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

core/compiler/compiler.factor

@@ -35,7 +35,7 @@ IN: compiler
     [ swap save-effect ]
     [ compiled-unxref ]
     [
-        dup compiled-crossref?
+        dup crossref?
         [ dependencies get compiled-xref ] [ drop ] if
     ] tri ;
 

core/compiler/units/units.factor

@@ -66,7 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- )
 
 : compile ( words -- )
     recompile-hook get call
-    dup [ drop compiled-crossref? ] assoc-contains?
+    dup [ drop crossref? ] assoc-contains?
     modify-code-heap ;
 
 SYMBOL: outdated-tuples
@@ -82,7 +82,7 @@ SYMBOL: update-tuples-hook
 : finish-compilation-unit ( -- )
     call-recompile-hook
     call-update-tuples-hook
-    dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
+    dup [ drop crossref? ] assoc-contains? modify-code-heap
      ;
 
 : with-nested-compilation-unit ( quot -- )

core/definitions/definitions.factor

@@ -47,7 +47,17 @@ M: object uses drop f ;
 
 : xref ( defspec -- ) dup uses crossref get add-vertex ;
 
-: usage ( defspec -- seq ) \ f or crossref get at keys ;
+: usage ( defspec -- seq ) crossref get at keys ;
+
+GENERIC: irrelevant? ( defspec -- ? )
+
+M: object irrelevant? drop f ;
+
+GENERIC: smart-usage ( defspec -- seq )
+
+M: f smart-usage drop \ f smart-usage ;
+
+M: object smart-usage usage [ irrelevant? not ] filter ;
 
 : unxref ( defspec -- )
     dup uses crossref get remove-vertex ;

core/generic/generic.factor

@@ -117,6 +117,9 @@ M: method-spec definition
 M: method-spec forget*
     first2 method forget* ;
 
+M: method-spec smart-usage
+    second smart-usage ;
+
 M: method-body definer
     drop \ M: \ ; ;
 
@@ -134,6 +137,9 @@ M: method-body forget*
         [ t "forgotten" set-word-prop ] bi
     ] if ;
 
+M: method-body smart-usage
+    "method-generic" word-prop smart-usage ;
+
 : implementors* ( classes -- words )
     all-words [
         "methods" word-prop keys

core/generic/standard/engines/tuple/tuple.factor

@@ -4,7 +4,7 @@ USING: kernel classes.tuple.private hashtables assocs sorting
 accessors combinators sequences slots.private math.parser words
 effects namespaces generic generic.standard.engines
 classes.algebra math math.private kernel.private
-quotations arrays ;
+quotations arrays definitions ;
 IN: generic.standard.engines.tuple
 
 TUPLE: echelon-dispatch-engine n methods ;
@@ -64,8 +64,9 @@ M: engine-word stack-effect
     [ extra-values ] [ stack-effect ] bi
     dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
 
-M: engine-word compiled-crossref?
+M: engine-word crossref? drop t ;
-    drop t ;
+
+M: engine-word irrelevant? drop t ;
 
 : remember-engine ( word -- )
     generic get "engines" word-prop push ;

core/generic/standard/standard-tests.factor

@@ -3,7 +3,8 @@ USING: tools.test math math.functions math.constants
 generic.standard strings sequences arrays kernel accessors
 words float-arrays byte-arrays bit-arrays parser namespaces
 quotations inference vectors growable hashtables sbufs
-prettyprint byte-vectors bit-vectors float-vectors ;
+prettyprint byte-vectors bit-vectors float-vectors definitions
+generic sets graphs assocs ;
 
 GENERIC: lo-tag-test
 
@@ -287,3 +288,24 @@ M: sbuf no-stack-effect-decl ;
 [ ] [ \ no-stack-effect-decl see ] unit-test
 
 [ ] [ \ no-stack-effect-decl word-def . ] unit-test
+
+! Cross-referencing with generic words
+TUPLE: xref-tuple-1 ;
+TUPLE: xref-tuple-2 < xref-tuple-1 ;
+
+: (xref-test) drop ;
+
+GENERIC: xref-test ( obj -- )
+
+M: xref-tuple-1 xref-test (xref-test) ;
+M: xref-tuple-2 xref-test (xref-test) ;
+
+[ t ] [
+    \ xref-test
+    \ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
+] unit-test
+
+[ t ] [
+    \ xref-test
+    \ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
+] unit-test

core/inference/backend/backend-docs.factor

@@ -61,7 +61,7 @@ HELP: effect-error
 { $description "Throws an " { $link effect-error } "." }
 { $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
 
-HELP: recursive-declare-error
+HELP: no-recursive-declaration
 { $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ;
 
 HELP: recursive-quotation-error

core/inference/backend/backend.factor

@@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
 io.streams.string kernel math namespaces parser prettyprint
 sequences strings vectors words quotations effects classes
 continuations debugger assocs combinators compiler.errors
-generic.standard.engines.tuple accessors math.order ;
+generic.standard.engines.tuple accessors math.order definitions ;
 IN: inference.backend
 
 : recursive-label ( word -- label/f )
@@ -21,6 +21,28 @@ M: engine-word inline?
 M: word inline?
     "inline" word-prop ;
 
+SYMBOL: visited
+
+: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
+
+: (redefined) ( word -- )
+    dup visited get key? [ drop ] [
+        [ reset-on-redefine reset-props ]
+        [ dup visited get set-at ]
+        [
+            crossref get at keys
+            [ word? ] filter
+            [
+                [ reset-on-redefine [ word-prop ] with contains? ]
+                [ inline? ]
+                bi or
+            ] filter
+            [ (redefined) ] each
+        ] tri
+    ] if ;
+
+M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
+
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys
     [ dup word? [ inline? ] when not ] find drop
@@ -68,8 +90,9 @@ M: object value-literal \ literal-expected inference-warning ;
     meta-d [ add-inputs ] change d-in [ + ] change ;
 
 : current-effect ( -- effect )
-    d-in get meta-d get length <effect>
+    d-in get
-    terminated? get over set-effect-terminated? ;
+    meta-d get length <effect>
+    terminated? get >>terminated? ;
 
 : init-inference ( -- )
     terminated? off
@@ -93,13 +116,13 @@ M: wrapper apply-object
     terminated? on #terminate node, ;
 
 : infer-quot ( quot rstate -- )
-    recursive-state get >r
+    recursive-state get [
         recursive-state set
         [ apply-object terminated? get not ] all? drop
-    r> recursive-state set ;
+    ] dip recursive-state set ;
 
 : infer-quot-recursive ( quot word label -- )
-    recursive-state get -rot 2array prefix infer-quot ;
+    2array recursive-state get swap prefix infer-quot ;
 
 : time-bomb ( error -- )
     [ throw ] curry recursive-state get infer-quot ;
@@ -114,9 +137,9 @@ TUPLE: recursive-quotation-error quot ;
         value-literal recursive-quotation-error inference-error
     ] [
         dup value-literal callable? [
-            dup value-literal
+            [ value-literal ]
-            over value-recursion
+            [ [ value-recursion ] keep f 2array prefix ]
-            rot f 2array prefix infer-quot
+            bi infer-quot
         ] [
             drop bad-call
         ] if
@@ -169,26 +192,26 @@ TUPLE: too-many-r> ;
     meta-d get push-all ;
 
 : if-inline ( word true false -- )
-    >r >r dup inline? r> r> if ; inline
+    [ dup inline? ] 2dip if ; inline
 
 : consume/produce ( effect node -- )
-    over effect-in over consume-values
+    [ [ in>> ] dip consume-values ]
-    over effect-out over produce-values
+    [ [ out>> ] dip produce-values ]
-    node,
+    [ node, terminated?>> [ terminate ] when ]
-    effect-terminated? [ terminate ] when ;
+    2tri ;
 
 GENERIC: constructor ( value -- word/f )
 
 GENERIC: infer-uncurry ( value -- )
 
 M: curried infer-uncurry
-    drop pop-d dup curried-obj push-d curried-quot push-d ;
+    drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ;
 
 M: curried constructor
     drop \ curry ;
 
 M: composed infer-uncurry
-    drop pop-d dup composed-quot1 push-d composed-quot2 push-d ;
+    drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ;
 
 M: composed constructor
     drop \ compose ;
@@ -233,13 +256,13 @@ M: object constructor drop f ;
 DEFER: unify-values
 
 : unify-curries ( seq -- value )
-    dup [ curried-obj ] map unify-values
+    [ [ obj>> ] map unify-values ]
-    swap [ curried-quot ] map unify-values
+    [ [ quot>> ] map unify-values ] bi
     <curried> ;
 
 : unify-composed ( seq -- value )
-    dup [ composed-quot1 ] map unify-values
+    [ [ quot1>> ] map unify-values ]
-    swap [ composed-quot2 ] map unify-values
+    [ [ quot2>> ] map unify-values ] bi
     <composed> ;
 
 TUPLE: cannot-unify-specials ;
@@ -270,7 +293,7 @@ TUPLE: unbalanced-branches-error quots in out ;
 
 : unify-inputs ( max-d-in d-in meta-d -- meta-d )
     dup [
-        [ >r - r> length + ] keep add-inputs nip
+        [ [ - ] dip length + ] keep add-inputs nip
     ] [
         2nip
     ] if ;
@@ -296,21 +319,24 @@ TUPLE: unbalanced-branches-error quots in out ;
     [ swap at ] curry map ;
 
 : datastack-effect ( seq -- )
-    dup quotation branch-variable
+    [ quotation branch-variable ]
-    over d-in branch-variable
+    [ d-in branch-variable ]
-    rot meta-d active-variable
+    [ meta-d active-variable ] tri
-    unify-effect meta-d set d-in set ;
+    unify-effect
+    [ d-in set ] [ meta-d set ] bi* ;
 
 : retainstack-effect ( seq -- )
-    dup quotation branch-variable
+    [ quotation branch-variable ]
-    over length 0 <repetition>
+    [ length 0 <repetition> ]
-    rot meta-r active-variable
+    [ meta-r active-variable ] tri
-    unify-effect meta-r set drop ;
+    unify-effect
+    [ drop ] [ meta-r set ] bi* ;
 
 : unify-effects ( seq -- )
-    dup datastack-effect
+    [ datastack-effect ]
-    dup retainstack-effect
+    [ retainstack-effect ]
-    [ terminated? swap at ] all? terminated? set ;
+    [ [ terminated? swap at ] all? terminated? set ]
+    tri ;
 
 : unify-dataflow ( effects -- nodes )
     dataflow-graph branch-variable ;
@@ -325,14 +351,17 @@ TUPLE: unbalanced-branches-error quots in out ;
 : infer-branch ( last value -- namespace )
     [
         copy-inference
-        dup value-literal quotation set
+
-        infer-quot-value
+        [ value-literal quotation set ]
+        [ infer-quot-value ]
+        bi
+
         terminated? get [ drop ] [ call node, ] if
     ] H{ } make-assoc ; inline
 
 : (infer-branches) ( last branches -- list )
     [ infer-branch ] with map
-    dup unify-effects unify-dataflow ; inline
+    [ unify-effects ] [ unify-dataflow ] bi ; inline
 
 : infer-branches ( last branches node -- )
     #! last is a quotation which provides a #return or a #values
@@ -368,9 +397,10 @@ TUPLE: effect-error word effect ;
 
 : finish-word ( word -- )
     current-effect
-    2dup check-effect
+    [ check-effect ]
-    over recorded get push
+    [ drop recorded get push ]
-    "inferred-effect" set-word-prop ;
+    [ "inferred-effect" set-word-prop ]
+    2tri ;
 
 : infer-word ( word -- effect )
     [
@@ -386,8 +416,7 @@ TUPLE: effect-error word effect ;
 
 : custom-infer ( word -- )
     #! Customized inference behavior
-    dup +inlined+ depends-on
+    [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
-    "infer" word-prop call ;
 
 : cached-infer ( word -- )
     dup "inferred-effect" word-prop make-call-node ;
@@ -400,13 +429,13 @@ TUPLE: effect-error word effect ;
         [ dup infer-word make-call-node ]
     } cond ;
 
-TUPLE: recursive-declare-error word ;
+TUPLE: no-recursive-declaration word ;
 
 : declared-infer ( word -- )
     dup stack-effect [
         make-call-node
     ] [
-        \ recursive-declare-error inference-error
+        \ no-recursive-declaration inference-error
     ] if* ;
 
 GENERIC: collect-label-info* ( label node -- )
@@ -441,40 +470,56 @@ M: #return collect-label-info*
 : inline-block ( word -- #label data )
     [
         copy-inference nest-node
-        dup word-def swap <inlined-block>
+        [ word-def ] [ <inlined-block> ] bi
         [ infer-quot-recursive ] 2keep
         #label unnest-node
         dup collect-label-info
     ] H{ } make-assoc ;
 
 : join-values ( #label -- )
-    calls>> [ node-in-d ] map meta-d get suffix
+    calls>> [ in-d>> ] map meta-d get suffix
     unify-lengths unify-stacks
     meta-d [ length tail* ] change ;
 
 : splice-node ( node -- )
-    dup node-successor [
+    dup successor>> [
-        dup node, penultimate-node f over set-node-successor
+        [ node, ] [ penultimate-node ] bi
-        dup current-node set
+        f >>successor
-    ] when drop ;
+        current-node set
+    ] [ drop ] if ;
 
-: apply-infer ( hash -- )
+: apply-infer ( data -- )
-    { meta-d meta-r d-in terminated? }
+    { meta-d meta-r d-in terminated? } swap extract-keys
-    [ swap [ at ] curry map ] keep
+    namespace swap update ;
-    [ set ] 2each ;
+
+: current-stack-height ( -- n )
+    meta-d get length d-in get - ;
+
+: word-stack-height ( word -- n )
+    stack-effect [ in>> length ] [ out>> length ] bi - ;
+
+: bad-recursive-declaration ( word inferred -- )
+    dup 0 < [ 0 ] [ 0 swap ] if <effect> effect-error ;
+
+: check-stack-height ( word height -- )
+    over word-stack-height over =
+    [ 2drop ] [ bad-recursive-declaration ] if ;
+
+: inline-recursive-word ( word #label -- )
+    current-stack-height [
+        flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d
+        [ node, ]
+        [ calls>> [ [ flatten-curries ] modify-values ] each ]
+        [ word>> ]
+        tri
+    ] dip
+    current-stack-height -
+    check-stack-height ;
 
 : inline-word ( word -- )
-    dup inline-block over recursive-label? [
+    dup inline-block over recursive-label?
-        flatten-meta-d >r
+    [ drop inline-recursive-word ]
-        drop join-values inline-block apply-infer
+    [ apply-infer node-child successor>> splice-node drop ] if ;
-        r> over set-node-in-d
-        dup node,
-        calls>> [
-            [ flatten-curries ] modify-values
-        ] each
-    ] [
-        apply-infer node-child node-successor splice-node drop
-    ] if ;
 
 M: word apply-object
     [

core/inference/errors/errors.factor

@@ -15,10 +15,8 @@ M: inference-error error-help drop f ;
 
 M: unbalanced-branches-error error.
     "Unbalanced branches:" print
-    dup unbalanced-branches-error-quots
+    [ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip
-    over unbalanced-branches-error-in
+    [ [ bl ] [ pprint ] interleave nl ] each ;
-    rot unbalanced-branches-error-out [ length ] map
-    3array flip [ [ bl ] [ pprint ] interleave nl ] each ;
 
 M: literal-expected summary
     drop "Literal value expected" ;
@@ -32,24 +30,24 @@ M: too-many-r> summary
     "Quotation pops retain stack elements which it did not push" ;
 
 M: no-effect error.
-    "Unable to infer stack effect of " write no-effect-word . ;
+    "Unable to infer stack effect of " write word>> . ;
 
-M: recursive-declare-error error.
+M: no-recursive-declaration error.
     "The recursive word " write
-    recursive-declare-error-word pprint
+    word>> pprint
     " must declare a stack effect" print ;
 
 M: effect-error error.
     "Stack effects of the word " write
-    dup effect-error-word pprint
+    dup word>> pprint
     " do not match." print
     "Declared: " write
-    dup effect-error-word stack-effect effect>string .
+    dup word>> stack-effect effect>string .
-    "Inferred: " write effect-error-effect effect>string . ;
+    "Inferred: " write effect>> effect>string . ;
 
 M: recursive-quotation-error error.
     "The quotation " write
-    recursive-quotation-error-quot pprint
+    quot>> pprint
     " calls itself." print
     "Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
 

core/inference/inference-docs.factor

@@ -89,7 +89,7 @@ ARTICLE: "inference-errors" "Inference errors"
 { $subsection too-many-r> }
 { $subsection unbalanced-branches-error }
 { $subsection effect-error }
-{ $subsection recursive-declare-error } ;
+{ $subsection no-recursive-declaration } ;
 
 ARTICLE: "inference" "Stack effect inference"
 "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."

core/inference/inference-tests.factor

@@ -549,10 +549,34 @@ ERROR: custom-error ;
 { 1 0 } [ [ ] map-children ] must-infer-as
 
 ! Corner case
-! [ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
+[ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
 
-! [ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
+[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
 
-! : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
+: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
 
-! [ [ erg's-inference-bug ] infer ] must-fail
+[ [ erg's-inference-bug ] infer ] must-fail
+
+: inference-invalidation-a ;
+: inference-invalidation-b [ inference-invalidation-a ] dip call ; inline
+: inference-invalidation-c [ + ] inference-invalidation-b ;
+
+[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
+
+{ 2 1 } [ inference-invalidation-c ] must-infer-as
+
+[ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
+
+[ 3 ] [ inference-invalidation-c ] unit-test
+
+{ 0 1 } [ inference-invalidation-c ] must-infer-as
+
+GENERIC: inference-invalidation-d ( obj -- )
+
+M: object inference-invalidation-d inference-invalidation-c 2drop ;
+
+\ inference-invalidation-d must-infer
+
+[ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
+
+[ [ inference-invalidation-d ] infer ] must-fail

core/kernel/kernel.factor

@@ -72,7 +72,7 @@ DEFER: if
     >r keep r> call ; inline
 
 : tri ( x p q r -- )
-    >r pick >r bi r> r> call ; inline
+    >r >r keep r> keep r> call ; inline
 
 ! Double cleavers
 : 2bi ( x y p q -- )
@@ -93,7 +93,7 @@ DEFER: if
     >r dip r> call ; inline
 
 : tri* ( x y z p q r -- )
-    >r rot >r bi* r> r> call ; inline
+    >r >r 2dip r> dip r> call ; inline
 
 ! Double spreaders
 : 2bi* ( w x y z p q -- )

core/words/words.factor

@@ -102,7 +102,7 @@ SYMBOL: compiled-crossref
 compiled-crossref global [ H{ } assoc-like ] change-at
 
 : compiled-xref ( word dependencies -- )
-    [ drop compiled-crossref? ] assoc-filter
+    [ drop crossref? ] assoc-filter
     2dup "compiled-uses" set-word-prop
     compiled-crossref get add-vertex* ;
 
@@ -125,28 +125,9 @@ SYMBOL: +called+
         compiled-usage [ nip +inlined+ eq? ] assoc-filter update
     ] with each keys ;
 
-<PRIVATE
+GENERIC: redefined ( word -- )
 
-SYMBOL: visited
+M: object redefined drop ;
-
-: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
-
-: (redefined) ( word -- )
-    dup visited get key? [ drop ] [
-        [ reset-on-redefine reset-props ]
-        [ dup visited get set-at ]
-        [
-            crossref get at keys
-            [ word? ] filter
-            [ reset-on-redefine [ word-prop ] with contains? ] filter
-            [ (redefined) ] each
-        ] tri
-    ] if ;
-
-PRIVATE>
-
-: redefined ( word -- )
-    H{ } clone visited [ (redefined) ] with-variable ;
 
 : define ( word def -- )
     [ ] like

extra/cairo/gadgets/gadgets.factor

@@ -13,21 +13,23 @@ IN: cairo.gadgets
     >r first2 over width>stride
     [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
     [ cairo_image_surface_create_for_data ] 3bi
-    r> with-cairo-from-surface ;
+    r> with-cairo-from-surface ; inline
 
-TUPLE: cairo-gadget < texture-gadget quot ;
+TUPLE: cairo-gadget < texture-gadget dim quot ;
 
 : <cairo-gadget> ( dim quot -- gadget )
     cairo-gadget construct-gadget
         swap >>quot
         swap >>dim ;
 
-M: cairo-gadget format>> drop GL_BGRA ;
+M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
 
-M: cairo-gadget render* ( gadget -- )
+: render-cairo ( dim quot -- bytes format )
-    dup
+    >r 2^-bounds r> copy-cairo GL_BGRA ; inline
-    [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi
+
-    >>bytes call-next-method ;
+! M: cairo-gadget render*
+!     [ dim>> dup ] [ quot>> ] bi
+!     render-cairo render-bytes* ;
 
 ! maybe also texture>png
 ! : cairo>png ( gadget path -- )
@@ -40,11 +42,16 @@ M: cairo-gadget render* ( gadget -- )
     cr swap 0 0 cairo_set_source_surface
     cr cairo_paint ;
 
-: <png-gadget> ( path -- gadget )
+TUPLE: png-gadget < texture-gadget path ;
-    normalize-path cairo_image_surface_create_from_png
+: <png> ( path -- gadget )
+    png-gadget construct-gadget
+        swap >>path ;
+
+M: png-gadget render*
+    path>> normalize-path cairo_image_surface_create_from_png
     [ cairo_image_surface_get_width ]
     [ cairo_image_surface_get_height 2array dup 2^-bounds ]
     [ [ copy-surface ] curry copy-cairo ] tri
-    GL_BGRA rot <texture-gadget> ;
+    GL_BGRA render-bytes* ;
-
 
+M: png-gadget cache-key* path>> ;

extra/db/tuples/tuples.factor

@@ -152,6 +152,9 @@ M: retryable execute-statement* ( statement type -- )
 : select-tuples ( tuple -- tuples )
     dup dup class <select-by-slots-statement> do-select ;
 
+: count-tuples ( tuple -- n )
+    select-tuples length ;
+
 : select-tuple ( tuple -- tuple/f )
     dup dup class f f f 1 <query>
     do-select ?first ;

extra/dns/server/server.factor

@@ -0,0 +1,139 @@
+
+USING: kernel
+       combinators
+       sequences
+       math
+       io.sockets
+       unicode.case
+       accessors
+       combinators.cleave
+       newfx
+       dns ;
+
+IN: dns.server
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: records ( -- vector ) V{ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: filter-by-name ( records name -- records ) swap [ name>> = ] with filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {name-type-class} ( obj -- array )
+  { [ name>> >lower ] [ type>> ] [ class>> ] } <arr> ;
+
+: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: matching-rrs  ( query -- rrs ) records [ rr=query? ] with filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: matching-rrs? ( query -- query rrs/f ? ) dup matching-rrs dup empty? not ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: matching-cname? ( query -- query rr/f ? )
+  dup clone CNAME >>type matching-rrs
+  dup empty? [ drop f f ] [ 1st t ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: query->rrs
+
+: query-canonical ( query rr -- rrs )
+  tuck [ clone ] [ rdata>> ] bi* >>name query->rrs prefix-on ;
+
+: query->rrs ( query -- rrs/f )
+    {
+      { [      matching-rrs?   ] [ nip ] }
+      { [ drop matching-cname? ] [ query-canonical ] }
+      { [ drop t               ] [ drop f ] }
+    }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delegate-servers? ( name -- name rrs ? )
+  dup NS IN query boa matching-rrs dup empty? not ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delegate-servers ( name -- rrs )
+    {
+      { [ dup "" = ]          [ drop { } ] }
+      { [ delegate-servers? ] [ nip ] }
+      { [ drop t ]            [ cdr-name delegate-servers ] }
+    }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delegate-addresses ( rrs-ns -- rrs-a )
+  [ rdata>> A IN query boa matching-rrs ] map concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: have-delegates? ( query -- query rrs-ns ? )
+  dup name>> delegate-servers dup empty? not ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill-additional ( message -- message )
+  dup authority-section>> delegate-addresses >>additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: no-records-with-name? ( query -- query ? )
+  dup name>> records [ name>> = ] with filter empty? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: find-answer ( message -- message )
+  dup message-query                     ! message query
+    {
+      { [ dup query->rrs dup   ] [ nip >>answer-section 1 >>aa ] }
+      { [ drop have-delegates? ] [ nip >>authority-section fill-additional ] }
+      { [ drop no-records-with-name? ] [ drop NAME-ERROR >>rcode ] }
+      { [ drop t ] [ ] }
+    }
+  cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (socket) ( -- vec ) V{ f } ;
+
+: socket ( -- socket ) (socket) 1st ;
+
+: init-socket-on-port ( port -- )
+  f swap <inet4> <datagram> 0 (socket) as-mutate ;
+
+: init-socket ( -- ) 53 init-socket-on-port ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: loop ( -- )
+  socket receive
+  swap
+  parse-message
+  find-answer
+  message->ba
+  swap
+  socket send
+  loop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start ( -- ) init-socket loop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: start

extra/editors/editors.factor

@@ -53,7 +53,7 @@ M: object find-parse-error
 
 : fix ( word -- )
     [ "Fixing " write pprint " and all usages..." print nl ]
-    [ [ usage ] keep prefix ] bi
+    [ [ smart-usage ] keep prefix ] bi
     [
         [ "Editing " write . ]
         [

extra/freetype/freetype.factor

@@ -155,6 +155,16 @@ C-STRUCT: face
     { "face-size*" "size" }
     { "void*" "charmap" } ;
 
+C-STRUCT: FT_Bitmap
+    { "int" "rows" }
+    { "int" "width" }
+    { "int" "pitch" }
+    { "void*" "buffer" }
+    { "short" "num_grays" }
+    { "char" "pixel_mode" }
+    { "char" "palette_mode" }
+    { "void*" "palette" } ;
+
 FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
 
 FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ;
@@ -170,6 +180,15 @@ C-ENUM:
     FT_RENDER_MODE_LCD
     FT_RENDER_MODE_LCD_V ;
 
+C-ENUM:
+    FT_PIXEL_MODE_NONE
+    FT_PIXEL_MODE_MONO
+    FT_PIXEL_MODE_GRAY
+    FT_PIXEL_MODE_GRAY2
+    FT_PIXEL_MODE_GRAY4
+    FT_PIXEL_MODE_LCD
+    FT_PIXEL_MODE_LCD_V ;
+
 FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ;
 
 FUNCTION: void FT_Done_Face ( face* face ) ;
@@ -177,3 +196,4 @@ FUNCTION: void FT_Done_Face ( face* face ) ;
 FUNCTION: void FT_Done_FreeType ( void* library ) ;
 
 FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ;
+

extra/furnace/furnace.factor

@@ -151,7 +151,7 @@ CHLOE: a
 : form-magic ( tag -- )
     [ modify-form ] each-responder
     nested-values get " " join f like form-nesting-key hidden-form-field
-    "for" optional-attr [ hidden render ] when* ;
+    "for" optional-attr [ "," split [ hidden render ] each ] when* ;
 
 : form-start-tag ( tag -- )
     [

extra/help/html/html.factor

@@ -0,0 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: help.html
+
+

extra/http/server/server.factor

@@ -44,8 +44,13 @@ main-responder global [ <404> <trivial-responder> or ] change-at
 
 : do-response ( response -- )
     dup write-response
-    request get method>> "HEAD" =
+    request get method>> "HEAD" = [ drop ] [
-    [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ;
+        '[ , write-response-body ]
+        [
+            development-mode get
+            [ http-error. ] [ drop "Response error" ] if
+        ] recover
+    ] if ;
 
 LOG: httpd-hit NOTICE
 

extra/lisp/lisp-tests.factor

@@ -13,8 +13,6 @@ IN: lisp.test
     "+" "math" "+" define-primitive
     "-" "math" "-" define-primitive
     
-!    "list" [ >array ] lisp-define
-    
     { 5 } [
       [ 2 3 ] "+" <lisp-symbol> funcall
     ] unit-test
@@ -55,8 +53,4 @@ IN: lisp.test
        "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
     ] unit-test
     
-!     { { 1 2 3 4 5 } } [
-!       "(list 1 2 3 4 5)" lisp-eval
-!     ] unit-test
-
 ] with-interactive-vocabs

extra/lisp/lisp.factor

@@ -59,10 +59,23 @@ PRIVATE>
 : convert-unquoted ( cons -- quot )    
     "unquote not valid outside of quasiquote!" throw ;
     
-: convert-quasiquoted ( cons -- newcons )
+: convert-unquoted-splicing ( cons -- quot )    
+    "unquote-splicing not valid outside of quasiquote!" throw ;
+    
+<PRIVATE    
+: quasiquote-unquote ( cons -- newcons )
     [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
     [ cadr ] traverse ;
     
+: quasiquote-unquote-splicing ( cons -- newcons )    
+    [ { [ dup list? ] [ dup cdr [ cons? ] [ car cons? ] bi and ]
+        [ dup cadr car lisp-symbol? ] [ cadr car name>> "unquote-splicing" equal? dup ] } && nip ]
+    [ dup cadr cdr >>cdr ] traverse ;
+PRIVATE>
+
+: convert-quasiquoted ( cons -- newcons )
+    quasiquote-unquote quasiquote-unquote-splicing ;
+    
 : convert-defmacro ( cons -- quot )
     cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
     
@@ -72,6 +85,7 @@ PRIVATE>
       { "defmacro" [ convert-defmacro ] }
       { "quote" [ convert-quoted ] }
       { "unquote" [ convert-unquoted ] }
+      { "unquote-splicing" [ convert-unquoted-splicing ] }
       { "quasiquote" [ convert-quasiquoted ] }
       { "begin" [ convert-begin ] }
       { "cond" [ convert-cond ] }
@@ -99,7 +113,7 @@ PRIVATE>
     call ; inline
     
 : macro-expand ( cons -- quot )
-    uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form  ] bi* call ;
+    uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form  ] bi* ;
     
 : lisp-string>factor ( str -- quot )
     lisp-expr parse-result-ast compile-form ;

extra/lists/lazy/examples/examples-tests.factor

@@ -1,5 +1,5 @@
-USING: lazy-lists.examples lazy-lists tools.test ;
+USING: lists.lazy.examples lazy-lists tools.test ;
-IN: lazy-lists.examples.tests
+IN: lists.lazy.examples.tests
 
 [ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
 [ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test

extra/math/functions/functions-tests.factor

@@ -44,7 +44,10 @@ IN: math.functions.tests
 
 [ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
 [ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
+[ t ] [ -100 atan tan -100 1.e-10 ~ ] unit-test
 [ t ] [ 10 asinh sinh 10 1.e-10 ~ ] unit-test
+[ t ] [ 10 atanh tanh 10 1.e-10 ~ ] unit-test
+[ t ] [ 0.5 atanh tanh 0.5 1.e-10 ~ ] unit-test
 
 [ 100 ] [ 100 100 gcd nip ] unit-test
 [ 100 ] [ 1000 100 gcd nip ] unit-test

extra/math/functions/functions.factor

@@ -182,17 +182,17 @@ M: number (^)
 : coth ( x -- y ) tanh recip ; inline
 
 : acosh ( x -- y )
-    dup >=1? [ facosh ] [ dup sq 1- sqrt + log ] if ; inline
+    dup sq 1- sqrt + log ; inline
 
 : asech ( x -- y ) recip acosh ; inline
 
 : asinh ( x -- y )
-    dup complex? [ dup sq 1+ sqrt + log ] [ fasinh ] if ; inline
+    dup sq 1+ sqrt + log ; inline
 
 : acosech ( x -- y ) recip asinh ; inline
 
 : atanh ( x -- y )
-    dup [-1,1]? [ fatanh ] [ dup 1+ swap 1- neg / log 2 / ] if ; inline
+    dup 1+ swap 1- neg / log 2 / ; inline
 
 : acoth ( x -- y ) recip atanh ; inline
 

extra/math/libm/libm.factor

@@ -15,18 +15,6 @@ IN: math.libm
     "double" "libm" "atan" { "double" } alien-invoke ;
     foldable
 
-: facosh ( x -- y )
-    "double" "libm" "acosh" { "double" } alien-invoke ;
-    foldable
-
-: fasinh ( x -- y )
-    "double" "libm" "asinh" { "double" } alien-invoke ;
-    foldable
-
-: fatanh ( x -- y )
-    "double" "libm" "atanh" { "double" } alien-invoke ;
-    foldable
-
 : fatan2 ( x y -- z )
     "double" "libm" "atan2" { "double" "double" } alien-invoke ;
     foldable
@@ -70,3 +58,16 @@ IN: math.libm
 : fsqrt ( x -- y )
     "double" "libm" "sqrt" { "double" } alien-invoke ;
     foldable
+    
+! Windows doesn't have these...
+: facosh ( x -- y )
+    "double" "libm" "acosh" { "double" } alien-invoke ;
+    foldable
+
+: fasinh ( x -- y )
+    "double" "libm" "asinh" { "double" } alien-invoke ;
+    foldable
+
+: fatanh ( x -- y )
+    "double" "libm" "atanh" { "double" } alien-invoke ;
+    foldable

extra/opengl/gadgets/gadgets-tests.factor

@@ -0,0 +1,4 @@
+IN: opengl.gadgets.tests
+USING: tools.test opengl.gadgets ;
+
+\ render* must-infer

extra/opengl/gadgets/gadgets.factor

@@ -2,10 +2,57 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: locals math.functions math namespaces
 opengl.gl accessors kernel opengl ui.gadgets
+fry assocs
 destructors sequences ui.render colors ;
 IN: opengl.gadgets
 
-TUPLE: texture-gadget bytes format dim tex ;
+TUPLE: texture-gadget ;
+
+GENERIC: render* ( gadget -- texture dims )
+GENERIC: cache-key* ( gadget -- key )
+
+M: texture-gadget cache-key* ;
+
+SYMBOL: textures
+SYMBOL: refcounts
+
+: init-cache ( symbol -- )
+    dup get [ drop ] [ H{ } clone swap set-global ] if ;
+
+textures init-cache
+refcounts init-cache
+
+: refcount-change ( gadget quot -- )
+    >r cache-key* refcounts get
+    [ [ 0 ] unless* ] r> compose change-at ;
+
+TUPLE: cache-entry tex dims ;
+C: <entry> cache-entry
+
+: make-entry ( gadget -- entry )
+    dup render* <entry>
+    [ swap cache-key* textures get set-at ] keep ;
+
+: get-entry ( gadget -- {texture,dims} )
+    dup cache-key* textures get at
+    [ nip ] [ make-entry ] if* ;
+
+: get-dims ( gadget -- dims )
+    get-entry dims>> ;
+
+: get-texture ( gadget -- texture )
+    get-entry tex>> ;
+
+: release-texture ( gadget -- )
+    cache-key* textures get delete-at*
+    [ tex>> delete-texture ] [ drop ] if ;
+
+M: texture-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
+
+M: texture-gadget ungraft* ( gadget -- )
+    dup [ 1- ] refcount-change
+    dup cache-key* refcounts get at
+    zero? [ release-texture ] [ drop ] if ;
 
 : 2^-ceil ( x -- y )
     dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
@@ -13,31 +60,29 @@ TUPLE: texture-gadget bytes format dim tex ;
 : 2^-bounds ( dim -- dim' )
     [ 2^-ceil ] map ; foldable flushable
 
-: <texture-gadget> ( bytes format dim -- gadget )
+:: (render-bytes) ( dims bytes format texture -- )
-    texture-gadget construct-gadget
-        swap >>dim
-        swap >>format
-        swap >>bytes ;
-
-GENERIC: render* ( texture-gadget -- )
-
-M:: texture-gadget render* ( gadget -- )
     GL_ENABLE_BIT [
         GL_TEXTURE_2D glEnable
-        GL_TEXTURE_2D gadget tex>> glBindTexture
+        GL_TEXTURE_2D texture glBindTexture
         GL_TEXTURE_2D
         0
         GL_RGBA
-        gadget dim>> 2^-bounds first2
+        dims 2^-bounds first2
         0
-        gadget format>>
+        format
         GL_UNSIGNED_BYTE
-        gadget bytes>>
+        bytes
         glTexImage2D
         init-texture
         GL_TEXTURE_2D 0 glBindTexture
     ] do-attribs ;
 
+: render-bytes ( dims bytes format -- texture )
+    gen-texture [ (render-bytes) ] keep ;
+
+: render-bytes* ( dims bytes format -- texture dims )
+    pick >r render-bytes r> ;
+
 :: four-corners ( dim -- )
     [let* | w [ dim first ]
             h [ dim second ]
@@ -56,19 +101,12 @@ M: texture-gadget draw-gadget* ( gadget -- )
             white gl-color
             1.0 -1.0 glPixelZoom
             GL_TEXTURE_2D glEnable
-            GL_TEXTURE_2D over tex>> glBindTexture
+            GL_TEXTURE_2D over get-texture glBindTexture
             GL_QUADS [
-                dim>> four-corners
+                get-dims four-corners
             ] do-state
             GL_TEXTURE_2D 0 glBindTexture
         ] do-attribs
     ] with-translation ;
 
-M: texture-gadget graft* ( gadget -- )
+M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;
-    gen-texture >>tex [ render* ]
-    [ f >>bytes drop ] bi ;
-
-M: texture-gadget ungraft* ( gadget -- )
-    tex>> delete-texture ;
-
-M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ;

extra/pango/cairo/cairo.factor

@@ -9,8 +9,8 @@ arrays pango pango.fonts ;
 IN: pango.cairo
 
 << "pangocairo" {
-!    { [ os winnt? ] [ "libpangocairo-1.dll" ] }
+    { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] }
-!    { [ os macosx? ] [ "libpangocairo.dylib" ] }
+    { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] }
     { [ os unix? ] [ "libpangocairo-1.0.so" ] }
 } cond "cdecl" add-library >>
 
@@ -93,43 +93,24 @@ pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width
 ! Higher level words and combinators
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-USING: destructors accessors namespaces kernel cairo ;
+USING: pango.layouts
-
+destructors accessors namespaces kernel cairo ;
-TUPLE: pango-layout alien ;
-C: <pango-layout> pango-layout
-M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
-
-: layout ( -- pango-layout ) pango-layout get ;
 
 : (with-pango) ( layout quot -- )
     >r alien>> pango-layout r> with-variable ; inline
 
-: with-pango ( quot -- )
+: with-pango-cairo ( quot -- )
-    cr pango_cairo_create_layout <pango-layout> swap
+    cr pango_cairo_create_layout swap with-layout ; inline
-    [ (with-pango) ] curry with-disposal ; inline
-
-: pango-layout-get-pixel-size ( layout -- width height )
-    0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
-    [ *int ] bi@ ;
 
 MEMO: dummy-cairo ( -- cr )
     CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ;
 
 : dummy-pango ( quot -- )
-    >r dummy-cairo cairo r> [ with-pango ] curry with-variable ; inline
+    >r dummy-cairo cairo r> [ with-pango-cairo ] curry with-variable ; inline
 
 : layout-size ( quot -- dim )
     [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
 
-: layout-font ( str -- )
-    pango_font_description_from_string
-    dup zero? [ "pango: not a valid font." throw ] when
-    layout over pango_layout_set_font_description
-    pango_font_description_free ;
-
-: layout-text ( str -- )
-    layout swap -1 pango_layout_set_text ;
-
 : show-layout ( -- )
     cr layout pango_cairo_show_layout ;
 

extra/pango/cairo/gadgets/gadgets.factor

@@ -1,64 +1,27 @@
 ! Copyright (C) 2008 Matthew Willis.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: pango.cairo cairo cairo.ffi
+USING: pango.cairo pango.gadgets
-cairo.gadgets namespaces arrays
+cairo.gadgets arrays namespaces
-fry accessors ui.gadgets assocs
+fry accessors ui.gadgets
-sequences shuffle opengl opengl.gadgets
+sequences opengl.gadgets
-alien.c-types kernel math ;
+kernel pango.layouts ;
+
 IN: pango.cairo.gadgets
 
-SYMBOL: textures
+TUPLE: pango-cairo-gadget < pango-gadget ;
-SYMBOL: dims
-SYMBOL: refcounts
 
-: init-cache ( symbol -- )
+SINGLETON: pango-cairo-backend
-    dup get [ drop ] [ H{ } clone swap set-global ] if ;
+pango-cairo-backend pango-backend set-global
 
-textures init-cache
+M: pango-cairo-backend construct-pango
-dims init-cache
+    pango-cairo-gadget construct-gadget ;
-refcounts init-cache
 
-TUPLE: pango-gadget < cairo-gadget text font ;
+: setup-layout ( gadget -- quot )
+    [ font>> ] [ text>> ] bi
+    '[ , layout-font , layout-text ] ; inline
 
-: cache-key ( gadget -- key )
+M: pango-cairo-gadget render* ( gadget -- ) 
-    [ font>> ] [ text>> ] bi 2array ;
+    setup-layout [ layout-size dup ]
-
+    [ 
-: refcount-change ( gadget quot -- )
+        '[ [ @ show-layout ] with-pango-cairo ]
-    >r cache-key refcounts get
+    ] bi render-cairo render-bytes* ;
-    [ [ 0 ] unless* ] r> compose change-at ;
-
-: <pango-gadget> ( font text -- gadget )
-    pango-gadget construct-gadget
-        swap >>text
-        swap >>font ;
-
-: setup-layout ( {font,text} -- quot )
-    first2 '[ , layout-font , layout-text ] ; inline
-
-M: pango-gadget quot>> ( gadget -- quot )
-    cache-key setup-layout [ show-layout ] compose
-    [ with-pango ] curry ;
-
-M: pango-gadget dim>> ( gadget -- dim )
-    cache-key dims get [ setup-layout layout-size ] cache ;
-
-M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
-
-: release-texture ( gadget -- )
-    cache-key textures get delete-at* [ delete-texture ] [ drop ] if ;
-
-M: pango-gadget ungraft* ( gadget -- )
-    dup [ 1- ] refcount-change
-    dup cache-key refcounts get at
-    zero? [ release-texture ] [ drop ] if ;
-
-M: pango-gadget render* ( gadget -- ) 
-    [ gen-texture ] [ cache-key textures get set-at ] bi
-    call-next-method ;
-
-M: pango-gadget tex>> ( gadget -- texture )
-    dup cache-key textures get at 
-    [ nip ] [ dup render* tex>> ] if* ;
-
-USE: ui.gadgets.panes
-: hello "Sans 50" "hello" <pango-gadget> gadget. ;

extra/pango/cairo/samples/samples.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: prettyprint sequences ui.gadgets.panes
 pango.cairo.gadgets math kernel cairo cairo.ffi
-pango.cairo tools.time namespaces assocs
+pango.cairo pango.gadgets tools.time namespaces assocs
 threads io.backend io.encodings.utf8 io.files ;
 
 IN: pango.cairo.samples
@@ -10,14 +10,9 @@ IN: pango.cairo.samples
 : hello-pango ( -- )
     "monospace 10" "resource:extra/pango/cairo/gadgets/gadgets.factor"
     normalize-path utf8 file-contents
-    <pango-gadget> gadget. ;
+    <pango> gadget. ;
 
 : time-pango ( -- )
     [ hello-pango ] time ;
 
-! clear the caches, for testing.
-: clear-pango ( -- )
-    dims get clear-assoc
-    textures get clear-assoc ;
-
 MAIN: time-pango

extra/pango/ft2/ft2.factor

@@ -0,0 +1,56 @@
+USING: alien alien.c-types
+math kernel byte-arrays freetype
+opengl.gadgets accessors pango
+ui.gadgets memoize
+arrays sequences libc opengl.gl
+system combinators alien.syntax
+pango.layouts ;
+IN: pango.ft2
+
+<< "pangoft2" {
+    { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] }
+    { [ os macosx? ] [ "libpangocairo-1.0.0.dylib" ] }
+    { [ os unix? ] [ "libpangoft2-1.0.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: pangoft2
+
+FUNCTION: PangoFontMap*
+pango_ft2_font_map_new ( ) ;
+
+FUNCTION: PangoContext*
+pango_ft2_font_map_create_context ( PangoFT2FontMap* fontmap ) ;
+
+FUNCTION: void
+pango_ft2_render_layout ( FT_Bitmap* bitmap, PangoLayout* layout, int x, int y ) ;
+
+: 4*-ceil ( n -- k*4 )
+    3 + 4 /i 4 * ;
+
+: <ft-bitmap> ( width height -- ft-bitmap )
+    swap dup
+    2dup * 4*-ceil
+    "uchar" malloc-array
+    256
+    FT_PIXEL_MODE_GRAY
+    "FT_Bitmap" <c-object> dup >r
+    {
+        set-FT_Bitmap-rows
+        set-FT_Bitmap-width
+        set-FT_Bitmap-pitch
+        set-FT_Bitmap-buffer
+        set-FT_Bitmap-num_grays
+        set-FT_Bitmap-pixel_mode
+    } set-slots r> ;
+
+: render-layout ( layout -- dims alien )
+    [ 
+        pango-layout-get-pixel-size
+        2array dup 2^-bounds first2 <ft-bitmap> dup
+    ] [ 0 0 pango_ft2_render_layout ] bi FT_Bitmap-buffer ;
+
+MEMO: ft2-context ( -- PangoContext* )
+    pango_ft2_font_map_new pango_ft2_font_map_create_context ;
+
+: with-ft2-layout ( quot -- )
+    ft2-context pango_layout_new swap with-layout ; inline

extra/pango/ft2/gadgets/gadgets.factor

@@ -0,0 +1,20 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: pango.ft2 pango.gadgets opengl.gadgets
+accessors kernel opengl.gl libc
+sequences namespaces ui.gadgets pango.layouts ;
+IN: pango.ft2.gadgets
+
+TUPLE: pango-ft2-gadget < pango-gadget ;
+
+SINGLETON: pango-ft2-backend
+pango-ft2-backend pango-backend set-global
+
+M: pango-ft2-backend construct-pango
+    pango-ft2-gadget construct-gadget ;
+
+M: pango-ft2-gadget render*
+    [
+        [ text>> layout-text ] [ font>> layout-font ] bi
+        layout render-layout
+    ] with-ft2-layout [ GL_ALPHA render-bytes* ] keep free ;

extra/pango/gadgets/gadgets.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: opengl.gadgets kernel
+arrays
+accessors ;
+
+IN: pango.gadgets
+
+TUPLE: pango-gadget < texture-gadget text font ;
+
+M: pango-gadget cache-key* [ font>> ] [ text>> ] bi 2array ;
+
+SYMBOL: pango-backend
+HOOK: construct-pango pango-backend ( -- gadget )
+
+: <pango> ( font text -- gadget )
+    construct-pango
+        swap >>text
+        swap >>font ;

extra/pango/layouts/layouts.factor

@@ -0,0 +1,30 @@
+USING: alien alien.c-types 
+math
+destructors accessors namespaces
+pango kernel ;
+IN: pango.layouts
+
+: pango-layout-get-pixel-size ( layout -- width height )
+    0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
+    [ *int ] bi@ ;
+
+TUPLE: pango-layout alien ;
+C: <pango-layout> pango-layout
+M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
+
+: layout ( -- pango-layout ) pango-layout get ;
+
+: (with-layout) ( pango-layout quot -- )
+    >r alien>> pango-layout r> with-variable ; inline
+
+: with-layout ( layout quot -- )
+    >r <pango-layout> r> [ (with-layout) ] curry with-disposal ; inline
+
+: layout-font ( str -- )
+    pango_font_description_from_string
+    dup zero? [ "pango: not a valid font." throw ] when
+    layout over pango_layout_set_font_description
+    pango_font_description_free ;
+
+: layout-text ( str -- )
+    layout swap -1 pango_layout_set_text ;

extra/pango/pango.factor

@@ -9,8 +9,8 @@ IN: pango
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 << "pango" {
-!    { [ os winnt? ] [ "libpango-1.dll" ] }
+    { [ os winnt? ] [ "libpango-1.0-0.dll" ] }
-!    { [ os macosx? ] [ "libpango.dylib" ] }
+    { [ os macosx? ] [ "libpango-1.0.0.dylib" ] }
     { [ os unix? ] [ "libpango-1.0.so" ] }
 } cond "cdecl" add-library >>
 
@@ -18,6 +18,9 @@ LIBRARY: pango
 
 : PANGO_SCALE 1024 ;
 
+FUNCTION: PangoLayout*
+pango_layout_new ( PangoContext* context ) ;
+
 FUNCTION: void
 pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
 

extra/tools/crossref/crossref.factor

@@ -7,7 +7,7 @@ sorting hashtables vocabs parser source-files ;
 IN: tools.crossref
 
 : usage. ( word -- )
-    usage sorted-definitions. ;
+    smart-usage sorted-definitions. ;
 
 : words-matching ( str -- seq )
     all-words [ dup word-name ] { } map>assoc completions ;

extra/tools/profiler/profiler-docs.factor

@@ -44,7 +44,7 @@ HELP: vocab-profile.
 HELP: usage-profile.
 { $values { "word" word } }
 { $description "Prints a table of call counts from the most recent invocation of " { $link profile } ", for words which directly call " { $snippet "word" } " only." }
-{ $notes "This word obtains the list of static usages with the " { $link usage } " word, and is not aware of dynamic call history. Consider the following scenario. A word " { $snippet "X" } " can execute word " { $snippet "Y" } " in a conditional branch, and " { $snippet "X" } " is executed many times during the profiling run, but this particular branch executing " { $snippet "Y" } " is never taken. However, some other word does execute " { $snippet "Y" } " multiple times. Then " { $snippet "\\ Y usage-profile." } " will list a number of calls to " { $snippet "X" } ", even though " { $snippet "Y" } " was never executed " { $emphasis "from" } " " { $snippet "X" } "." }
+{ $notes "This word obtains the list of static usages with the " { $link smart-usage } " word, and is not aware of dynamic call history. Consider the following scenario. A word " { $snippet "X" } " can execute word " { $snippet "Y" } " in a conditional branch, and " { $snippet "X" } " is executed many times during the profiling run, but this particular branch executing " { $snippet "Y" } " is never taken. However, some other word does execute " { $snippet "Y" } " multiple times. Then " { $snippet "\\ Y usage-profile." } " will list a number of calls to " { $snippet "X" } ", even though " { $snippet "Y" } " was never executed " { $emphasis "from" } " " { $snippet "X" } "." }
 { $examples { $code "\\ + usage-profile." } } ;
 
 HELP: vocabs-profile.

extra/tools/profiler/profiler.factor

@@ -58,7 +58,7 @@ M: method-body (profile.)
     "Call counts for words which call " write
     dup pprint
     ":" print
-    usage [ word? ] filter counters counters. ;
+    smart-usage [ word? ] filter counters counters. ;
 
 : vocabs-profile. ( -- )
     "Call counts for all vocabularies:" print

extra/ui/tools/search/search.factor

@@ -94,7 +94,7 @@ M: live-search pref-dim* drop { 400 200 } ;
     "Words in " rot vocab-name append show-titled-popup ;
 
 : show-word-usage ( workspace word -- )
-    "" over usage f <definition-search>
+    "" over smart-usage f <definition-search>
     "Words and methods using " rot word-name append
     show-titled-popup ;
 

extra/ui/windows/windows.factor

@@ -3,7 +3,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings arrays assocs ui
 ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
-ui.gestures io kernel math math.vectors namespaces prettyprint
+ui.gestures io kernel math math.vectors namespaces
 sequences strings vectors words windows.kernel32 windows.gdi32
 windows.user32 windows.opengl32 windows.messages windows.types
 windows.nt windows threads libc combinators continuations
@@ -380,7 +380,7 @@ SYMBOL: trace-messages?
     "uint" { "void*" "uint" "long" "long" } "stdcall" [
         [
             pick
-            trace-messages? get-global [ dup windows-message-name . ] when
+            trace-messages? get-global [ dup windows-message-name word-name print flush ] when
             wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
         ] ui-try
      ] alien-callback ;

extra/unicode/data/data.factor

@@ -46,11 +46,11 @@ VALUE: properties
 
 : (process-data) ( index data -- newdata )
     filter-comments
-    [ [ nth ] keep first swap 2array ] with map
+    [ [ nth ] keep first swap ] with { } map>assoc
     [ >r hex> r> ] assoc-map ;
 
 : process-data ( index data -- hash )
-    (process-data) [ hex> ] assoc-map >hashtable ;
+    (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ;
 
 : (chain-decomposed) ( hash value -- newvalue )
     [

extra/urls/urls-tests.factor

@@ -1,7 +1,7 @@
 IN: urls.tests
 USING: urls urls.private tools.test
 tuple-syntax arrays kernel assocs
-present ;
+present accessors ;
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
 [ "hello world" ] [ "hello%20world" url-decode ] unit-test
@@ -224,3 +224,5 @@ urls [
 [ "a" ] [
     <url> "a" "b" set-query-param "b" query-param
 ] unit-test
+
+[ "foo#3" ] [ URL" foo" clone 3 >>anchor present ] unit-test

extra/urls/urls.factor

@@ -170,7 +170,7 @@ M: url present
             [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
             [ path>> url-encode % ]
             [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
-            [ anchor>> [ "#" % url-encode % ] when* ]
+            [ anchor>> [ "#" % present url-encode % ] when* ]
         } cleave
     ] "" make ;
 

extra/webapps/blogs/blogs-common.xml

@@ -0,0 +1,31 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:atom t:href="$blogs/posts.atom">Recent Posts</t:atom>
+
+	<t:style t:include="resource:extra/webapps/blogs/blogs.css" />
+
+	<div class="navbar">
+
+		  <t:a t:href="$blogs/">All Posts</t:a>
+		| <t:a t:href="$blogs/by">My Posts</t:a>
+		| <t:a t:href="$blogs/new-post">New Post</t:a>
+
+		<t:if t:code="furnace.sessions:uid">
+
+			<t:if t:code="furnace.auth.login:allow-edit-profile?">
+				| <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
+			</t:if>
+
+			| <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
+
+		</t:if>
+
+	</div>
+
+	<h1><t:write-title /></h1>
+
+	<t:call-next-template />
+
+</t:chloe>

extra/webapps/blogs/blogs.css

@@ -0,0 +1,15 @@
+.post-form {
+	border: 2px solid #666;
+	padding: 10px;
+	background: #eee;
+}
+
+.post-title {
+	background-color:#f5f5ff;
+	padding: 3px;
+}
+
+.post-footer {
+	text-align: right;
+	font-size:90%;
+}

extra/webapps/blogs/blogs.factor

@@ -0,0 +1,253 @@
+! 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
+http.server.dispatchers
+furnace furnace.actions furnace.auth.login furnace.boilerplate
+furnace.sessions furnace.syndication ;
+IN: webapps.blogs
+
+TUPLE: blogs < dispatcher ;
+
+: view-post-url ( id -- url )
+    number>string "$blogs/post/" prepend >url ;
+
+: view-comment-url ( parent id -- url )
+    [ view-post-url ] dip >>anchor ;
+
+: list-posts-url ( -- url )
+    URL" $blogs/" ;
+
+: user-posts-url ( author -- url )
+    "$blogs/by/" prepend >url ;
+
+TUPLE: entity id author date content ;
+
+GENERIC: entity-url ( entity -- url )
+
+M: entity feed-entry-url entity-url ;
+
+entity f {
+    { "id" "ID" INTEGER +db-assigned-id+ }
+    { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
+    { "date" "DATE" TIMESTAMP +not-null+ }
+    { "content" "CONTENT" TEXT +not-null+ }
+} define-persistent
+
+M: entity feed-entry-date date>> ;
+
+TUPLE: post < entity title comments ;
+
+M: post feed-entry-title
+    [ author>> ] [ drop ": " ] [ title>> ] tri 3append ;
+
+M: post entity-url
+    id>> view-post-url ;
+
+\ post "BLOG_POSTS" {
+    { "title" "TITLE" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: <post> ( id -- post ) \ post new swap >>id ;
+
+: init-posts-table \ post ensure-table ;
+
+TUPLE: comment < entity parent ;
+
+comment "COMMENTS" {
+    { "parent" "PARENT" INTEGER +not-null+ } ! post id
+} define-persistent
+
+M: comment feed-entry-title
+    author>> "Comment by " prepend ;
+
+M: comment entity-url
+    [ parent>> ] [ id>> ] bi view-comment-url ;
+
+: <comment> ( parent id -- post )
+    comment new
+        swap >>id
+        swap >>parent ;
+
+: init-comments-table comment ensure-table ;
+
+: post ( id -- post )
+    [ <post> select-tuple ] [ f <comment> select-tuples ] bi
+    >>comments ;
+
+: reverse-chronological-order ( seq -- sorted )
+    [ [ date>> ] compare invert-comparison ] sort ;
+
+: validate-author ( -- )
+    { { "author" [ [ v-username ] v-optional ] } } validate-params ;
+
+: list-posts ( -- posts )
+    f <post> "author" value >>author
+    select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
+    reverse-chronological-order ;
+
+: <list-posts-action> ( -- action )
+    <page-action>
+        [
+            list-posts "posts" set-value
+        ] >>init
+
+        { blogs "list-posts" } >>template ;
+
+: <list-posts-feed-action> ( -- action )
+    <feed-action>
+        [ "Recent Posts" ] >>title
+        [ list-posts ] >>entries
+        [ list-posts-url ] >>url ;
+
+: <user-posts-action> ( -- action )
+    <page-action>
+        "author" >>rest
+        [
+            validate-author
+            list-posts "posts" set-value
+        ] >>init
+        { blogs "user-posts" } >>template ;
+
+: <user-posts-feed-action> ( -- action )
+    <feed-action>
+        [ validate-author ] >>init
+        [ "Recent Posts by " "author" value append ] >>title
+        [ list-posts ] >>entries
+        [ "author" value user-posts-url ] >>url ;
+
+: <post-feed-action> ( -- action )
+    <feed-action>
+        [ validate-integer-id "id" value post "post" set-value ] >>init
+        [ "post" value feed-entry-title ] >>title
+        [ "post" value entity-url ] >>url
+        [ "post" value comments>> ] >>entries ;
+
+: <view-post-action> ( -- action )
+    <page-action>
+        "id" >>rest
+
+        [
+            validate-integer-id
+            "id" value post from-object
+
+            "id" value
+            "new-comment" [
+                "parent" set-value
+            ] nest-values
+        ] >>init
+
+        { blogs "view-post" } >>template ;
+
+: validate-post ( -- )
+    {
+        { "title" [ v-one-line ] }
+        { "content" [ v-required ] }
+    } validate-params ;
+
+: <new-post-action> ( -- action )
+    <page-action>
+        [
+            validate-post
+            uid "author" set-value
+        ] >>validate
+
+        [
+            f <post>
+                dup { "title" "content" } deposit-slots
+                uid >>author
+                now >>date
+            [ insert-tuple ] [ entity-url <redirect> ] bi
+        ] >>submit
+
+        { blogs "new-post" } >>template ;
+
+: <edit-post-action> ( -- action )
+    <page-action>
+        [
+            validate-integer-id
+            "id" value <post> select-tuple from-object
+        ] >>init
+
+        [
+            validate-integer-id
+            validate-post
+        ] >>validate
+
+        [
+            "id" value <post> select-tuple
+                dup { "title" "content" } deposit-slots
+            [ update-tuple ] [ entity-url <redirect> ] bi
+        ] >>submit
+
+        { blogs "edit-post" } >>template ;
+    
+: <delete-post-action> ( -- action )
+    <action>
+        [
+            validate-integer-id
+            { { "author" [ v-username ] } } validate-params
+        ] >>validate
+        [
+            "id" value <post> delete-tuples
+            "author" value user-posts-url <redirect>
+        ] >>submit ;
+
+: validate-comment ( -- )
+    {
+        { "parent" [ v-integer ] }
+        { "content" [ v-required ] }
+    } validate-params ;
+
+: <new-comment-action> ( -- action )
+    <action>
+
+        [
+            validate-comment
+            uid "author" set-value
+        ] >>validate
+
+        [
+            "parent" value f <comment>
+                "content" value >>content
+                uid >>author
+                now >>date
+            [ insert-tuple ] [ entity-url <redirect> ] bi
+        ] >>submit ;
+    
+: <delete-comment-action> ( -- action )
+    <action>
+        [
+            validate-integer-id
+            { { "parent" [ v-integer ] } } validate-params
+        ] >>validate
+        [
+            f "id" value <comment> delete-tuples
+            "parent" value view-post-url <redirect>
+        ] >>submit ;
+    
+: <blogs> ( -- dispatcher )
+    blogs new-dispatcher
+        <list-posts-action> "" add-responder
+        <list-posts-feed-action> "posts.atom" add-responder
+        <user-posts-action> "by" add-responder
+        <user-posts-feed-action> "by.atom" add-responder
+        <view-post-action> "post" add-responder
+        <post-feed-action> "post.atom" add-responder
+        <new-post-action> <protected>
+            "make a new blog post" >>description
+            "new-post" add-responder
+        <edit-post-action> <protected>
+            "edit a blog post" >>description
+            "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

@@ -0,0 +1,29 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Edit: <t:label t:name="title" /></t:title>
+
+	<div class="post-form">
+		<t:form t:action="$blogs/edit-post" t:for="id">
+
+			<p>Title: <t:field t:name="title" t:size="60" /></p>
+			<p><t:textarea t:name="content" t:rows="30" t:cols="80" /></p>
+			<input type="SUBMIT" value="Done" />
+		</t:form>
+	</div>
+
+	<div class="posting-footer">
+		Post by
+		<t:a t:href="$blogs/" t:query="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:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
+	</div>
+
+</t:chloe>

extra/webapps/blogs/list-posts.xml

@@ -0,0 +1,35 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Recent Posts</t:title>
+
+	<t:bind-each t:name="posts">
+
+		<h2 class="post-title">
+			<t:a t:href="$blogs/post" t:query="id">
+				<t:label t:name="title" />
+			</t:a>
+		</h2>
+
+		<p class="posting-body">
+			<t:farkup t:name="content" />
+		</p>
+
+		<div class="posting-footer">
+			Post by
+			<t:a t:href="$blogs/by" t:query="author">
+				<t:label t:name="author" />
+			</t:a>
+			on
+			<t:label t:name="date" />
+			|
+			<t:a t:href="$blogs/post" t:query="id">
+				<t:label t:name="comments" />
+				comments.
+			</t:a>
+		</div>
+
+	</t:bind-each>
+
+</t:chloe>

extra/webapps/blogs/new-post.xml

@@ -0,0 +1,17 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>New Post</t:title>
+
+	<div class="post-form">
+		<t:form t:action="$blogs/new-post">
+	
+			<p>Title: <t:field t:name="title" t:size="60" /></p>
+			<p><t:textarea t:name="content" t:rows="30" t:cols="80" /></p>
+			<input type="SUBMIT" value="Done" />
+		</t:form>
+	</div>
+
+	<t:validation-messages />
+</t:chloe>

extra/webapps/blogs/user-posts.xml

@@ -0,0 +1,41 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:atom t:href="$blogs/by" t:query="author">
+		Recent Posts by <t:label t:name="author" />
+	</t:atom>
+
+	<t:title>
+		Recent Posts by <t:label t:name="author" />
+	</t:title>
+
+	<t:bind-each t:name="posts">
+
+		<h2 class="post-title">
+			<t:a t:href="$blogs/post" t:query="id">
+				<t:label t:name="title" />
+			</t:a>
+		</h2>
+
+		<p class="posting-body">
+			<t:farkup t:name="content" />
+		</p>
+
+		<div class="posting-footer">
+			Post by
+			<t:a t:href="$blogs/by" t:query="author">
+				<t:label t:name="author" />
+			</t:a>
+			on
+			<t:label t:name="date" />
+			|
+			<t:a t:href="$blogs/post" t:query="id">
+				<t:label t:name="comments" />
+				comments.
+			</t:a>
+		</div>
+
+	</t:bind-each>
+
+</t:chloe>

extra/webapps/blogs/view-post.xml

@@ -0,0 +1,60 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:atom t:href="$blogs/post.atom" t:query="id">
+		<t:label t:name="author" />: <t:label t:name="title" />
+	</t:atom>
+
+	<t:atom t:href="$blogs/by.atom" t:query="author">
+		Recent Posts by <t:label t:name="author" />
+	</t:atom>
+
+	<t:title> <t:label t:name="author" />: <t:label t:name="title" /> </t:title>
+
+	<p class="posting-body">
+		<t:farkup t:name="content" />
+	</p>
+
+	<div class="posting-footer">
+		Post by
+		<t:a t:href="$blogs/" t:query="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:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
+	</div>
+
+	<t:bind-each t:name="comments">
+		<hr/>
+
+		<p class="comment-header">
+			Comment by <t:label t:name="author" /> on <t:label t:name="date" />:
+		</p>
+
+		<p class="posting-body">
+			<t:farkup t:name="content" />
+		</p>
+		
+		<t:button t:action="$blogs/delete-comment" t:for="id,parent" class="link-button link">Delete Comment</t:button>
+
+	</t:bind-each>
+
+	<t:bind t:name="new-comment">
+
+		<h2>New Comment</h2>
+
+		<div class="post-form">
+			<t:form t:action="$blogs/new-comment" t:for="parent">
+				<p><t:textarea t:name="content" t:rows="20" t:cols="60" /></p>
+				<p><input type="SUBMIT" value="Done" /></p>
+			</t:form>
+		</div>
+
+	</t:bind>
+
+</t:chloe>

extra/webapps/factor-website/factor-website.factor

@@ -12,6 +12,7 @@ furnace.sessions
 furnace.auth.login
 furnace.auth.providers.db
 furnace.boilerplate
+webapps.blogs
 webapps.pastebin
 webapps.planet
 webapps.todo
@@ -38,6 +39,9 @@ IN: webapps.factor-website
         init-articles-table
         init-revisions-table
 
+        init-postings-table
+        init-comments-table
+
         init-short-url-table
     ] with-db ;
 
@@ -45,6 +49,7 @@ TUPLE: factor-website < dispatcher ;
 
 : <factor-website> ( -- responder )
     factor-website new-dispatcher
+        <blogs> "blogs" add-responder
         <todo-list> "todo" add-responder
         <pastebin> "pastebin" add-responder
         <planet-factor> "planet" add-responder

extra/webapps/pastebin/paste.xml

@@ -53,6 +53,7 @@
 			</table>
 
 			<input type="SUBMIT" value="Done" />
+
 		</t:form>
 
 	</t:bind>

extra/webapps/planet/planet.xml

@@ -19,7 +19,7 @@
 					</p>
 
 					<p class="posting-date">
-						<t:a t:value="url"><t:label t:name="pub-date" /></t:a>
+						<t:a t:value="url"><t:label t:name="date" /></t:a>
 					</p>
 
 				</t:bind-each>

extra/webapps/todo/todo.factor

@@ -51,6 +51,9 @@ todo "TODO"
         { "description" [ v-required ] }
     } validate-params ;
 
+: view-todo-url ( id -- url )
+    <url> "$todo-list/view" >>path swap "id" set-query-param ;
+
 : <new-action> ( -- action )
     <page-action>
         [ 0 "priority" set-value ] >>init
@@ -62,14 +65,7 @@ todo "TODO"
         [
             f <todo>
                 dup { "summary" "priority" "description" } deposit-slots
-            [ insert-tuple ]
+            [ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
-            [
-                <url>
-                    "$todo-list/view" >>path
-                    swap id>> "id" set-query-param
-                <redirect>
-            ]
-            bi
         ] >>submit ;
 
 : <edit-action> ( -- action )
@@ -89,23 +85,19 @@ todo "TODO"
         [
             f <todo>
                 dup { "id" "summary" "priority" "description" } deposit-slots
-            [ update-tuple ]
+            [ update-tuple ] [ id>> view-todo-url <redirect> ] bi
-            [
-                <url>
-                    "$todo-list/view" >>path
-                    swap id>> "id" set-query-param
-                <redirect>
-            ]
-            bi
         ] >>submit ;
 
+: todo-list-url ( -- url )
+    URL" $todo-list/list" ;
+
 : <delete-action> ( -- action )
     <action>
         [ validate-integer-id ] >>validate
 
         [
             "id" get <todo> delete-tuples
-            URL" $todo-list/list" <redirect>
+            todo-list-url <redirect>
         ] >>submit ;
 
 : <list-action> ( -- action )

extra/webapps/wiki/wiki.factor

@@ -15,14 +15,14 @@ validators
 db.types db.tuples lcs farkup urls ;
 IN: webapps.wiki
 
-: title-url ( title action -- url )
+: view-url ( title -- url )
-    "$wiki/" prepend >url swap "title" set-query-param ;
+    "$wiki/view/" prepend >url ;
 
-: view-url ( title -- url ) "view" title-url ;
+: edit-url ( title -- url )
+    "$wiki/edit" >url swap "title" set-query-param ;
 
-: edit-url ( title -- url ) "edit" title-url ;
+: revisions-url ( title -- url )
-
+    "$wiki/revisions" >url swap "title" set-query-param ;
-: revisions-url ( title -- url ) "revisions" title-url ;
 
 : revision-url ( id -- url )
     "$wiki/revision" >url swap "id" set-query-param ;