diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index ef00e94dd5..8c653b866e 100755
--- a/core/compiler/compiler.factor
+++ b/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 ;
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index c2e84429cf..6acd3a6415 100755
--- a/core/compiler/units/units.factor
+++ b/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 -- )
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 459512b83a..122205eb26 100755
--- a/core/definitions/definitions.factor
+++ b/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 ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index b9a556e316..c99de94ded 100755
--- a/core/generic/generic.factor
+++ b/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
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 51ea4f8225..24fb8ba4f4 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/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?
- drop t ;
+M: engine-word crossref? drop t ;
+
+M: engine-word irrelevant? drop t ;
: remember-engine ( word -- )
generic get "engines" word-prop push ;
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index 1bff9ae15d..66f191a93f 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/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
diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor
index 91314d1312..ccfa490318 100755
--- a/core/inference/backend/backend-docs.factor
+++ b/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
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index c49e7fda8a..42a1c1dd19 100755
--- a/core/inference/backend/backend.factor
+++ b/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>
- terminated? get over set-effect-terminated? ;
+ d-in get
+ 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 set
- [ apply-object terminated? get not ] all? drop
- r> recursive-state set ;
+ recursive-state get [
+ recursive-state set
+ [ apply-object terminated? get not ] all? drop
+ ] 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
- over value-recursion
- rot f 2array prefix infer-quot
+ [ value-literal ]
+ [ [ value-recursion ] keep f 2array prefix ]
+ 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
- over effect-out over produce-values
- node,
- effect-terminated? [ terminate ] when ;
+ [ [ in>> ] dip consume-values ]
+ [ [ out>> ] dip produce-values ]
+ [ node, 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
- swap [ curried-quot ] map unify-values
+ [ [ obj>> ] map unify-values ]
+ [ [ quot>> ] map unify-values ] bi
<curried> ;
: unify-composed ( seq -- value )
- dup [ composed-quot1 ] map unify-values
- swap [ composed-quot2 ] map unify-values
+ [ [ quot1>> ] 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
- over d-in branch-variable
- rot meta-d active-variable
- unify-effect meta-d set d-in set ;
+ [ quotation branch-variable ]
+ [ d-in branch-variable ]
+ [ meta-d active-variable ] tri
+ unify-effect
+ [ d-in set ] [ meta-d set ] bi* ;
: retainstack-effect ( seq -- )
- dup quotation branch-variable
- over length 0 <repetition>
- rot meta-r active-variable
- unify-effect meta-r set drop ;
+ [ quotation branch-variable ]
+ [ length 0 <repetition> ]
+ [ meta-r active-variable ] tri
+ unify-effect
+ [ drop ] [ meta-r set ] bi* ;
: unify-effects ( seq -- )
- dup datastack-effect
- dup retainstack-effect
- [ terminated? swap at ] all? terminated? set ;
+ [ datastack-effect ]
+ [ retainstack-effect ]
+ [ [ 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
- over recorded get push
- "inferred-effect" set-word-prop ;
+ [ check-effect ]
+ [ drop recorded get push ]
+ [ "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
- "infer" word-prop call ;
+ [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
: 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 node, penultimate-node f over set-node-successor
- dup current-node set
- ] when drop ;
+ dup successor>> [
+ [ node, ] [ penultimate-node ] bi
+ f >>successor
+ current-node set
+ ] [ drop ] if ;
-: apply-infer ( hash -- )
- { meta-d meta-r d-in terminated? }
- [ swap [ at ] curry map ] keep
- [ set ] 2each ;
+: apply-infer ( data -- )
+ { meta-d meta-r d-in terminated? } swap extract-keys
+ namespace swap update ;
+
+: 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? [
- flatten-meta-d >r
- drop join-values inline-block apply-infer
- r> over set-node-in-d
- dup node,
- calls>> [
- [ flatten-curries ] modify-values
- ] each
- ] [
- apply-infer node-child node-successor splice-node drop
- ] if ;
+ dup inline-block over recursive-label?
+ [ drop inline-recursive-word ]
+ [ apply-infer node-child successor>> splice-node drop ] if ;
M: word apply-object
[
diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor
index f565420cac..3c6680bcde 100644
--- a/core/inference/errors/errors.factor
+++ b/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
- over unbalanced-branches-error-in
- rot unbalanced-branches-error-out [ length ] map
- 3array flip [ [ bl ] [ pprint ] interleave nl ] each ;
+ [ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 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 .
- "Inferred: " write effect-error-effect effect>string . ;
+ dup word>> stack-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 ;
diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor
index d79c82ed65..acc9329670 100755
--- a/core/inference/inference-docs.factor
+++ b/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."
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index 0d3eb03cf4..4ce354bdcc 100755
--- a/core/inference/inference-tests.factor
+++ b/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
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 9112dbf25e..61f687c95a 100755
--- a/core/kernel/kernel.factor
+++ b/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 -- )
diff --git a/core/words/words.factor b/core/words/words.factor
index 5549f98010..bc4b2ede72 100755
--- a/core/words/words.factor
+++ b/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
-
-: 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 ;
+M: object redefined drop ;
: define ( word def -- )
[ ] like
diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor
index b42c47d79b..c9fef618f8 100644
--- a/extra/cairo/gadgets/gadgets.factor
+++ b/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 -- )
- dup
- [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi
- >>bytes call-next-method ;
+: render-cairo ( dim quot -- bytes format )
+ >r 2^-bounds r> copy-cairo GL_BGRA ; inline
+
+! 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 )
- normalize-path cairo_image_surface_create_from_png
+TUPLE: png-gadget < texture-gadget path ;
+: <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>> ;
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index d121e06445..b7cc6c81c2 100755
--- a/extra/db/tuples/tuples.factor
+++ b/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 ;
diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor
new file mode 100644
index 0000000000..7c33265d39
--- /dev/null
+++ b/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
\ No newline at end of file
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index a15a12830c..25bd560d42 100755
--- a/extra/editors/editors.factor
+++ b/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 . ]
[
diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor
index f34bdc9920..8572a8bd91 100755
--- a/extra/freetype/freetype.factor
+++ b/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 ) ;
+
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 862ed80e11..3566d45c5b 100644
--- a/extra/furnace/furnace.factor
+++ 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 -- )
[
diff --git a/extra/help/html/html.factor b/extra/help/html/html.factor
new file mode 100644
index 0000000000..b1bf8958a8
--- /dev/null
+++ b/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
+
+
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 10d6070f7b..fc50432030 100755
--- a/extra/http/server/server.factor
+++ b/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" =
- [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ;
+ request get method>> "HEAD" = [ drop ] [
+ '[ , write-response-body ]
+ [
+ development-mode get
+ [ http-error. ] [ drop "Response error" ] if
+ ] recover
+ ] if ;
LOG: httpd-hit NOTICE
diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
index c4090e1098..14b91aa58b 100644
--- a/extra/lisp/lisp-tests.factor
+++ b/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
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index e865a2e3ed..425ee27bb7 100644
--- a/extra/lisp/lisp.factor
+++ b/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 ;
diff --git a/extra/lists/lazy/examples/examples-tests.factor b/extra/lists/lazy/examples/examples-tests.factor
index d4e3ed79b8..c088f1d9a7 100644
--- a/extra/lists/lazy/examples/examples-tests.factor
+++ b/extra/lists/lazy/examples/examples-tests.factor
@@ -1,5 +1,5 @@
-USING: lazy-lists.examples lazy-lists tools.test ;
-IN: lazy-lists.examples.tests
+USING: lists.lazy.examples lazy-lists tools.test ;
+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
diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor
index 6176c12d21..232fdb25b3 100755
--- a/extra/math/functions/functions-tests.factor
+++ b/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
diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor
index bb43e4a721..4dcb215138 100755
--- a/extra/math/functions/functions.factor
+++ b/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
diff --git a/extra/math/libm/libm.factor b/extra/math/libm/libm.factor
old mode 100644
new mode 100755
index f70c8d2a77..8bda6a6dd0
--- a/extra/math/libm/libm.factor
+++ b/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
diff --git a/extra/opengl/gadgets/gadgets-tests.factor b/extra/opengl/gadgets/gadgets-tests.factor
new file mode 100644
index 0000000000..499ec9730a
--- /dev/null
+++ b/extra/opengl/gadgets/gadgets-tests.factor
@@ -0,0 +1,4 @@
+IN: opengl.gadgets.tests
+USING: tools.test opengl.gadgets ;
+
+\ render* must-infer
diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor
index de37969220..9e670c04ab 100644
--- a/extra/opengl/gadgets/gadgets.factor
+++ b/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 )
- texture-gadget construct-gadget
- swap >>dim
- swap >>format
- swap >>bytes ;
-
-GENERIC: render* ( texture-gadget -- )
-
-M:: texture-gadget render* ( gadget -- )
+:: (render-bytes) ( dims bytes format texture -- )
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 -- )
- gen-texture >>tex [ render* ]
- [ f >>bytes drop ] bi ;
-
-M: texture-gadget ungraft* ( gadget -- )
- tex>> delete-texture ;
-
-M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ;
+M: texture-gadget pref-dim* ( gadget -- dim ) get-dims ;
diff --git a/extra/pango/cairo/cairo.factor b/extra/pango/cairo/cairo.factor
index d1b536d9bc..1ff5328ee0 100644
--- a/extra/pango/cairo/cairo.factor
+++ b/extra/pango/cairo/cairo.factor
@@ -9,8 +9,8 @@ arrays pango pango.fonts ;
IN: pango.cairo
<< "pangocairo" {
-! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
-! { [ os macosx? ] [ "libpangocairo.dylib" ] }
+ { [ os winnt? ] [ "libpangocairo-1.0-0.dll" ] }
+ { [ 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 ;
-
-TUPLE: pango-layout alien ;
-C: <pango-layout> pango-layout
-M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
-
-: layout ( -- pango-layout ) pango-layout get ;
+USING: pango.layouts
+destructors accessors namespaces kernel cairo ;
: (with-pango) ( layout quot -- )
>r alien>> pango-layout r> with-variable ; inline
-: with-pango ( quot -- )
- cr pango_cairo_create_layout <pango-layout> swap
- [ (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@ ;
+: with-pango-cairo ( quot -- )
+ cr pango_cairo_create_layout swap with-layout ; inline
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 ;
diff --git a/extra/pango/cairo/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor
index 118ed76afc..a21affc364 100644
--- a/extra/pango/cairo/gadgets/gadgets.factor
+++ b/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
-cairo.gadgets namespaces arrays
-fry accessors ui.gadgets assocs
-sequences shuffle opengl opengl.gadgets
-alien.c-types kernel math ;
+USING: pango.cairo pango.gadgets
+cairo.gadgets arrays namespaces
+fry accessors ui.gadgets
+sequences opengl.gadgets
+kernel pango.layouts ;
+
IN: pango.cairo.gadgets
-SYMBOL: textures
-SYMBOL: dims
-SYMBOL: refcounts
+TUPLE: pango-cairo-gadget < pango-gadget ;
-: init-cache ( symbol -- )
- dup get [ drop ] [ H{ } clone swap set-global ] if ;
+SINGLETON: pango-cairo-backend
+pango-cairo-backend pango-backend set-global
-textures init-cache
-dims init-cache
-refcounts init-cache
+M: pango-cairo-backend construct-pango
+ pango-cairo-gadget construct-gadget ;
-TUPLE: pango-gadget < cairo-gadget text font ;
+: setup-layout ( gadget -- quot )
+ [ font>> ] [ text>> ] bi
+ '[ , layout-font , layout-text ] ; inline
-: cache-key ( gadget -- key )
- [ font>> ] [ text>> ] bi 2array ;
-
-: refcount-change ( gadget quot -- )
- >r cache-key refcounts get
- [ [ 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. ;
+M: pango-cairo-gadget render* ( gadget -- )
+ setup-layout [ layout-size dup ]
+ [
+ '[ [ @ show-layout ] with-pango-cairo ]
+ ] bi render-cairo render-bytes* ;
diff --git a/extra/pango/cairo/samples/samples.factor b/extra/pango/cairo/samples/samples.factor
index 644d731d70..f081650943 100644
--- a/extra/pango/cairo/samples/samples.factor
+++ b/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
diff --git a/extra/pango/ft2/ft2.factor b/extra/pango/ft2/ft2.factor
new file mode 100644
index 0000000000..5ce59c7095
--- /dev/null
+++ b/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
diff --git a/extra/pango/ft2/gadgets/gadgets.factor b/extra/pango/ft2/gadgets/gadgets.factor
new file mode 100644
index 0000000000..43ddc954ee
--- /dev/null
+++ b/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 ;
diff --git a/extra/pango/gadgets/gadgets.factor b/extra/pango/gadgets/gadgets.factor
new file mode 100644
index 0000000000..f9442a4613
--- /dev/null
+++ b/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 ;
diff --git a/extra/pango/layouts/layouts.factor b/extra/pango/layouts/layouts.factor
new file mode 100644
index 0000000000..71317ce552
--- /dev/null
+++ b/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 ;
diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor
index 3549d9abb4..be5c257cb0 100644
--- a/extra/pango/pango.factor
+++ b/extra/pango/pango.factor
@@ -9,8 +9,8 @@ IN: pango
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<< "pango" {
-! { [ os winnt? ] [ "libpango-1.dll" ] }
-! { [ os macosx? ] [ "libpango.dylib" ] }
+ { [ os winnt? ] [ "libpango-1.0-0.dll" ] }
+ { [ 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 ) ;
diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor
index f4515a9ebe..3ff22cb0c6 100755
--- a/extra/tools/crossref/crossref.factor
+++ b/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 ;
diff --git a/extra/tools/profiler/profiler-docs.factor b/extra/tools/profiler/profiler-docs.factor
index 50bbc527d1..69edf1a7e0 100755
--- a/extra/tools/profiler/profiler-docs.factor
+++ b/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.
diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor
index 6a5fce6281..4ae3666829 100755
--- a/extra/tools/profiler/profiler.factor
+++ b/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
diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor
index b18c0c1ad6..695727e314 100755
--- a/extra/ui/tools/search/search.factor
+++ b/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 ;
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index 5e17d02542..d42c679b22 100755
--- a/extra/ui/windows/windows.factor
+++ b/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 ;
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index f9e5667947..125442e17f 100755
--- a/extra/unicode/data/data.factor
+++ b/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 )
[
diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor
index a718989476..87c9b91950 100644
--- a/extra/urls/urls-tests.factor
+++ b/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
diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor
index bb4d17e1f5..7e74fd1115 100644
--- a/extra/urls/urls.factor
+++ b/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 ;
diff --git a/extra/webapps/blogs/blogs-common.xml b/extra/webapps/blogs/blogs-common.xml
new file mode 100644
index 0000000000..965f059abd
--- /dev/null
+++ b/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>
diff --git a/extra/webapps/blogs/blogs.css b/extra/webapps/blogs/blogs.css
new file mode 100644
index 0000000000..66676796a4
--- /dev/null
+++ b/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%;
+}
diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor
new file mode 100644
index 0000000000..60911b4947
--- /dev/null
+++ b/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 ;
diff --git a/extra/webapps/blogs/edit-post.xml b/extra/webapps/blogs/edit-post.xml
new file mode 100644
index 0000000000..da88a78ab0
--- /dev/null
+++ b/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>
diff --git a/extra/webapps/blogs/list-posts.xml b/extra/webapps/blogs/list-posts.xml
new file mode 100644
index 0000000000..9c9685fe74
--- /dev/null
+++ b/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>
diff --git a/extra/webapps/blogs/new-post.xml b/extra/webapps/blogs/new-post.xml
new file mode 100644
index 0000000000..9cb0250518
--- /dev/null
+++ b/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>
diff --git a/extra/webapps/blogs/user-posts.xml b/extra/webapps/blogs/user-posts.xml
new file mode 100644
index 0000000000..95fae23b34
--- /dev/null
+++ b/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>
diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml
new file mode 100644
index 0000000000..23bf513946
--- /dev/null
+++ b/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>
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
index 44899cba31..d17a912ad8 100644
--- a/extra/webapps/factor-website/factor-website.factor
+++ b/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,13 +39,17 @@ IN: webapps.factor-website
init-articles-table
init-revisions-table
+ init-postings-table
+ init-comments-table
+
init-short-url-table
] with-db ;
TUPLE: factor-website < dispatcher ;
: <factor-website> ( -- responder )
- factor-website new-dispatcher
+ factor-website new-dispatcher
+ <blogs> "blogs" add-responder
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
<planet-factor> "planet" add-responder
diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml
index ea69c7bf7d..1c138fc8c0 100644
--- a/extra/webapps/pastebin/paste.xml
+++ b/extra/webapps/pastebin/paste.xml
@@ -53,6 +53,7 @@
</table>
<input type="SUBMIT" value="Done" />
+
</t:form>
</t:bind>
diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml
index 96343bc5fa..fe4d23bd3b 100644
--- a/extra/webapps/planet/planet.xml
+++ b/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>
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 1cecbc1094..a588b880d3 100755
--- a/extra/webapps/todo/todo.factor
+++ b/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 ]
- [
- <url>
- "$todo-list/view" >>path
- swap id>> "id" set-query-param
- <redirect>
- ]
- bi
+ [ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
] >>submit ;
: <edit-action> ( -- action )
@@ -89,23 +85,19 @@ todo "TODO"
[
f <todo>
dup { "id" "summary" "priority" "description" } deposit-slots
- [ update-tuple ]
- [
- <url>
- "$todo-list/view" >>path
- swap id>> "id" set-query-param
- <redirect>
- ]
- bi
+ [ update-tuple ] [ id>> view-todo-url <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 )
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 611bba4c70..1dc6ef4ae8 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/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 )
- "$wiki/" prepend >url swap "title" set-query-param ;
+: view-url ( title -- url )
+ "$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 ) "revisions" title-url ;
+: revisions-url ( title -- url )
+ "$wiki/revisions" >url swap "title" set-query-param ;
: revision-url ( id -- url )
"$wiki/revision" >url swap "id" set-query-param ;