Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
3a941a2b65
|
|
@ -35,7 +35,7 @@ IN: compiler
|
|||
[ swap save-effect ]
|
||||
[ compiled-unxref ]
|
||||
[
|
||||
dup compiled-crossref?
|
||||
dup crossref?
|
||||
[ dependencies get compiled-xref ] [ drop ] if
|
||||
] tri ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>> ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 . ]
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: help.html
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
IN: opengl.gadgets.tests
|
||||
USING: tools.test opengl.gadgets ;
|
||||
|
||||
\ render* must-infer
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
@ -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%;
|
||||
}
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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>
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -53,6 +53,7 @@
|
|||
</table>
|
||||
|
||||
<input type="SUBMIT" value="Done" />
|
||||
|
||||
</t:form>
|
||||
|
||||
</t:bind>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue