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

core/assocs/assocs.factor

@@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : value-at ( value assoc -- key/f )
     swap [ = nip ] curry assoc-find 2drop ;
 
+: push-at ( value key assoc -- )
+    [ ?push ] change-at ;
+
 : zip ( keys values -- alist )
     2array flip ; inline
 

core/bit-arrays/bit-arrays-tests.factor

@@ -38,7 +38,7 @@ IN: bit-arrays.tests
 
 [ t ] [
     100 [
-        drop 100 [ drop 2 random zero? ] map
+        drop 100 [ 2 random zero? ] replicate
         dup >bit-array >array =
     ] all?
 ] unit-test

core/classes/algebra/algebra-tests.factor

@@ -204,7 +204,7 @@ UNION: z1 b1 c1 ;
 
 10 [
     [ ] [
-        20 [ drop random-op ] map >quotation
+        20 [ random-op ] [ ] replicate-as
         [ infer effect-in [ random-class ] times ] keep
         call
         drop
@@ -238,8 +238,8 @@ UNION: z1 b1 c1 ;
 
 20 [
     [ t ] [
-        20 [ drop random-boolean-op ] [ ] map-as dup .
+        20 [ random-boolean-op ] [ ] replicate-as dup .
-        [ infer effect-in [ drop random-boolean ] map dup . ] keep
+        [ infer effect-in [ random-boolean ] replicate dup . ] keep
         
         [ >r [ ] each r> call ] 2keep
         

core/grouping/grouping-tests.factor

@@ -10,3 +10,5 @@ IN: grouping.tests
     2 over set-length
     >array
 ] unit-test
+
+[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test

core/grouping/grouping.factor

@@ -56,7 +56,7 @@ M: clumps set-length
 M: clumps group@
     [ n>> over + ] [ seq>> ] bi ;
 
-TUPLE: sliced-clumps < groups ;
+TUPLE: sliced-clumps < clumps ;
 
 : <sliced-clumps> ( seq n -- clumps )
     sliced-clumps new-groups ; inline

core/inference/backend/backend.factor

@@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ;
     1 #drop node,
     pop-d dup value-literal >r value-recursion r> ;
 
-: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
+: value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
 
 : add-inputs ( seq stack -- n stack )
     tuck [ length ] bi@ - dup 0 >
@@ -162,7 +162,7 @@ TUPLE: too-many-r> ;
     dup ensure-values
     #>r
     over 0 pick node-inputs
-    over [ drop pop-d ] map reverse [ push-r ] each
+    over [ pop-d ] replicate reverse [ push-r ] each
     0 pick pick node-outputs
     node,
     drop ;
@@ -171,7 +171,7 @@ TUPLE: too-many-r> ;
     dup check-r>
     #r>
     0 pick pick node-inputs
-    over [ drop pop-r ] map reverse [ push-d ] each
+    over [ pop-r ] replicate reverse [ push-d ] each
     over 0 pick node-outputs
     node,
     drop ;

core/optimizer/def-use/def-use.factor

@@ -13,7 +13,7 @@ SYMBOL: def-use
     used-by empty? ;
 
 : uses-values ( node seq -- )
-    [ def-use get [ ?push ] change-at ] with each ;
+    [ def-use get push-at ] with each ;
 
 : defs-values ( seq -- )
     #! If there is no value, set it to a new empty vector,
@@ -132,5 +132,4 @@ M: #r> kill-node*
     #! degree of accuracy; the new values should be marked as
     #! having _some_ usage, so that flushing doesn't erronously
     #! flush them away.
-    nest-def-use keys
+    nest-def-use keys def-use get [ t -rot push-at ] curry each ;
-    def-use get [ [ t swap ?push ] change-at ] curry each ;

core/parser/parser-docs.factor

@@ -117,14 +117,18 @@ $nl
 { $subsection parse-tokens } ;
 
 ARTICLE: "parsing-words" "Parsing words"
-"The Factor parser is follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
+"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
 $nl
 "Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:"
 { $code ": hello \"Hello world\" print ; parsing" }
-"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
+"Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser."
+$nl
+"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
+$nl
+"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later."
 $nl
 "Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:"
-{ $link staging-violation }
+{ $subsection staging-violation }
 "Tools for implementing parsing words:"
 { $subsection "reading-ahead" }
 { $subsection "parsing-word-nest" }

core/sequences/sequences.factor

@@ -361,6 +361,12 @@ PRIVATE>
 : map ( seq quot -- newseq )
     over map-as ; inline
 
+: replicate ( seq quot -- newseq )
+    [ drop ] prepose map ; inline
+
+: replicate-as ( seq quot exemplar -- newseq )
+    >r [ drop ] prepose r> map-as ; inline
+
 : change-each ( seq quot -- )
     over map-into ; inline
 

core/sorting/sorting-tests.factor

@@ -11,7 +11,7 @@ unit-test
 [ t ] [
     100 [
         drop
-        100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic?
+        100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
     ] all?
 ] unit-test
 

core/strings/strings-tests.factor

@@ -98,7 +98,7 @@ unit-test
 [ ] [
     [
         4 [
-            100 [ drop "obdurak" clone ] map
+            100 [ "obdurak" clone ] replicate
             gc
             dup [
                 1234 0 rot set-string-nth

core/vectors/vectors-tests.factor

@@ -26,7 +26,7 @@ IN: vectors.tests
 [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
 
 [ t ] [
-    100 [ drop 100 random ] map >vector
+    100 [ 100 random ] V{ } map-as
     dup >array >vector =
 ] unit-test
 

extra/assocs/lib/lib.factor

@@ -17,9 +17,6 @@ IN: assocs.lib
 : replace-at ( assoc value key -- assoc )
     >r >r dup r> 1vector r> rot set-at ;
 
-: insert-at ( value key assoc -- )
-    [ ?push ] change-at ;
-
 : peek-at* ( assoc key -- obj ? )
     swap at* dup [ >r peek r> ] when ;
 
@@ -32,7 +29,7 @@ IN: assocs.lib
 : multi-assoc-each ( assoc quot -- )
     [ with each ] curry assoc-each ; inline
 
-: insert ( value variable -- ) namespace insert-at ;
+: insert ( value variable -- ) namespace push-at ;
 
 : generate-key ( assoc -- str )
     >r 32 random-bits >hex r>

extra/color-picker/color-picker.factor

@@ -24,7 +24,7 @@ M: color-preview model-changed
     [ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
 
 : <color-sliders> ( -- model gadget )
-    3 [ drop 0 0 0 255 <range> ] map
+    3 [ 0 0 0 255 <range> ] replicate
     dup [ range-model ] map <compose>
     swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;
 

extra/db/queries/queries.factor

@@ -195,3 +195,12 @@ M: db <count-statement> ( tuple class groups -- statement )
     ] { { } { } { } } nmake
     >r >r parse-sql 4drop r> r>
     <simple-statement> maybe-make-retryable do-select ;
+
+: create-index ( index-name table-name columns -- )
+    [
+        >r >r "create index " % % r> " on " % % r> "(" %
+        "," join % ")" %
+    ] "" make sql-command ;
+
+: drop-index ( index-name -- )
+    [ "drop index " % % ] "" make sql-command ;

extra/delegate/delegate.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser generic kernel classes words slots assocs
-sequences arrays vectors definitions prettyprint combinators.lib
+sequences arrays vectors definitions prettyprint
-math hashtables sets ;
+math hashtables sets macros namespaces ;
 IN: delegate
 
 : protocol-words ( protocol -- words )
@@ -23,7 +23,15 @@ M: tuple-class group-words
 
 : consult-method ( word class quot -- )
     [ drop swap first create-method ]
-    [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi
+    [
+        nip
+        [
+            over second saver %
+            %
+            dup second restorer %
+            first ,
+        ] [ ] make
+    ] 3bi
     define ;
 
 : change-word-prop ( word prop quot -- )

extra/furnace/actions/actions.factor

@@ -29,14 +29,10 @@ SYMBOL: rest
 
 CHLOE: validation-messages drop render-validation-messages ;
 
-TUPLE: action rest init display validate submit ;
+TUPLE: action rest authorize init display validate submit ;
 
 : new-action ( class -- action )
-    new
+    new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
-        [ ] >>init
-        [ <400> ] >>display
-        [ ] >>validate
-        [ <400> ] >>submit ;
 
 : <action> ( -- action )
     action new-action ;
@@ -46,18 +42,28 @@ TUPLE: action rest init display validate submit ;
 
 : handle-get ( action -- response )
     '[
-        ,
+        , dup display>> [
-        [ init>> call ]
+            {
-        [ drop flashed-variables restore-flash ]
+                [ init>> call ]
-        [ display>> call ]
+                [ authorize>> call ]
-        tri
+                [ drop flashed-variables restore-flash ]
+                [ display>> call ]
+            } cleave
+        ] [ drop <400> ] if
     ] with-exit-continuation ;
 
 : validation-failed ( -- * )
     request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
 
 : (handle-post) ( action -- response )
-    [ validate>> call ] [ submit>> call ] bi ;
+    '[
+        , dup submit>> [
+            [ validate>> call ]
+            [ authorize>> call ]
+            [ submit>> call ]
+            tri
+        ] [ drop <400> ] if
+    ] with-exit-continuation ;
 
 : param ( name -- value )
     params get at ;

extra/furnace/auth/login/login.factor

@@ -49,6 +49,10 @@ TUPLE: login < dispatcher users checksum ;
 
 TUPLE: protected < filter-responder description capabilities ;
 
+: <protected> ( responder -- protected )
+    protected new
+        swap >>responder ;
+
 : users ( -- provider )
     login get users>> ;
 
@@ -85,13 +89,17 @@ M: user-saver dispose
     "invalid username or password" validation-error
     validation-failed ;
 
+SYMBOL: description
+SYMBOL: capabilities
+
+: flashed-variables { description capabilities } ;
+
 : <login-action> ( -- action )
     <page-action>
         [
-            protected fget [
+            flashed-variables restore-flash
-                [ description>> "description" set-value ]
+            description get "description" set-value
-                [ capabilities>> words>strings "capabilities" set-value ] bi
+            capabilities get words>strings "capabilities" set-value
-            ] when*
         ] >>init
 
         { login "login" } >>template
@@ -200,7 +208,10 @@ M: user-saver dispose
             drop
 
             URL" $login" end-aside
-        ] >>submit ;
+        ] >>submit
+
+    <protected>
+        "edit your profile" >>description ;
 
 ! ! ! Password recovery
 
@@ -316,32 +327,36 @@ SYMBOL: lost-password-from
         ] >>submit ;
 
 ! ! ! Authentication logic
-: <protected> ( responder -- protected )
-    protected new
-        swap >>responder ;
-
 : show-login-page ( -- response )
     begin-aside
-    URL" $login/login" { protected } <flash-redirect> ;
+    protected get description>> description set
+    protected get capabilities>> capabilities set
+    URL" $login/login" flashed-variables <flash-redirect> ;
 
-: check-capabilities ( responder user -- ? )
+: login-required ( -- * )
-    [ capabilities>> ] bi@ subset? ;
+    show-login-page exit-with ;
+
+: have-capability? ( capability -- ? )
+    logged-in-user get capabilities>> member? ;
+
+: check-capabilities ( responder user/f -- ? )
+    dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ;
 
 M: protected call-responder* ( path responder -- response )
     dup protected set
-    uid dup [
+    dup logged-in-user get check-capabilities
-        users get-user 2dup check-capabilities [
+    [ call-next-method ] [ 2drop show-login-page ] if ;
-            [ logged-in-user set ] [ save-user-after ] bi
+
-            call-next-method
+: init-user ( -- )
-        ] [
+    uid [
-            3drop show-login-page
+        users get-user
-        ] if
+        [ logged-in-user set ]
-    ] [
+        [ save-user-after ] bi
-        3drop show-login-page
+    ] when* ;
-    ] if ;
 
 M: login call-responder* ( path responder -- response )
     dup login set
+    init-user
     call-next-method ;
 
 : <login-boilerplate> ( responder -- responder' )
@@ -359,10 +374,7 @@ M: login call-responder* ( path responder -- response )
 ! ! ! Configuration
 
 : allow-edit-profile ( login -- login )
-    <edit-profile-action> <protected>
+    <edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;
-        "edit your profile" >>description
-    <login-boilerplate>
-        "edit-profile" add-responder ;
 
 : allow-registration ( login -- login )
     <register-action> <login-boilerplate>

extra/furnace/furnace.factor

@@ -97,15 +97,22 @@ SYMBOL: exit-continuation
     dup empty?
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
 
-CHLOE: atom
+: a-url-path ( tag -- string )
-    [ children>string ]
+    [ "href" required-attr ] [ "rest" optional-attr value ] bi
-    [ "href" required-attr ]
+    [ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
-    [ "query" optional-attr parse-query-attr ] tri
+
-    <url>
+: a-url ( tag -- url )
-        swap >>query
+    dup "value" optional-attr
-        swap >>path
+    [ value ] [
-    adjust-url relative-to-request
+        <url>
-    add-atom-feed ;
+            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 ;
 
@@ -114,23 +121,11 @@ 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 ;
-        <a
-            dup link-attrs
-            dup "value" optional-attr [ value f ] [
-                [ "href" required-attr ]
-                [ "query" optional-attr parse-query-attr ]
-                bi
-            ] ?if
-            <url>
-                swap >>query
-                swap >>path
-            adjust-url relative-to-request =href
-        a>
-    ] with-scope ;
 
 CHLOE: a
     [ a-start-tag ]
@@ -158,11 +153,12 @@ CHLOE: a
     [
         [
             <form
-                "POST" =method
+                {
-                [ link-attrs ]
+                    [ link-attrs ]
-                [ "action" required-attr resolve-base-path =action ]
+                    [ "method" optional-attr "post" or =method ]
-                [ tag-attrs non-chloe-attrs-only print-attrs ]
+                    [ "action" required-attr resolve-base-path =action ]
-                tri
+                    [ tag-attrs non-chloe-attrs-only print-attrs ]
+                } cleave
             form>
         ]
         [ form-magic ] bi

extra/gap-buffer/cursortree/cursortree.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Alex Chapman All Rights Reserved.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math
+USING: assocs kernel gap-buffer generic trees trees.avl math
 sequences quotations ;
 IN: gap-buffer.cursortree
 
@@ -21,7 +21,7 @@ TUPLE: right-cursor ;
 
 : cursor-index ( cursor -- i ) cursor-i ;
 
-: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ; 
+: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ; 
 
 : remove-cursor ( cursortree cursor -- )
     tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;

extra/help/lint/lint.factor

@@ -114,7 +114,7 @@ M: help-error error.
     H{ } clone [
         [
             >r >r dup >link where dup
-            [ first r> at r> [ ?push ] change-at ]
+            [ first r> at r> push-at ]
             [ r> r> 2drop 2drop ]
             if
         ] 2curry each

extra/html/templates/chloe/chloe-tests.factor

@@ -151,7 +151,7 @@ TUPLE: person first-name last-name ;
 
 [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
 
-[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
+[ "<form method='post' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
     [
         "test10" test-template call-template
     ] run-template

extra/http/http-tests.factor

@@ -7,7 +7,7 @@ IN: http.tests
 : lf>crlf "\n" split "\r\n" join ;
 
 STRING: read-request-test-1
-POST http://foo/bar HTTP/1.1
+POST /bar HTTP/1.1
 Some-Header: 1
 Some-Header: 2
 Content-Length: 4
@@ -18,7 +18,7 @@ blah
 
 [
     TUPLE{ request
-        url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
+        url: TUPLE{ url path: "/bar" }
         method: "POST"
         version: "1.1"
         header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
@@ -49,14 +49,14 @@ read-request-test-1' 1array [
 ] unit-test
 
 STRING: read-request-test-2
-HEAD  http://foo/bar   HTTP/1.1
+HEAD  /bar   HTTP/1.1
 Host: www.sex.com
 
 ;
 
 [
     TUPLE{ request
-        url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
+        url: TUPLE{ url host: "www.sex.com" path: "/bar" }
         method: "HEAD"
         version: "1.1"
         header: H{ { "host" "www.sex.com" } }

extra/http/http.factor

@@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger
 strings vectors hashtables quotations arrays byte-arrays
 math.parser calendar calendar.format present
 
-io io.server io.sockets.secure
+io io.encodings.iana io.encodings.binary io.encodings.8-bit
-io.encodings.iana io.encodings.binary io.encodings.8-bit
 
 unicode.case unicode.categories qualified
 
@@ -142,7 +141,6 @@ cookies ;
     request new
         "1.1" >>version
         <url>
-            "http" >>protocol
             H{ } clone >>query
         >>url
         H{ } clone >>header
@@ -202,7 +200,6 @@ TUPLE: post-data raw content content-type ;
 : extract-host ( request -- request )
     [ ] [ url>> ] [ "host" header parse-host ] tri
     [ >>host ] [ >>port ] bi*
-    ensure-port
     drop ;
 
 : extract-cookies ( request -- request )
@@ -214,9 +211,6 @@ TUPLE: post-data raw content content-type ;
 : parse-content-type ( content-type -- type encoding )
     ";" split1 parse-content-type-attributes "charset" swap at ;
 
-: detect-protocol ( request -- request )
-    dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
-
 : read-request ( -- request )
     <request>
     read-method
@@ -224,7 +218,6 @@ TUPLE: post-data raw content content-type ;
     read-request-version
     read-request-header
     read-post-data
-    detect-protocol
     extract-host
     extract-cookies ;
 

extra/http/server/redirection/redirection.factor

@@ -1,10 +1,14 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators namespaces
+USING: kernel accessors combinators namespaces strings
 logging urls http http.server http.server.responses ;
 IN: http.server.redirection
 
-: relative-to-request ( url -- url' )
+GENERIC: relative-to-request ( url -- url' )
+
+M: string relative-to-request ;
+
+M: url relative-to-request
     request get url>>
         clone
         f >>query

extra/http/server/server.factor

@@ -2,16 +2,18 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences arrays namespaces splitting
 vocabs.loader destructors assocs debugger continuations
-tools.vocabs math
+combinators tools.vocabs math
 io
 io.server
+io.sockets
+io.sockets.secure
 io.encodings
 io.encodings.utf8
 io.encodings.ascii
 io.encodings.binary
 io.streams.limited
 io.timeouts
-fry logging calendar
+fry logging calendar urls
 http
 http.server.responses
 html.elements
@@ -66,7 +68,7 @@ main-responder global [ <404> <trivial-responder> or ] change-at
             [
                 utf8 [
                     development-mode get
-                    [ http-error. ] [ drop "Response error" throw ] if
+                    [ http-error. ] [ drop "Response error" rethrow ] if
                 ] with-encoded-output
             ] recover
         ] if
@@ -88,12 +90,26 @@ LOG: httpd-hit NOTICE
 : dispatch-request ( request -- response )
     url>> path>> split-path main-responder get call-responder ;
 
+: prepare-request ( request -- request )
+    [
+        local-address get
+        [ secure? "https" "http" ? >>protocol ]
+        [ port>> '[ , or ] change-port ]
+        bi
+    ] change-url ;
+
+: valid-request? ( request -- ? )
+    url>> port>> local-address get port>> = ;
+
 : do-request ( request -- response )
     '[
         ,
-        [ init-request ]
+        {
-        [ log-request ]
+            [ init-request ]
-        [ dispatch-request ] tri
+            [ prepare-request ]
+            [ log-request ]
+            [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
+        } cleave
     ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
 
 : ?refresh-all ( -- )

extra/io/files/unique/unique.factor

@@ -15,7 +15,7 @@ IN: io.files.unique
     [ 10 random CHAR: 0 + ] [ random-letter ] if ;
 
 : random-name ( n -- string )
-    [ drop random-ch ] "" map-as ;
+    [ random-ch ] "" replicate-as ;
 
 : unique-length ( -- n ) 10 ; inline
 : unique-retries ( -- n ) 10 ; inline

extra/io/pipes/pipes.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.encodings io.backend io.ports io.streams.duplex
-io splitting grouping sequences sequences.lib namespaces kernel
+io splitting grouping sequences namespaces kernel
 destructors math concurrency.combinators accessors
 arrays continuations quotations ;
 IN: io.pipes

extra/io/pools/pools.factor

@@ -10,7 +10,7 @@ TUPLE: pool connections disposed expired ;
     dup check-disposed
     dup expired>> expired? [
         ALIEN: 31337 >>expired
-        connections>> [ delete-all ] [ dispose-each ] bi
+        connections>> delete-all
     ] [ drop ] if ;
 
 : <pool> ( class -- pool )
@@ -34,6 +34,7 @@ GENERIC: make-connection ( pool -- conn )
     dup check-pool [ make-connection ] keep return-connection ;
 
 : acquire-connection ( pool -- conn )
+    dup check-pool
     [ dup connections>> empty? ] [ dup new-connection ] [ ] while
     connections>> pop ;
 

extra/io/server/server-tests.factor

@@ -2,6 +2,6 @@ IN: io.server.tests
 USING: tools.test io.server io.server.private kernel ;
 
 { 2 0 } [ [ ] server-loop ] must-infer-as
-{ 2 0 } [ [ ] with-connection ] must-infer-as
+{ 3 0 } [ [ ] with-connection ] must-infer-as
 { 1 0 } [ [ ] swap datagram-loop ] must-infer-as
 { 2 0 } [ [ ] with-datagrams ] must-infer-as

extra/io/server/server.factor

@@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files
 io.streams.duplex logging continuations destructors kernel math
 math.parser namespaces parser sequences strings prettyprint
 debugger quotations calendar threads concurrency.combinators
-assocs fry ;
+assocs fry accessors ;
 IN: io.server
 
 SYMBOL: servers
@@ -15,9 +15,10 @@ SYMBOL: remote-address
 
 LOG: accepted-connection NOTICE
 
-: with-connection ( client remote quot -- )
+: with-connection ( client remote local quot -- )
     '[
         , [ remote-address set ] [ accepted-connection ] bi
+        , local-address set
         @
     ] with-stream ; inline
 
@@ -25,7 +26,8 @@ LOG: accepted-connection NOTICE
 
 : accept-loop ( server quot -- )
     [
-        >r accept r> '[ , , , with-connection ] "Client" spawn drop
+        [ [ accept ] [ addr>> ] bi ] dip
+        '[ , , , , with-connection ] "Client" spawn drop
     ] 2keep accept-loop ; inline
 
 : server-loop ( addrspec encoding quot -- )
@@ -59,7 +61,7 @@ LOG: received-datagram NOTICE
 
 : datagram-loop ( quot datagram -- )
     [
-        [ receive dup received-datagram >r swap call r> ] keep
+        [ receive dup received-datagram [ swap call ] dip ] keep
         pick [ send ] [ 3drop ] if
     ] 2keep datagram-loop ; inline
 

extra/io/streams/duplex/duplex.factor

@@ -5,9 +5,6 @@ io.encodings.private io.timeouts debugger inspector listener
 accessors delegate delegate.protocols ;
 IN: io.streams.duplex
 
-! We ensure that the stream can only be closed once, to preserve
-! integrity of duplex I/O ports.
-
 TUPLE: duplex-stream in out ;
 
 C: <duplex-stream> duplex-stream

extra/io/unix/backend/backend.factor

@@ -44,14 +44,11 @@ TUPLE: mx fd reads writes ;
 
 GENERIC: add-input-callback ( thread fd mx -- )
 
-: add-callback ( thread fd assoc -- )
+M: mx add-input-callback reads>> push-at ;
-    [ ?push ] change-at ;
-
-M: mx add-input-callback reads>> add-callback ;
 
 GENERIC: add-output-callback ( thread fd mx -- )
 
-M: mx add-output-callback writes>> add-callback ;
+M: mx add-output-callback writes>> push-at ;
 
 GENERIC: remove-input-callbacks ( fd mx -- callbacks )
 

extra/koszul/koszul.factor

@@ -142,7 +142,7 @@ DEFER: (d)
 
 ! Computing a basis
 : graded ( seq -- seq )
-    dup 0 [ length max ] reduce 1+ [ drop V{ } clone ] map
+    dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
     [ dup length pick nth push ] reduce ;
 
 : nth-basis-elt ( generators n -- elt )

extra/lcs/lcs-tests.factor

@@ -2,6 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test lcs ;
 
+\ lcs must-infer
+\ diff must-infer
+\ levenshtein must-infer
+
 [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
 [ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
 [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test

extra/lcs/lcs.factor

@@ -63,15 +63,19 @@ TUPLE: trace-state old new table i j ;
     [ 1- ] change-i [ 1- ] change-j ;
 
 : inserted? ( state -- ? )
-    [ j>> 0 > ]
+    {
-    [ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;
+        [ j>> 0 > ]
+        [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]
+    } 1&& ;
 
 : do-insert ( state -- state )
     dup new-nth insert boa , [ 1- ] change-j ;
 
 : deleted? ( state -- ? )
-    [ i>> 0 > ]
+    {
-    [ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;
+        [ i>> 0 > ]
+        [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]
+    } 1&& ;
 
 : do-delete ( state -- state )
     dup old-nth delete boa , [ 1- ] change-i ;

extra/project-euler/150/150.factor

@@ -17,9 +17,6 @@ IN: project-euler.150
 : partial-sum-infimum ( seq -- seq )
     0 0 rot [ (partial-sum-infimum) ] each drop ; inline
 
-: generate ( n quot -- seq )
-    [ drop ] prepose map ; inline
-
 : map-infimum ( seq quot -- min )
     [ min ] compose 0 swap reduce ; inline
 
@@ -30,7 +27,7 @@ IN: project-euler.150
     615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
 
 : sums-triangle ( -- seq )
-    0 1000 [ 1+ [ next ] generate partial-sums ] map nip ; 
+    0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ; 
 
 PRIVATE>
 

extra/sequences/lib/lib.factor

@@ -131,10 +131,6 @@ MACRO: firstn ( n -- )
     [ find drop [ head-slice ] when* ] curry
     [ dup ] prepose keep like ;
 
-: replicate ( seq quot -- newseq )
-    #! quot: ( -- obj )
-    [ drop ] prepose map ; inline
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 <PRIVATE
@@ -244,20 +240,6 @@ PRIVATE>
 : short ( seq n -- seq n' )
     over length min ; inline
 
-<PRIVATE
-:: insert ( seq quot n -- )
-    n zero? [
-        n n 1- [ seq nth quot call ] bi@ >= [
-            n n 1- seq exchange
-            seq quot n 1- insert
-        ] unless
-    ] unless ; inline
-PRIVATE>
-
-: insertion-sort ( seq quot -- )
-    ! quot is a transformation on elements
-    over length [ insert ] 2with each ; inline
-
 : if-seq ( seq quot1 quot2 -- )
     [ f like ] 2dip if* ; inline
 

extra/sorting/insertion/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

extra/sorting/insertion/insertion.factor

@@ -0,0 +1,16 @@
+USING: locals sequences kernel math ;
+IN: sorting.insertion
+
+<PRIVATE
+:: insert ( seq quot n -- )
+    n zero? [
+        n n 1- [ seq nth quot call ] bi@ >= [
+            n n 1- seq exchange
+            seq quot n 1- insert
+        ] unless
+    ] unless ; inline
+PRIVATE>
+
+: insertion-sort ( seq quot -- )
+    ! quot is a transformation on elements
+    over length [ insert ] with with each ; inline

extra/sorting/insertion/summary.txt

@@ -0,0 +1 @@
+Insertion sort

extra/sorting/insertion/tags.txt

@@ -0,0 +1 @@
+collections

extra/state-parser/state-parser.factor

@@ -144,7 +144,7 @@ M: not-enough-characters summary ( obj -- str )
     ] if next ;
 
 : expect-string ( string -- )
-    dup [ drop get-char next ] map 2dup =
+    dup [ get-char next ] replicate 2dup =
     [ 2drop ] [ expected ] if ;
 
 : init-parser ( -- )

extra/strings/lib/lib-tests.factor

@@ -5,4 +5,4 @@ IN: temporary
 [ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
 [ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
 [ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
-[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test
+[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test

extra/strings/lib/lib.factor

@@ -30,5 +30,4 @@ IN: strings.lib
     alphanumeric-chars random ;
 
 : random-alphanumeric-string ( length -- str )
-    [ drop random-alphanumeric-char ] map "" like ;
+    [ random-alphanumeric-char ] "" replicate-as ;
-

extra/ui/gadgets/frames/frames.factor

@@ -8,7 +8,7 @@ IN: ui.gadgets.frames
 ! gadgets gets left-over space.
 TUPLE: frame ;
 
-: <frame-grid> ( -- grid ) 9 [ drop <gadget> ] map 3 group ;
+: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
 
 : @center 1 1 ;
 : @left 0 1 ;

extra/unicode/breaks/breaks.factor

@@ -23,8 +23,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
 
 CATEGORY: (extend) Me Mn ;
 : extend? ( ch -- ? )
-    [ (extend)? ]
+    { [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ;
-    [ "Other_Grapheme_Extend" property? ] or? ;
 
 : grapheme-class ( ch -- class )
     {
@@ -35,7 +34,7 @@ CATEGORY: (extend) Me Mn ;
     } cond ;
 
 : init-grapheme-table ( -- table )
-    graphemes [ drop graphemes f <array> ] map ;
+    graphemes [ graphemes f <array> ] replicate ;
 
 SYMBOL: table
 

extra/unicode/collation/collation.factor

@@ -58,8 +58,7 @@ ducet insert-helpers
     HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;
 
 : illegal? ( char -- ? )
-    [ "Noncharacter_Code_Point" property? ]
+    { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;
-    [ category "Cs" = ] or? ;
 
 : derive-weight ( char -- weights )
     first dup illegal?

extra/unicode/data/data.factor

@@ -1,7 +1,7 @@
 USING: assocs math kernel sequences io.files hashtables
 quotations splitting grouping arrays math.parser hash2 math.order
 byte-arrays words namespaces words compiler.units parser
-io.encodings.ascii values interval-maps ascii sets assocs.lib
+io.encodings.ascii values interval-maps ascii sets
 combinators.lib combinators locals math.ranges sorting ;
 IN: unicode.data
 
@@ -62,7 +62,7 @@ VALUE: properties
     dup [ swap (chain-decomposed) ] curry assoc-map ;
 
 : first* ( seq -- ? )
-    second [ empty? ] [ first ] or? ;
+    second { [ empty? ] [ first ] } 1|| ;
 
 : (process-decomposed) ( data -- alist )
     5 swap (process-data)
@@ -107,7 +107,7 @@ VALUE: properties
 
 :: fill-ranges ( table -- table )
     name-map >alist sort-values keys
-    [ [ "first>" tail? ] [ "last>" tail? ] or? ] filter
+    [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
     2 group [
         [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
         [ swap table ?set-nth ] curry each
@@ -151,7 +151,7 @@ C: <code-point> code-point
 
 : properties>intervals ( properties -- assoc[str,interval] )
     dup values prune [ f ] H{ } map>assoc
-    [ [ insert-at ] curry assoc-each ] keep
+    [ [ push-at ] curry assoc-each ] keep
     [ <interval-set> ] assoc-map ;
 
 : load-properties ( -- assoc )

extra/unicode/normalize/normalize.factor

@@ -1,5 +1,5 @@
 USING: sequences namespaces unicode.data kernel math arrays
-locals combinators.lib sequences.lib combinators.lib ;
+locals combinators.lib sorting.insertion combinators.lib ;
 IN: unicode.normalize
 
 ! Conjoining Jamo behavior

extra/webapps/blogs/blogs.factor

@@ -1,24 +1,33 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sorting math.order math.parser
-urls validators html.components db.types db.tuples calendar
+urls validators html.components db db.types db.tuples calendar
-http.server.dispatchers
+present http.server.dispatchers
-furnace furnace.actions furnace.auth.login furnace.boilerplate
+furnace
-furnace.sessions furnace.syndication ;
+furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.boilerplate
+furnace.sessions
+furnace.syndication ;
 IN: webapps.blogs
 
 TUPLE: blogs < dispatcher ;
 
+SYMBOL: can-administer-blogs?
+
+can-administer-blogs? define-capability
+
 : view-post-url ( id -- url )
-    number>string "$blogs/post/" prepend >url ;
+    present "$blogs/post/" prepend >url ;
 
 : view-comment-url ( parent id -- url )
     [ view-post-url ] dip >>anchor ;
 
 : list-posts-url ( -- url )
-    URL" $blogs/" ;
+    "$blogs/" >url ;
 
-: user-posts-url ( author -- url )
+: posts-by-url ( author -- url )
     "$blogs/by/" prepend >url ;
 
 TUPLE: entity id author date content ;
@@ -39,7 +48,7 @@ M: entity feed-entry-date date>> ;
 TUPLE: post < entity title comments ;
 
 M: post feed-entry-title
-    [ author>> ] [ drop ": " ] [ title>> ] tri 3append ;
+    [ author>> ] [ title>> ] bi ": " swap 3append ;
 
 M: post entity-url
     id>> view-post-url ;
@@ -79,19 +88,16 @@ M: comment entity-url
     [ [ date>> ] compare invert-comparison ] sort ;
 
 : validate-author ( -- )
-    { { "author" [ [ v-username ] v-optional ] } } validate-params ;
+    { { "author" [ v-username ] } } validate-params ;
 
 : list-posts ( -- posts )
     f <post> "author" value >>author
-    select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
+    select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
     reverse-chronological-order ;
 
 : <list-posts-action> ( -- action )
     <page-action>
-        [
+        [ list-posts "posts" set-value ] >>init
-            list-posts "posts" set-value
-        ] >>init
-
         { blogs "list-posts" } >>template ;
 
 : <list-posts-feed-action> ( -- action )
@@ -100,21 +106,24 @@ M: comment entity-url
         [ list-posts ] >>entries
         [ list-posts-url ] >>url ;
 
-: <user-posts-action> ( -- action )
+: <posts-by-action> ( -- action )
     <page-action>
+
         "author" >>rest
+
         [
             validate-author
             list-posts "posts" set-value
         ] >>init
-        { blogs "user-posts" } >>template ;
 
-: <user-posts-feed-action> ( -- action )
+        { blogs "posts-by" } >>template ;
+
+: <posts-by-feed-action> ( -- action )
     <feed-action>
         [ validate-author ] >>init
         [ "Recent Posts by " "author" value append ] >>title
         [ list-posts ] >>entries
-        [ "author" value user-posts-url ] >>url ;
+        [ "author" value posts-by-url ] >>url ;
 
 : <post-feed-action> ( -- action )
     <feed-action>
@@ -125,6 +134,7 @@ M: comment entity-url
 
 : <view-post-action> ( -- action )
     <page-action>
+
         "id" >>rest
 
         [
@@ -147,6 +157,7 @@ M: comment entity-url
 
 : <new-post-action> ( -- action )
     <page-action>
+
         [
             validate-post
             uid "author" set-value
@@ -160,38 +171,76 @@ M: comment entity-url
             [ insert-tuple ] [ entity-url <redirect> ] bi
         ] >>submit
 
-        { blogs "new-post" } >>template ;
+        { blogs "new-post" } >>template
+
+     <protected>
+        "make a new blog post" >>description ;
+
+: authorize-author ( author -- )
+    uid = can-administer-blogs? have-capability? or
+    [ login-required ] unless ;
+
+: do-post-action ( -- )
+    validate-integer-id
+    "id" value <post> select-tuple from-object ;
 
 : <edit-post-action> ( -- action )
     <page-action>
-        [
+
-            validate-integer-id
+        "id" >>rest
-            "id" value <post> select-tuple from-object
+
-        ] >>init
+        [ do-post-action ] >>init
+
+        [ do-post-action validate-post ] >>validate
+
+        [ "author" value authorize-author ] >>authorize
 
         [
-            validate-integer-id
+            "id" value <post>
-            validate-post
+            dup { "title" "author" "date" "content" } deposit-slots
-        ] >>validate
-
-        [
-            "id" value <post> select-tuple
-                dup { "title" "content" } deposit-slots
             [ update-tuple ] [ entity-url <redirect> ] bi
         ] >>submit
 
-        { blogs "edit-post" } >>template ;
+        { blogs "edit-post" } >>template
-    
+
+    <protected>
+        "edit a blog post" >>description ;
+
+: delete-post ( id -- )
+    [ <post> delete-tuples ] [ f <comment> delete-tuples ] bi ;
+
 : <delete-post-action> ( -- action )
     <action>
+
+        [ do-post-action ] >>validate
+
+        [ "author" value authorize-author ] >>authorize
+
         [
-            validate-integer-id
+            [ "id" value delete-post ] with-transaction
-            { { "author" [ v-username ] } } validate-params
+            "author" value posts-by-url <redirect>
-        ] >>validate
+        ] >>submit
+
+     <protected>
+        "delete a blog post" >>description ;
+
+: <delete-author-action> ( -- action )
+    <action>
+
+        [ validate-author ] >>validate
+
+        [ "author" value authorize-author ] >>authorize
+
         [
-            "id" value <post> delete-tuples
+            [
-            "author" value user-posts-url <redirect>
+                f <post> "author" value >>author select-tuples [ id>> delete-post ] each
-        ] >>submit ;
+                f f <comment> "author" value >>author delete-tuples
+            ] with-transaction
+            "author" value posts-by-url <redirect>
+        ] >>submit
+
+     <protected>
+        "delete a blog post" >>description ;
 
 : validate-comment ( -- )
     {
@@ -213,41 +262,44 @@ M: comment entity-url
                 uid >>author
                 now >>date
             [ insert-tuple ] [ entity-url <redirect> ] bi
-        ] >>submit ;
+        ] >>submit
-    
+
+     <protected>
+        "make a comment" >>description ;
+
 : <delete-comment-action> ( -- action )
     <action>
+
         [
             validate-integer-id
             { { "parent" [ v-integer ] } } validate-params
         ] >>validate
+
+        [
+            "parent" value <post> select-tuple
+            author>> authorize-author
+        ] >>authorize
+
         [
             f "id" value <comment> delete-tuples
             "parent" value view-post-url <redirect>
-        ] >>submit ;
+        ] >>submit
-    
+
+        <protected>
+            "delete a comment" >>description ;
+
 : <blogs> ( -- dispatcher )
     blogs new-dispatcher
         <list-posts-action> "" add-responder
         <list-posts-feed-action> "posts.atom" add-responder
-        <user-posts-action> "by" add-responder
+        <posts-by-action> "by" add-responder
-        <user-posts-feed-action> "by.atom" add-responder
+        <posts-by-feed-action> "by.atom" add-responder
         <view-post-action> "post" add-responder
         <post-feed-action> "post.atom" add-responder
-        <new-post-action> <protected>
+        <new-post-action> "new-post" add-responder
-            "make a new blog post" >>description
+        <edit-post-action> "edit-post" add-responder
-            "new-post" add-responder
+        <delete-post-action> "delete-post" add-responder
-        <edit-post-action> <protected>
+        <new-comment-action> "new-comment" add-responder
-            "edit a blog post" >>description
+        <delete-comment-action> "delete-comment" add-responder
-            "edit-post" add-responder
-        <delete-post-action> <protected>
-            "delete a blog post" >>description
-            "delete-post" add-responder
-        <new-comment-action> <protected>
-            "make a comment" >>description
-            "new-comment" add-responder
-        <delete-comment-action> <protected>
-            "delete a comment" >>description
-            "delete-comment" add-responder
     <boilerplate>
         { blogs "blogs-common" } >>template ;

extra/webapps/blogs/edit-post.xml

@@ -15,13 +15,13 @@
 
 	<div class="posting-footer">
 		Post by
-		<t:a t:href="$blogs/" t:query="author">
+		<t:a t:href="$blogs/by" t:rest="author">
 			<t:label t:name="author" />
 		</t:a>
 		on
 		<t:label t:name="date" />
 		|
-		<t:a t:href="$blogs/post" t:for="id">View Post</t:a>
+		<t:a t:href="$blogs/post" t:rest="id">View Post</t:a>
 		|
 		<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
 	</div>

extra/webapps/blogs/list-posts.xml

@@ -7,7 +7,7 @@
 	<t:bind-each t:name="posts">
 
 		<h2 class="post-title">
-			<t:a t:href="$blogs/post" t:query="id">
+			<t:a t:href="$blogs/post" t:rest="id">
 				<t:label t:name="title" />
 			</t:a>
 		</h2>
@@ -18,13 +18,13 @@
 
 		<div class="posting-footer">
 			Post by
-			<t:a t:href="$blogs/by" t:query="author">
+			<t:a t:href="$blogs/by" t:rest="author">
 				<t:label t:name="author" />
 			</t:a>
 			on
 			<t:label t:name="date" />
 			|
-			<t:a t:href="$blogs/post" t:query="id">
+			<t:a t:href="$blogs/post" t:rest="id">
 				<t:label t:name="comments" />
 				comments.
 			</t:a>

extra/webapps/blogs/posts-by.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:atom t:href="$blogs/by" t:query="author">
+	<t:atom t:href="$blogs/by" t:rest="author">
 		Recent Posts by <t:label t:name="author" />
 	</t:atom>
 
@@ -13,7 +13,7 @@
 	<t:bind-each t:name="posts">
 
 		<h2 class="post-title">
-			<t:a t:href="$blogs/post" t:query="id">
+			<t:a t:href="$blogs/post" t:rest="id">
 				<t:label t:name="title" />
 			</t:a>
 		</h2>
@@ -24,13 +24,13 @@
 
 		<div class="posting-footer">
 			Post by
-			<t:a t:href="$blogs/by" t:query="author">
+			<t:a t:href="$blogs/by" t:rest="author">
 				<t:label t:name="author" />
 			</t:a>
 			on
 			<t:label t:name="date" />
 			|
-			<t:a t:href="$blogs/post" t:query="id">
+			<t:a t:href="$blogs/post" t:rest="id">
 				<t:label t:name="comments" />
 				comments.
 			</t:a>

extra/webapps/blogs/view-post.xml

@@ -2,11 +2,11 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:atom t:href="$blogs/post.atom" t:query="id">
+	<t:atom t:href="$blogs/post.atom" t:rest="id">
 		<t:label t:name="author" />: <t:label t:name="title" />
 	</t:atom>
 
-	<t:atom t:href="$blogs/by.atom" t:query="author">
+	<t:atom t:href="$blogs/by.atom" t:rest="author">
 		Recent Posts by <t:label t:name="author" />
 	</t:atom>
 
@@ -18,13 +18,13 @@
 
 	<div class="posting-footer">
 		Post by
-		<t:a t:href="$blogs/" t:query="author">
+		<t:a t:href="$blogs/" t:rest="author">
 			<t:label t:name="author" />
 		</t:a>
 		on
 		<t:label t:name="date" />
 		|
-		<t:a t:href="$blogs/edit-post" t:query="id">Edit Post</t:a>
+		<t:a t:href="$blogs/edit-post" t:rest="id">Edit Post</t:a>
 		|
 		<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
 	</div>
@@ -33,7 +33,7 @@
 		<hr/>
 
 		<p class="comment-header">
-			Comment by <t:label t:name="author" /> on <t:label t:name="date" />:
+			<a name="@id">Comment by <t:label t:name="author" /> on <t:label t:name="date" />:</a>
 		</p>
 
 		<p class="posting-body">

extra/webapps/pastebin/pastebin.factor

@@ -19,6 +19,10 @@ IN: webapps.pastebin
 
 TUPLE: pastebin < dispatcher ;
 
+SYMBOL: can-delete-pastes?
+
+can-delete-pastes? define-capability
+
 ! ! !
 ! DOMAIN MODEL
 ! ! !
@@ -170,13 +174,20 @@ M: annotation entity-url
 
 : <delete-paste-action> ( -- action )
     <action>
+
         [ validate-integer-id ] >>validate
 
         [
-            "id" value <paste> delete-tuples
+            [
-            "id" value f <annotation> delete-tuples
+                "id" value <paste> delete-tuples
+                "id" value f <annotation> delete-tuples
+            ] with-transaction
             URL" $pastebin/list" <redirect>
-        ] >>submit ;
+        ] >>submit
+
+        <protected>
+            "delete pastes" >>description
+            { can-delete-pastes? } >>capabilities ;
 
 ! ! !
 ! ANNOTATIONS
@@ -199,6 +210,7 @@ M: annotation entity-url
 
 : <delete-annotation-action> ( -- action )
     <action>
+
         [ { { "id" [ v-number ] } } validate-params ] >>validate
 
         [
@@ -206,11 +218,11 @@ M: annotation entity-url
             [ delete-tuples ]
             [ parent>> paste-url <redirect> ]
             bi
-        ] >>submit ;
+        ] >>submit
 
-SYMBOL: can-delete-pastes?
+    <protected>
-
+        "delete annotations" >>description
-can-delete-pastes? define-capability
+        { can-delete-pastes? } >>capabilities ;
 
 : <pastebin> ( -- responder )
     pastebin new-dispatcher
@@ -219,13 +231,9 @@ can-delete-pastes? define-capability
         <paste-action> "paste" add-responder
         <paste-feed-action> "paste.atom" add-responder
         <new-paste-action> "new-paste" add-responder
-        <delete-paste-action> <protected>
+        <delete-paste-action> "delete-paste" add-responder
-            "delete pastes" >>description
-            { can-delete-pastes? } >>capabilities "delete-paste" add-responder
         <new-annotation-action> "new-annotation" add-responder
-        <delete-annotation-action> <protected>
+        <delete-annotation-action> "delete-annotation" add-responder
-            "delete annotations" >>description
-            { can-delete-pastes? } >>capabilities "delete-annotation" add-responder
     <boilerplate>
         { pastebin "pastebin-common" } >>template ;
 

extra/webapps/planet/planet.factor

@@ -18,6 +18,10 @@ IN: webapps.planet
 
 TUPLE: planet-factor < dispatcher ;
 
+SYMBOL: can-administer-planet-factor?
+
+can-administer-planet-factor? define-capability
+
 TUPLE: planet-factor-admin < dispatcher ;
 
 TUPLE: blog id name www-url feed-url ;
@@ -30,8 +34,8 @@ blog "BLOGS"
 {
     { "id" "ID" INTEGER +db-assigned-id+ }
     { "name" "NAME" { VARCHAR 256 } +not-null+ }
-    { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
+    { "www-url" "WWWURL" URL +not-null+ }
-    { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
+    { "feed-url" "FEEDURL" URL +not-null+ }
 } define-persistent
 
 TUPLE: posting < entry id ;
@@ -40,7 +44,7 @@ posting "POSTINGS"
 {
     { "id" "ID" INTEGER +db-assigned-id+ }
     { "title" "TITLE" { VARCHAR 256 } +not-null+ }
-    { "url" "LINK" { VARCHAR 256 } +not-null+ }
+    { "url" "LINK" URL +not-null+ }
     { "description" "DESCRIPTION" TEXT +not-null+ }
     { "date" "DATE" TIMESTAMP +not-null+ }
 } define-persistent
@@ -134,6 +138,7 @@ posting "POSTINGS"
 
 : <new-blog-action> ( -- action )
     <page-action>
+
         { planet-factor "new-blog" } >>template
 
         [ validate-blog ] >>validate
@@ -150,9 +155,10 @@ posting "POSTINGS"
             ]
             tri
         ] >>submit ;
-    
+
 : <edit-blog-action> ( -- action )
     <page-action>
+
         [
             validate-integer-id
             "id" value <blog> select-tuple from-object
@@ -184,20 +190,16 @@ posting "POSTINGS"
         <update-action> "update" add-responder
         <new-blog-action> "new-blog" add-responder
         <edit-blog-action> "edit-blog" add-responder
-        <delete-blog-action> "delete-blog" add-responder ;
+        <delete-blog-action> "delete-blog" add-responder
-
+    <protected>
-SYMBOL: can-administer-planet-factor?
+        "administer Planet Factor" >>description
-
+        { can-administer-planet-factor? } >>capabilities ;
-can-administer-planet-factor? define-capability
 
 : <planet-factor> ( -- responder )
     planet-factor new-dispatcher
         <planet-action> "list" add-main-responder
         <planet-feed-action> "feed.xml" add-responder
-        <planet-factor-admin> <protected>
+        <planet-factor-admin> "admin" add-responder
-            "administer Planet Factor" >>description
-            { can-administer-planet-factor? } >>capabilities
-        "admin" add-responder
     <boilerplate>
         { planet-factor "planet-common" } >>template ;
 

extra/webapps/wee-url/wee-url.factor

@@ -26,7 +26,7 @@ short-url "SHORT_URLS" {
     3append ; foldable
 
 : random-url ( -- string )
-    1 6 [a,b] random [ drop letter-bank random ] "" map-as ;
+    1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
 
 : insert-short-url ( short-url -- short-url )
     '[ , dup random-url >>short insert-tuple ] 10 retry ;

extra/webapps/wiki/articles.xml

@@ -7,7 +7,7 @@
 	<ul>
 		<t:bind-each t:name="articles">
 			<li>
-				<t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
+				<t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title"/></t:a>
 			</li>
 		</t:bind-each>
 	</ul>

extra/webapps/wiki/changes.xml

@@ -4,16 +4,26 @@
 
 	<t:title>Recent Changes</t:title>
 
-	<ul>
+	<div class="revisions">
-		<t:bind-each t:name="changes">
+
-			<li>
+		<table>
-				<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
+
-				on
+			<tr>
-				<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+				<th>Article</th>
-				by
+				<th>Date</th>
-				<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
+				<th>By</th>
-			</li>
+			</tr>
-		</t:bind-each>
+
-	</ul>
+			<t:bind-each t:name="changes">
+				<tr>
+					<td><t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a></td>
+					<td><t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a></td>
+					<td><t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a></td>
+				</tr>
+			</t:bind-each>
+
+		</table>
+
+	</div>
 
 </t:chloe>

extra/webapps/wiki/diff.xml

@@ -8,13 +8,13 @@
 		<tr>
 			<th class="field-label">Old revision:</th>
 			<t:bind t:name="old">
-				<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+				<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
 			</t:bind>
 		</tr>
 		<tr>
 			<th class="field-label">New revision:</th>
 			<t:bind t:name="old">
-				<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
+				<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
 			</t:bind>
 		</tr>
 	</table>

extra/webapps/wiki/page-common.xml

@@ -2,16 +2,16 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:atom t:href="$wiki/revisions.atom" t:query="title">
+	<t:atom t:href="$wiki/revisions.atom" t:rest="title">
 		Revisions of <t:label t:name="title" />
 	</t:atom>
 
 	<t:call-next-template />
 
 	<div class="navbar">
-		<t:a t:href="$wiki/view" t:query="title">Latest</t:a>
+		<t:a t:href="$wiki/view" t:rest="title">Latest</t:a>
-		| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
+		| <t:a t:href="$wiki/revisions" t:rest="title">Revisions</t:a>
-		| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+		| <t:a t:href="$wiki/edit" t:rest="title">Edit</t:a>
 		| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
 	</div>
 

extra/webapps/wiki/revisions.xml

@@ -8,14 +8,14 @@
 		<table>
 			<tr>
 				<th>Revision</th>
-				<th>Author</th>
+				<th>By</th>
 				<th>Rollback</th>
 			</tr>
 
 			<t:bind-each t:name="revisions">
 				<tr>
-					<td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
+					<td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
-					<td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
+					<td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
 					<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
 				</tr>
 			</t:bind-each>
@@ -24,7 +24,7 @@
 
 	<h2>View Differences</h2>
 
-	<form action="diff" method="get">
+	<t:form t:action="$wiki/diff" t:method="get">
 		<table>
 			<tr>
 				<th class="field-label">Old revision:</th>
@@ -51,6 +51,6 @@
 		</table>
 
 		<input type="submit" value="View" />
-	</form>
+	</t:form>
 
 </t:chloe>

extra/webapps/wiki/user-edits.xml

@@ -2,7 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:atom t:href="$wiki/user-edits.atom" t:query="author">
+	<t:atom t:href="$wiki/user-edits.atom" t:rest="author">
 		Edits by <t:label t:name="author" />
 	</t:atom>
 
@@ -11,9 +11,9 @@
 	<ul>
 		<t:bind-each t:name="user-edits">
 			<li>
-				<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
+				<t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a>
 				on
-				<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+				<t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a>
 			</li>
 		</t:bind-each>
 	</ul>

extra/webapps/wiki/view.xml

@@ -8,6 +8,6 @@
 		<t:farkup t:name="content" />
 	</div>
 
-	<p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</em></p>
+	<p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</em></p>
 
 </t:chloe>

extra/webapps/wiki/wiki.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel hashtables calendar
-namespaces splitting sequences sorting math.order
+namespaces splitting sequences sorting math.order present
 html.components syndication
 http.server
 http.server.dispatchers
@@ -15,23 +15,26 @@ validators
 db.types db.tuples lcs farkup urls ;
 IN: webapps.wiki
 
-: view-url ( title -- url )
+: wiki-url ( rest path -- url )
-    "$wiki/view/" prepend >url ;
+    [ "$wiki/" % % "/" % % ] "" make
+    <url> swap >>path ;
 
-: edit-url ( title -- url )
+: view-url ( title -- url ) "view" wiki-url ;
-    "$wiki/edit" >url swap "title" set-query-param ;
 
-: revisions-url ( title -- url )
+: edit-url ( title -- url ) "edit" wiki-url ;
-    "$wiki/revisions" >url swap "title" set-query-param ;
 
-: revision-url ( id -- url )
+: revisions-url ( title -- url ) "revisions" wiki-url ;
-    "$wiki/revision" >url swap "id" set-query-param ;
 
-: user-edits-url ( author -- url )
+: revision-url ( id -- url ) "revision" wiki-url ;
-    "$wiki/user-edits" >url swap "author" set-query-param ;
+
+: user-edits-url ( author -- url ) "user-edits" wiki-url ;
 
 TUPLE: wiki < dispatcher ;
 
+SYMBOL: can-delete-wiki-articles?
+
+can-delete-wiki-articles? define-capability
+
 TUPLE: article title revision ;
 
 article "ARTICLES" {
@@ -82,11 +85,11 @@ M: revision feed-entry-url id>> revision-url ;
 
 : <view-article-action> ( -- action )
     <action>
+
         "title" >>rest
 
         [
             validate-title
-            "view?title=" relative-link-prefix set
         ] >>init
 
         [
@@ -100,11 +103,14 @@ M: revision feed-entry-url id>> revision-url ;
 
 : <view-revision-action> ( -- action )
     <page-action>
+
+        "id" >>rest
+
         [
             validate-integer-id
             "id" value <revision>
             select-tuple from-object
-            "view?title=" relative-link-prefix set
+            URL" $wiki/view/" adjust-url present relative-link-prefix set
         ] >>init
 
         { wiki "view" } >>template ;
@@ -121,6 +127,9 @@ M: revision feed-entry-url id>> revision-url ;
 
 : <edit-article-action> ( -- action )
     <page-action>
+
+        "title" >>rest
+
         [
             validate-title
             "title" value <article> select-tuple [
@@ -129,7 +138,7 @@ M: revision feed-entry-url id>> revision-url ;
         ] >>init
 
         { wiki "edit" } >>template
-        
+
         [
             validate-title
             { { "content" [ v-required ] } } validate-params
@@ -140,7 +149,10 @@ M: revision feed-entry-url id>> revision-url ;
                 logged-in-user get username>> >>author
                 "content" value >>content
             [ add-revision ] [ title>> view-url <redirect> ] bi
-        ] >>submit ;
+        ] >>submit
+
+    <protected>
+        "edit wiki articles" >>description ;
 
 : list-revisions ( -- seq )
     f <revision> "title" value >>title select-tuples
@@ -148,21 +160,32 @@ M: revision feed-entry-url id>> revision-url ;
 
 : <list-revisions-action> ( -- action )
     <page-action>
+
+        "title" >>rest
+
         [
             validate-title
             list-revisions "revisions" set-value
         ] >>init
+
         { wiki "revisions" } >>template ;
 
 : <list-revisions-feed-action> ( -- action )
     <feed-action>
+
+        "title" >>rest
+
         [ validate-title ] >>init
+
         [ "Revisions of " "title" value append ] >>title
+
         [ "title" value revisions-url ] >>url
+
         [ list-revisions ] >>entries ;
 
 : <rollback-action> ( -- action )
     <action>
+
         [ validate-integer-id ] >>validate
 
         [
@@ -171,13 +194,12 @@ M: revision feed-entry-url id>> revision-url ;
         ] >>submit ;
 
 : list-changes ( -- seq )
-    "id" value <revision> select-tuples
+    f <revision> select-tuples
     reverse-chronological-order ;
 
 : <list-changes-action> ( -- action )
     <page-action>
         [ list-changes "changes" set-value ] >>init
-
         { wiki "changes" } >>template ;
 
 : <list-changes-feed-action> ( -- action )
@@ -188,13 +210,18 @@ M: revision feed-entry-url id>> revision-url ;
 
 : <delete-action> ( -- action )
     <action>
+
         [ validate-title ] >>validate
 
         [
             "title" value <article> delete-tuples
             f <revision> "title" value >>title delete-tuples
             URL" $wiki" <redirect>
-        ] >>submit ;
+        ] >>submit
+
+     <protected>
+        "delete wiki articles" >>description
+        { can-delete-wiki-articles? } >>capabilities ;
 
 : <diff-action> ( -- action )
     <page-action>
@@ -218,6 +245,7 @@ M: revision feed-entry-url id>> revision-url ;
 
 : <list-articles-action> ( -- action )
     <page-action>
+
         [
             f <article> select-tuples
             [ [ title>> ] compare ] sort
@@ -232,23 +260,24 @@ M: revision feed-entry-url id>> revision-url ;
 
 : <user-edits-action> ( -- action )
     <page-action>
+
+        "author" >>rest
+
         [
             validate-author
             list-user-edits "user-edits" set-value
         ] >>init
+
         { wiki "user-edits" } >>template ;
 
 : <user-edits-feed-action> ( -- action )
     <feed-action>
+        "author" >>rest
         [ validate-author ] >>init
         [ "Edits by " "author" value append ] >>title
         [ "author" value user-edits-url ] >>url
         [ list-user-edits ] >>entries ;
 
-SYMBOL: can-delete-wiki-articles?
-
-can-delete-wiki-articles? define-capability
-
 : <article-boilerplate> ( responder -- responder' )
     <boilerplate>
         { wiki "page-common" } >>template ;
@@ -261,18 +290,13 @@ can-delete-wiki-articles? define-capability
         <list-revisions-action> <article-boilerplate> "revisions" add-responder
         <list-revisions-feed-action> "revisions.atom" add-responder
         <diff-action> <article-boilerplate> "diff" add-responder
-        <edit-article-action> <article-boilerplate> <protected>
+        <edit-article-action> <article-boilerplate> "edit" add-responder
-            "edit wiki articles" >>description
-            "edit" add-responder
         <rollback-action> "rollback" add-responder
         <user-edits-action> "user-edits" add-responder
         <list-articles-action> "articles" add-responder
         <list-changes-action> "changes" add-responder
         <user-edits-feed-action> "user-edits.atom" add-responder
         <list-changes-feed-action> "changes.atom" add-responder
-        <delete-action> <protected>
+        <delete-action> "delete" add-responder
-            "delete wiki articles" >>description
-            { can-delete-wiki-articles? } >>capabilities
-        "delete" add-responder
     <boilerplate>
         { wiki "wiki-common" } >>template ;

extra/windows/com/com.factor

@@ -1,5 +1,5 @@
 USING: alien alien.c-types windows.com.syntax windows.ole32
-windows.types continuations kernel alien.syntax ;
+windows.types continuations kernel alien.syntax libc ;
 IN: windows.com
 
 LIBRARY: ole32
@@ -27,9 +27,9 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
     HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
 
 : com-query-interface ( interface iid -- interface' )
-    f <void*>
+    "void*" heap-size [
-    [ IUnknown::QueryInterface ole32-error ] keep
+        [ IUnknown::QueryInterface ole32-error ] keep *void*
-    *void* ;
+    ] with-malloc ;
 
 : com-add-ref ( interface -- interface )
      [ IUnknown::AddRef drop ] keep ; inline

extra/windows/com/wrapper/wrapper.factor

@@ -1,11 +1,12 @@
 USING: alien alien.c-types windows.com.syntax
 windows.com.syntax.private windows.com continuations kernel
-sequences.lib namespaces windows.ole32 libc
+sequences.lib namespaces windows.ole32 libc vocabs
 assocs accessors arrays sequences quotations combinators
-math combinators.lib words compiler.units destructors ;
+math combinators.lib words compiler.units destructors fry
+math.parser ;
 IN: windows.com.wrapper
 
-TUPLE: com-wrapper vtbls freed? ;
+TUPLE: com-wrapper vtbls disposed ;
 
 <PRIVATE
 
@@ -14,6 +15,16 @@ SYMBOL: +wrapped-objects+
 [ H{ } +wrapped-objects+ set-global ]
 unless
 
+SYMBOL: +vtbl-counter+
++vtbl-counter+ get-global
+[ 0 +vtbl-counter+ set-global ]
+unless
+
+"windows.com.wrapper.callbacks" create-vocab drop
+
+: (next-vtbl-counter) ( -- n )
+    +vtbl-counter+ [ 1+ dup ] change ;
+
 : com-unwrap ( wrapped -- object )
     +wrapped-objects+ get-global at*
     [ "invalid COM wrapping pointer" throw ] unless ;
@@ -22,34 +33,38 @@ unless
     [ +wrapped-objects+ get-global delete-at ] keep
     free ;
 
-: (make-query-interface) ( interfaces -- quot )
+: (query-interface-cases) ( interfaces -- cases )
     [
-        [ swap 16 memory>byte-array ] %
+        [ find-com-interface-definition family-tree [ iid>> ] map ] dip
+        1quotation [ 2array ] curry map
+    ] map-index concat
+    [ drop f ] suffix ;
+
+: (make-query-interface) ( interfaces -- quot )
+    (query-interface-cases) 
+    '[
+        swap 16 memory>byte-array
+        , case
         [
-            >r find-com-interface-definition family-tree
+            "void*" heap-size * rot <displaced-alien> com-add-ref
-            r> 1quotation [ >r iid>> r> 2array ] curry map
+            0 rot set-void*-nth S_OK
-        ] map-index concat
+        ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
-        [ drop f ] suffix ,
+    ] ;
-        \ case ,
-        "void*" heap-size
-        [ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
-        curry ,
-        [ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
-        \ if* ,
-    ] [ ] make ;
 
 : (make-add-ref) ( interfaces -- quot )
-    length "void*" heap-size * [ swap <displaced-alien>
+    length "void*" heap-size * '[
+        , swap <displaced-alien>
         0 over ulong-nth
         1+ [ 0 rot set-ulong-nth ] keep
-    ] curry ;
+    ] ;
 
 : (make-release) ( interfaces -- quot )
-    length "void*" heap-size * [ over <displaced-alien>
+    length "void*" heap-size * '[
+        , over <displaced-alien>
         0 over ulong-nth
         1- [ 0 rot set-ulong-nth ] keep
         dup zero? [ swap (free-wrapped-object) ] [ nip ] if
-    ] curry ;
+    ] ;
 
 : (make-iunknown-methods) ( interfaces -- quots )
     [ (make-query-interface) ]
@@ -60,32 +75,48 @@ unless
 : (thunk) ( n -- quot )
     dup 0 =
     [ drop [ ] ]
-    [ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
+    [ "void*" heap-size neg * '[ , swap <displaced-alien> ] ]
     if ;
 
-: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
+: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
-    [ [ swap 2array ] curry map swap ] keep
+    [ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
-    [ com-unwrap ] compose [ swap 2array ] curry map append ;
+    [ '[ ,                   [ swap 2array ] curry map ] ] bi bi*
+    swap append ;
 
-: compile-alien-callback ( return parameters abi quot -- alien )
+: compile-alien-callback ( word return parameters abi quot -- alien )
     [ alien-callback ] 4 ncurry
-    [ gensym [ swap (( -- alien )) define-declared ] keep ]
+    [ [ (( -- alien )) define-declared ] pick slip ]
     with-compilation-unit
     execute ;
 
-: (make-vtbl) ( interface-name quots iunknown-methods n -- )
+: (byte-array-to-malloced-buffer) ( byte-array -- alien )
+    [ byte-length malloc ] [ over byte-array>memory ] bi ;
+
+: (callback-word) ( function-name interface-name counter -- word )
+    [ "::" rot 3append "-callback-" ] dip number>string 3append
+    "windows.com.wrapper.callbacks" create ;
+
+: (finish-thunk) ( param-count thunk quot -- thunked-quot )
+    [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
+    dip compose ;
+
+: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
     (thunk) (thunked-quots)
-    swap find-com-interface-definition family-tree-functions [
+    swap [ find-com-interface-definition family-tree-functions ]
-        [ return>> ] [ parameters>> [ first ] map ] bi
+    keep (next-vtbl-counter) '[
-        dup length 1- roll [
+        swap [
-            first dup empty?
+            [ name>> , , (callback-word) ]
-            [ 2drop [ ] ]
+            [ return>> ] [
-            [ swap [ ndip ] 2curry ]
+                parameters>>
-            if
+                [ [ first ] map ]
-        ] [ second ] bi compose
+                [ length ] bi
+            ] tri
+        ] [
+            first2 (finish-thunk)
+        ] bi*
         "stdcall" swap compile-alien-callback
-    ] 2map >c-void*-array [ byte-length malloc ] keep
+    ] 2map >c-void*-array
-    over byte-array>memory ;
+    (byte-array-to-malloced-buffer) ;
 
 : (make-vtbls) ( implementations -- vtbls )
     dup [ first ] map (make-iunknown-methods)
@@ -102,11 +133,10 @@ PRIVATE>
 : <com-wrapper> ( implementations -- wrapper )
     (make-vtbls) f com-wrapper boa ;
 
-M: com-wrapper dispose
+M: com-wrapper dispose*
-    t >>freed?
     vtbls>> [ free ] each ;
 
 : com-wrap ( object wrapper -- wrapped-object )
-    dup (malloc-wrapped-object) >r vtbls>> r>
+    [ vtbls>> ] [ (malloc-wrapped-object) ] bi
     [ [ set-void*-nth ] curry each-index ] keep
     [ +wrapped-objects+ get-global set-at ] keep ;

extra/xmode/rules/rules.factor

@@ -42,7 +42,7 @@ MEMO: standard-rule-set ( id -- ruleset )
     rule-set-imports push ;
 
 : inverted-index ( hashes key index -- )
-    [ swapd [ ?push ] change-at ] 2curry each ;
+    [ swapd push-at ] 2curry each ;
 
 : ?push-all ( seq1 seq2 -- seq1+seq2 )
     [