steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
John Benediktsson 2008-11-14 14:10:04 -08:00
parent 075f44a803 dd479ffad1
commit 55c67b4851
333 changed files with 4307 additions and 1778 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alias/alias-docs.factor
View File

@ -16,7 +16,7 @@ HELP: ALIAS:
}
} ;
ARTICLE: "alias" "Alias"
ARTICLE: "alias" "Word aliasing"
"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl
"Make a new word that aliases another word:"
{ $subsection define-alias }

3
basis/bootstrap/image/image.factor
View File

@ -134,6 +134,7 @@ SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-declare-word
SYMBOL: jit-save-stack
! Default definition for undefined words
SYMBOL: undefined-quot
@ -158,6 +159,7 @@ SYMBOL: undefined-quot
{ jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-declare-word 42 }
{ jit-save-stack 43 }
{ undefined-quot 60 }
} at header-size + ;
@ -459,6 +461,7 @@ M: quotation '
jit-return
jit-profiling
jit-declare-word
jit-save-stack
undefined-quot
} [ emit-userenv ] each ;

18
basis/bootstrap/stage2.factor
View File

@ -8,6 +8,8 @@ definitions assocs compiler.errors compiler.units
math.parser generic sets debugger command-line ;
IN: bootstrap.stage2
SYMBOL: core-bootstrap-time
SYMBOL: bootstrap-time
: default-image-name ( -- string )
@ -30,11 +32,15 @@ SYMBOL: bootstrap-time
: count-words ( pred -- )
all-words swap count number>string write ;
: print-report ( time -- )
: print-time ( time -- )
1000 /i
60 /mod swap
"Bootstrap completed in " write number>string write
" minutes and " write number>string write " seconds." print
number>string write
" minutes and " write number>string write " seconds." print ;
: print-report ( -- )
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
[ compiled>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
@ -46,7 +52,7 @@ SYMBOL: bootstrap-time
[
! We time bootstrap
millis >r
millis
default-image-name "output-image" set-global
@ -71,6 +77,8 @@ SYMBOL: bootstrap-time
[
load-components
millis over - core-bootstrap-time set-global
run-bootstrap-init
] with-compiler-errors
:errors
@ -92,7 +100,7 @@ SYMBOL: bootstrap-time
] [ print-error 1 exit ] recover
] set-boot-quot
millis r> - dup bootstrap-time set-global
millis swap - bootstrap-time set-global
print-report
"output-image" get save-image-and-exit

23
basis/compiler/cfg/builder/builder.factor
View File

@ -190,7 +190,7 @@ M: #if emit-node
: emit-dispatch ( node -- )
##epilogue
ds-pop ^^offset>slot i ##dispatch
ds-pop ^^offset>slot i 0 ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
@ -221,21 +221,14 @@ M: #push emit-node
literal>> ^^load-literal ds-push iterate-next ;
! #shuffle
: emit-shuffle ( effect -- )
[ out>> ] [ in>> dup length ds-load zip ] bi
'[ _ at ] map ds-store ;
M: #shuffle emit-node
shuffle-effect emit-shuffle iterate-next ;
M: #>r emit-node
[ in-d>> length ] [ out-r>> empty? ] bi
[ neg ##inc-d ] [ ds-load rs-store ] if
iterate-next ;
M: #r> emit-node
[ in-r>> length ] [ out-d>> empty? ] bi
[ neg ##inc-r ] [ rs-load ds-store ] if
dup
H{ } clone
[ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
[ nip ] 2tri
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
iterate-next ;
! #return

2
basis/compiler/cfg/instructions/instructions.factor
View File

@ -62,7 +62,7 @@ INSN: ##jump word ;
INSN: ##return ;
! Jump tables
INSN: ##dispatch src temp ;
INSN: ##dispatch src temp offset ;
INSN: ##dispatch-label label ;
! Slot access

4
basis/compiler/cfg/linearization/linearization.factor
View File

@ -43,8 +43,8 @@ M: ##branch linearize-insn
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
[ (binary-conditional) ]
[ drop dup successors>> first useless-branch? ] 2bi
[ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
[ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ;

5
basis/compiler/cfg/rpo/rpo.factor
View File

@ -9,7 +9,10 @@ SYMBOL: visited
: post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [
dup id>> visited get conjoin
[ successors>> [ post-order-traversal ] each ] [ , ] bi
[
successors>> <reversed>
[ post-order-traversal ] each
] [ , ] bi
] if ;
: post-order ( bb -- blocks )

20
basis/compiler/cfg/stacks/stacks.factor
View File

@ -15,16 +15,28 @@ IN: compiler.cfg.stacks
1 ##inc-d D 0 ##replace ;
: ds-load ( n -- vregs )
[ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
dup 0 =
[ drop f ]
[ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
: ds-store ( vregs -- )
<reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
[
<reversed>
[ length ##inc-d ]
[ [ <ds-loc> ##replace ] each-index ] bi
] unless-empty ;
: rs-load ( n -- vregs )
[ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
dup 0 =
[ drop f ]
[ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
: rs-store ( vregs -- )
<reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
[
<reversed>
[ length ##inc-r ]
[ [ <rs-loc> ##replace ] each-index ] bi
] unless-empty ;
: 2inputs ( -- vreg1 vreg2 )
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;

16
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
math
math fry
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
@ -113,4 +113,18 @@ M: ##compare-imm rewrite
] when
] when ;
: dispatch-offset ( expr -- n )
[ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
\ ##sub-imm eq? [ neg ] when ;
: add-dispatch-offset? ( insn -- expr ? )
src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
M: ##dispatch rewrite
dup add-dispatch-offset? [
[ clone ] dip
[ in1>> vn>vreg >>src ]
[ dispatch-offset '[ _ + ] change-offset ] bi
] [ drop ] if ;
M: insn rewrite ;

2
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -34,7 +34,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##dispatch f V int-regs 1 V int-regs 2 }
T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
} dup value-numbering =
] unit-test

2
basis/compiler/codegen/codegen.factor
View File

@ -93,7 +93,7 @@ M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ;
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
: >slot<
{

4
basis/compiler/codegen/fixup/fixup.factor
View File

@ -72,8 +72,8 @@ SYMBOL: literal-table
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: rel-here ( class -- )
0 swap rt-here rel-fixup ;
: rel-here ( offset class -- )
rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set

1
basis/compiler/constants/constants.factor
View File

@ -45,6 +45,7 @@ IN: compiler.constants
: rt-here 5 ; inline
: rt-label 6 ; inline
: rt-immediate 7 ; inline
: rt-stack-chain 8 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]

11
basis/compiler/tests/templates.factor → basis/compiler/tests/codegen.factor
View File

@ -230,3 +230,14 @@ TUPLE: id obj ;
10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
[ ] [ gc-check-bug ] unit-test
! New optimization
: test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
[ "a" ] [ 8 test-1 ] unit-test
[ "b" ] [ 9 test-1 ] unit-test
: test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
[ "a" ] [ 1 test-2 ] unit-test
[ "b" ] [ 2 test-2 ] unit-test

21
basis/compiler/tree/builder/builder.factor
View File

@ -1,9 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators stack-checker
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.backend compiler.tree ;
assocs words arrays vectors hints combinators compiler.tree
stack-checker
stack-checker.state
stack-checker.errors
stack-checker.visitor
stack-checker.backend
stack-checker.recursive-state ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
@ -12,12 +16,13 @@ IN: compiler.tree.builder
: build-tree ( quot -- nodes )
#! Not safe to call from inference transforms.
[ f infer-quot ] with-tree-builder nip ;
[ f initial-recursive-state infer-quot ] with-tree-builder nip ;
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
[ >vector meta-d set ] [ f infer-quot ] bi*
[ >vector meta-d set ]
[ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;
@ -32,10 +37,10 @@ IN: compiler.tree.builder
dup
[ "inline" word-prop ]
[ "recursive" word-prop ] bi and [
1quotation f infer-quot
1quotation f initial-recursive-state infer-quot
] [
[ specialized-def ]
[ dup 2array 1array ] bi infer-quot
[ specialized-def ] [ initial-recursive-state ] bi
infer-quot
] if ;
: check-cannot-infer ( word -- )

18
basis/compiler/tree/checker/checker.factor
View File

@ -22,8 +22,8 @@ ERROR: check-use-error value message ;
GENERIC: check-node* ( node -- )
M: #shuffle check-node*
[ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
[ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
[ [ mapping>> values ] [ [ in-d>> ] [ in-r>> ] bi append ] bi subset? [ "Bad mapping inputs" throw ] unless ]
[ [ mapping>> keys ] [ [ out-d>> ] [ out-r>> ] bi append ] bi set= [ "Bad mapping outputs" throw ] unless ]
bi ;
: check-lengths ( seq -- )
@ -31,13 +31,6 @@ M: #shuffle check-node*
M: #copy check-node* inputs/outputs 2array check-lengths ;
: check->r/r> ( node -- )
inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ;
M: #>r check-node* check->r/r> ;
M: #r> check-node* check->r/r> ;
M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
M: #phi check-node*
@ -113,11 +106,8 @@ M: #push check-stack-flow* check-out-d ;
M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ;
M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ;
M: #shuffle check-stack-flow*
{ [ check-in-d ] [ check-in-r ] [ check-out-d ] [ check-out-r ] } cleave ;
: assert-datastack-empty ( -- )
datastack get empty? [ "Data stack not empty" throw ] unless ;

12
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -5,7 +5,7 @@ strings sbufs sequences.private slots.private combinators
definitions system layouts vectors math.partial-dispatch
math.order math.functions accessors hashtables classes assocs
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
sorting.private combinators.short-circuit
sorting.private combinators.short-circuit grouping prettyprint
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
@ -500,3 +500,13 @@ cell-bits 32 = [
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
] unit-test
[ ] [
[ { null } declare [ 1 ] [ 2 ] if ]
build-tree normalize propagate cleanup check-nodes
] unit-test
[ t ] [
[ { array } declare 2 <groups> [ . . ] assoc-each ]
\ nth-unsafe inlined?
] unit-test

2
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -102,7 +102,7 @@ M: #declare cleanup* drop f ;
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
dup live-children sift dup length {
{ 0 [ 2drop f ] }
{ 0 [ drop in-d>> #drop ] }
{ 1 [ first swap in-d>> #drop prefix ] }
[ 2drop ]
} case ;

2
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -39,7 +39,7 @@ M: #branch remove-dead-code*
[ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
#shuffle ;
#data-shuffle ;
: insert-drops ( nodes values indices -- nodes' )
'[

26
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -39,12 +39,6 @@ M: #copy compute-live-values*
M: #call compute-live-values* nip look-at-inputs ;
M: #>r compute-live-values*
[ out-r>> ] [ in-d>> ] bi look-at-mapping ;
M: #r> compute-live-values*
[ out-d>> ] [ in-r>> ] bi look-at-mapping ;
M: #shuffle compute-live-values*
mapping>> at look-at-value ;
@ -61,7 +55,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
zip filter-mapping values ;
: filter-live ( values -- values' )
[ live-value? ] filter ;
dup empty? [ [ live-value? ] filter ] unless ;
:: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
inputs
@ -69,7 +63,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
outputs
mapping-keys
mapping-values
filter-corresponding zip #shuffle ; inline
filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
[let* | new-outputs [ outputs make-values ]
@ -95,16 +89,6 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
M: #introduce remove-dead-code* ( #introduce -- nodes )
maybe-drop-dead-outputs ;
M: #>r remove-dead-code*
[ filter-live ] change-out-r
[ filter-live ] change-in-d
dup in-d>> empty? [ drop f ] when ;
M: #r> remove-dead-code*
[ filter-live ] change-out-d
[ filter-live ] change-in-r
dup in-r>> empty? [ drop f ] when ;
M: #push remove-dead-code*
dup out-d>> first live-value? [ drop f ] unless ;
@ -125,12 +109,14 @@ M: #call remove-dead-code*
M: #shuffle remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
[ filter-live ] change-in-r
[ filter-live ] change-out-r
[ filter-mapping ] change-mapping
dup in-d>> empty? [ drop f ] when ;
dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
M: #copy remove-dead-code*
[ in-d>> ] [ out-d>> ] bi
2dup swap zip #shuffle
2dup swap zip #data-shuffle
remove-dead-code* ;
M: #terminate remove-dead-code*

46
basis/compiler/tree/debugger/debugger.factor
View File

@ -3,7 +3,7 @@
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators io sorting hints qualified
combinators combinators.short-circuit io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
@ -57,9 +57,41 @@ TUPLE: shuffle-node { effect effect } ;
M: shuffle-node pprint* effect>> effect>string text ;
: (shuffle-effect) ( in out #shuffle -- effect )
mapping>> '[ _ at ] map <effect> ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
: #>r? ( #shuffle -- ? )
{
[ in-d>> length 1 = ]
[ out-r>> length 1 = ]
[ in-r>> empty? ]
[ out-d>> empty? ]
} 1&& ;
: #r>? ( #shuffle -- ? )
{
[ in-d>> empty? ]
[ out-r>> empty? ]
[ in-r>> length 1 = ]
[ out-d>> length 1 = ]
} 1&& ;
M: #shuffle node>quot
{
{ [ dup #>r? ] [ drop \ >r , ] }
{ [ dup #r>? ] [ drop \ r> , ] }
{
[ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
[
shuffle-effect dup pretty-shuffle
[ % ] [ shuffle-node boa , ] ?if ;
[ % ] [ shuffle-node boa , ] ?if
]
}
[ drop "COMPLEX SHUFFLE" , ]
} cond ;
M: #push node>quot literal>> , ;
@ -82,16 +114,6 @@ M: #if node>quot
M: #dispatch node>quot
children>> [ nodes>quot ] map , \ dispatch , ;
M: #>r node>quot
[ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
<repetition> % ;
DEFER: rdrop
M: #r> node>quot
[ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
<repetition> % ;
M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
M: #alien-indirect node>quot params>> , \ #alien-indirect , ;

4
basis/compiler/tree/def-use/def-use.factor
View File

@ -38,16 +38,16 @@ GENERIC: node-uses-values ( node -- values )
M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ;
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #alien-callback node-uses-values drop f ;
M: node node-uses-values in-d>> ;
GENERIC: node-defs-values ( node -- values )
M: #>r node-defs-values out-r>> ;
M: #shuffle node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
M: #branch node-defs-values drop f ;
M: #declare node-defs-values drop f ;
M: #return node-defs-values drop f ;

2
basis/compiler/tree/escape-analysis/allocations/allocations.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
combinators sets disjoint-sets fry stack-checker.state ;
combinators sets disjoint-sets fry stack-checker.values ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to one of the following:

4
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -8,6 +8,7 @@ math.private kernel tools.test accessors slots.private
quotations.private prettyprint classes.tuple.private classes
classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
kernel.private ;
\ escape-analysis must-infer
@ -34,6 +35,7 @@ M: node count-unboxed-allocations* drop ;
propagate
cleanup
escape-analysis
dup check-nodes
0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
@ -307,7 +309,7 @@ C: <ro-box> ro-box
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 0 ] [
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]

8
basis/compiler/tree/finalization/finalization.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences words memoize classes.builtin
fry assocs
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
@ -27,9 +28,10 @@ GENERIC: finalize* ( node -- nodes )
M: #copy finalize* drop f ;
M: #shuffle finalize*
dup shuffle-effect
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
dup
[ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
[ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
bi and [ drop f ] when ;
: builtin-predicate? ( #call -- ? )
word>> "predicating" word-prop builtin-class? ;

2
basis/compiler/tree/identities/identities.factor
View File

@ -79,7 +79,7 @@ GENERIC: apply-identities* ( node -- node )
: select-input ( node n -- #shuffle )
[ [ in-d>> ] [ out-d>> ] bi ] dip
pick nth over first associate #shuffle ;
pick nth over first associate #data-shuffle ;
M: #call apply-identities*
dup word>> "identities" word-prop [

6
basis/compiler/tree/normalization/renaming/renaming.factor
View File

@ -10,7 +10,7 @@ SYMBOL: rename-map
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
rename-map get '[ [ _ at ] keep or ] map ;
dup empty? [ rename-map get '[ [ _ at ] keep or ] map ] unless ;
: add-renamings ( old new -- )
[ rename-values ] dip
@ -22,13 +22,11 @@ M: #introduce rename-node-values* ;
M: #shuffle rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r
[ [ rename-value ] assoc-map ] change-mapping ;
M: #push rename-node-values* ;
M: #r> rename-node-values*
[ rename-values ] change-in-r ;
M: #terminate rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r ;

4
basis/compiler/tree/propagation/branches/branches.factor
View File

@ -40,8 +40,8 @@ M: #dispatch live-branches
SYMBOL: infer-children-data
: copy-value-info ( -- )
value-infos [ clone ] change
constraints [ clone ] change ;
value-infos [ H{ } clone suffix ] change
constraints [ H{ } clone suffix ] change ;
: no-value-info ( -- )
value-infos off

6
basis/compiler/tree/propagation/constraints/constraints.factor
View File

@ -32,7 +32,7 @@ TUPLE: true-constraint value ;
M: true-constraint assume*
[ \ f class-not <class-info> swap value>> refine-value-info ]
[ constraints get at [ assume ] when* ]
[ constraints get assoc-stack [ assume ] when* ]
bi ;
M: true-constraint satisfied?
@ -44,7 +44,7 @@ TUPLE: false-constraint value ;
M: false-constraint assume*
[ \ f <class-info> swap value>> refine-value-info ]
[ constraints get at [ assume ] when* ]
[ constraints get assoc-stack [ assume ] when* ]
bi ;
M: false-constraint satisfied?
@ -83,7 +83,7 @@ TUPLE: implication p q ;
C: --> implication
: assume-implication ( p q -- )
[ constraints get [ swap suffix ] change-at ]
[ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication assume*

4
basis/compiler/tree/propagation/info/info-tests.factor
View File

@ -70,3 +70,7 @@ TUPLE: test-tuple { x read-only } ;
f f 3 <literal-info> 3array test-tuple <tuple-info> dup
object-info value-info-intersect =
] unit-test
[ t ] [
null-info 3 <literal-info> value-info<=
] unit-test

16
basis/compiler/tree/propagation/info/info.factor
View File

@ -34,7 +34,7 @@ slots ;
: null-info T{ value-info f null empty-interval } ; inline
: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
: object-info T{ value-info f object full-interval } ; inline
: class-interval ( class -- interval )
dup real class<=
@ -43,7 +43,7 @@ slots ;
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
dup empty-interval eq? [
dup special-interval? [
2drop f f
] [
dup from>> first {
@ -243,7 +243,7 @@ DEFER: (value-info-union)
: literals<= ( info1 info2 -- ? )
{
{ [ dup literal?>> not ] [ 2drop t ] }
{ [ over literal?>> not ] [ 2drop f ] }
{ [ over literal?>> not ] [ drop class>> null-class? ] }
[ [ literal>> ] bi@ eql? ]
} cond ;
@ -262,17 +262,19 @@ DEFER: (value-info-union)
]
} cond ;
! Current value --> info mapping
! Assoc stack of current value --> info mapping
SYMBOL: value-infos
: value-info ( value -- info )
resolve-copy value-infos get at null-info or ;
resolve-copy value-infos get assoc-stack null-info or ;
: set-value-info ( info value -- )
resolve-copy value-infos get set-at ;
resolve-copy value-infos get peek set-at ;
: refine-value-info ( info value -- )
resolve-copy value-infos get [ value-info-intersect ] change-at ;
resolve-copy value-infos get
[ assoc-stack value-info-intersect ] 2keep
peek set-at ;
: value-literal ( value -- obj ? )
value-info >literal< ;

4
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -8,7 +8,7 @@ math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
float-arrays system ;
float-arrays system sorting ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@ -592,6 +592,8 @@ MIXIN: empty-mixin
[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
[ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test

6
basis/compiler/tree/propagation/propagation.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces hashtables
USING: accessors kernel sequences namespaces hashtables arrays
compiler.tree
compiler.tree.propagation.copy
compiler.tree.propagation.info
@ -17,7 +17,7 @@ IN: compiler.tree.propagation
: propagate ( node -- node )
H{ } clone copies set
H{ } clone constraints set
H{ } clone value-infos set
H{ } clone 1array value-infos set
H{ } clone 1array constraints set
dup count-nodes
dup (propagate) ;

42
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -17,9 +17,12 @@ IN: compiler.tree.propagation.recursive
[ value-info<= ] 2all?
[ drop ] [ label>> f >>fixed-point drop ] if ;
: latest-input-infos ( node -- infos )
in-d>> [ value-info ] map ;
: recursive-stacks ( #enter-recursive -- stacks initial )
[ label>> calls>> [ node-input-infos ] map flip ]
[ in-d>> [ value-info ] map ] bi ;
[ latest-input-infos ] bi ;
: generalize-counter-interval ( interval initial-interval -- interval' )
{
@ -46,14 +49,13 @@ IN: compiler.tree.propagation.recursive
] if ;
: propagate-recursive-phi ( #enter-recursive -- )
[ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
[ node-output-infos check-fixed-point ]
[ out-d>> set-value-infos drop ]
3bi ;
[ recursive-stacks unify-recursive-stacks ] keep
out-d>> set-value-infos ;
M: #recursive propagate-around ( #recursive -- )
constraints [ H{ } clone suffix ] change
[
constraints [ clone ] change
constraints [ but-last H{ } clone suffix ] change
child>>
[ first compute-copy-equiv ]
@ -62,6 +64,9 @@ M: #recursive propagate-around ( #recursive -- )
tri
] until-fixed-point ;
: recursive-phi-infos ( node -- infos )
label>> enter-recursive>> node-output-infos ;
: generalize-return-interval ( info -- info' )
dup [ literal?>> ] [ class>> null-class? ] bi or
[ clone [-inf,inf] >>interval ] unless ;
@ -70,12 +75,25 @@ M: #recursive propagate-around ( #recursive -- )
[ generalize-return-interval ] map ;
: return-infos ( node -- infos )
label>> [ return>> node-input-infos ] [ loop?>> ] bi
[ generalize-return ] unless ;
label>> return>> node-input-infos generalize-return ;
: save-return-infos ( node infos -- )
swap out-d>> set-value-infos ;
: unless-loop ( node quot -- )
[ dup label>> loop?>> [ drop ] ] dip if ; inline
M: #call-recursive propagate-before ( #call-recursive -- )
[
[ ] [ latest-input-infos ] [ recursive-phi-infos ] tri
check-fixed-point
]
[
[
[ ] [ return-infos ] [ node-output-infos ] tri
[ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;
[ check-fixed-point ] [ drop save-return-infos ] 3bi
] unless-loop
] bi ;
M: #call-recursive annotate-node
dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
@ -83,5 +101,11 @@ M: #call-recursive annotate-node
M: #enter-recursive annotate-node
dup out-d>> (annotate-node) ;
M: #return-recursive propagate-before ( #return-recursive -- )
[
[ ] [ latest-input-infos ] [ node-input-infos ] tri
check-fixed-point
] unless-loop ;
M: #return-recursive annotate-node
dup in-d>> (annotate-node) ;

38
basis/compiler/tree/tree.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
sequences words vectors math.intervals classes
accessors combinators stack-checker.state stack-checker.visitor
stack-checker.inlining ;
IN: compiler.tree
@ -42,30 +42,21 @@ TUPLE: #push < node literal out-d ;
TUPLE: #renaming < node ;
TUPLE: #shuffle < #renaming mapping in-d out-d ;
TUPLE: #shuffle < #renaming mapping in-d out-d in-r out-r ;
: #shuffle ( inputs outputs mapping -- node )
: #shuffle ( in-d out-d in-r out-r mapping -- node )
\ #shuffle new
swap >>mapping
swap >>out-r
swap >>in-r
swap >>out-d
swap >>in-d ;
: #data-shuffle ( in-d out-d mapping -- node )
[ f f ] dip #shuffle ; inline
: #drop ( inputs -- node )
{ } { } #shuffle ;
TUPLE: #>r < #renaming in-d out-r ;
: #>r ( inputs outputs -- node )
\ #>r new
swap >>out-r
swap >>in-d ;
TUPLE: #r> < #renaming in-r out-d ;
: #r> ( inputs outputs -- node )
\ #r> new
swap >>out-d
swap >>in-r ;
{ } { } #data-shuffle ;
TUPLE: #terminate < node in-d in-r ;
@ -171,16 +162,9 @@ TUPLE: #alien-callback < #alien-node ;
GENERIC: inputs/outputs ( #renaming -- inputs outputs )
M: #shuffle inputs/outputs mapping>> unzip swap ;
M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
'[ _ at ] map
<effect> ;
: recursive-phi-in ( #enter-recursive -- seq )
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
@ -193,8 +177,8 @@ M: vector #call, #call node, ;
M: vector #push, #push node, ;
M: vector #shuffle, #shuffle node, ;
M: vector #drop, #drop node, ;
M: vector #>r, #>r node, ;
M: vector #r>, #r> node, ;
M: vector #>r, [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
M: vector #r>, [ swap [ f swap ] dip f ] [ swap zip ] 2bi #shuffle, ;
M: vector #return, #return node, ;
M: vector #enter-recursive, #enter-recursive node, ;
M: vector #return-recursive, #return-recursive node, ;

14
basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
View File

@ -42,7 +42,7 @@ M: #push unbox-tuples* ( #push -- nodes )
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
: flatten-values ( values -- values' )
(flatten-values) flatten ;
dup empty? [ (flatten-values) flatten ] unless ;
: prepare-slot-access ( #call -- tuple-values outputs slot-values )
[ in-d>> flatten-values ]
@ -54,7 +54,7 @@ M: #push unbox-tuples* ( #push -- nodes )
] tri ;
: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
[ drop ] [ zip ] 2bi #shuffle ;
[ drop ] [ zip ] 2bi #data-shuffle ;
: unbox-slot-access ( #call -- nodes )
dup out-d>> first unboxed-slot-access? [
@ -77,17 +77,11 @@ M: #copy unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d ;
M: #>r unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-r ;
M: #r> unbox-tuples*
[ flatten-values ] change-in-r
[ flatten-values ] change-out-d ;
M: #shuffle unbox-tuples*
[ flatten-values ] change-in-d
[ flatten-values ] change-out-d
[ flatten-values ] change-in-r
[ flatten-values ] change-out-r
[ unzip [ flatten-values ] bi@ zip ] change-mapping ;
M: #terminate unbox-tuples*

2
basis/cpu/architecture/architecture.factor
View File

@ -50,7 +50,7 @@ HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
HOOK: %dispatch cpu ( src temp -- )
HOOK: %dispatch cpu ( src temp offset -- )
HOOK: %dispatch-label cpu ( word -- )
HOOK: %slot cpu ( dst obj slot tag temp -- )

7
basis/cpu/ppc/bootstrap.factor
View File

@ -57,7 +57,12 @@ big-endian on
[
0 6 LOAD32
4 1 MR
7 6 0 LWZ
1 7 0 STW
] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define
[
0 6 LOAD32
6 MTCTR
BCTR
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define

8
basis/cpu/ppc/ppc.factor
View File

@ -111,10 +111,10 @@ M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp -- )
0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
temp temp src ADD
temp temp 5 cells LWZ
M:: ppc %dispatch ( src temp offset -- )
0 temp LOAD32
4 offset + cells rc-absolute-ppc-2/2 rel-here
temp temp src LWZX
temp MTCTR
BCTR ;

14
basis/cpu/x86/32/32.factor
View File

@ -6,7 +6,7 @@ accessors init combinators command-line cpu.x86.assembler
cpu.x86 cpu.architecture compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.intrinsics ;
compiler.cfg.builder compiler.cfg.intrinsics make ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
@ -26,6 +26,18 @@ M: x86.32 stack-reg ESP ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
M:: x86.32 %dispatch ( src temp offset -- )
! Load jump table base.
src HEX: ffffffff ADD
offset cells rc-absolute-cell rel-here
! Go
src HEX: 7f [+] JMP
! Fix up the displacement above
cell code-alignment
[ 7 + building get dup pop* push ]
[ align-code ]
bi ;
M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;

11
basis/cpu/x86/32/bootstrap.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser ;
cpu.x86.assembler layouts vocabs parser compiler.constants ;
IN: bootstrap.x86
4 \ cell set
@ -19,5 +19,14 @@ IN: bootstrap.x86
: fixnum>slot@ ( -- ) arg0 1 SAR ;
: rex-length ( -- n ) 0 ;
[
arg0 0 [] MOV ! load stack_chain
arg0 [] stack-reg MOV ! save stack pointer
] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
[
(JMP) drop
] rc-relative rt-primitive 1 jit-primitive jit-define
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call

15
basis/cpu/x86/64/64.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
slots splitting assocs combinators cpu.x86.assembler
slots splitting assocs combinators make locals cpu.x86.assembler
cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
@ -24,6 +24,19 @@ M: x86.64 stack-reg RSP ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
M:: x86.64 %dispatch ( src temp offset -- )
! Load jump table base.
temp HEX: ffffffff MOV
offset cells rc-absolute-cell rel-here
! Add jump table base
src temp ADD
src HEX: 7f [+] JMP
! Fix up the displacement above
cell code-alignment
[ 15 + building get dup pop* push ]
[ align-code ]
bi ;
: param-reg-1 int-regs param-regs first ; inline
: param-reg-2 int-regs param-regs second ; inline
: param-reg-3 int-regs param-regs third ; inline

13
basis/cpu/x86/64/bootstrap.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser ;
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
IN: bootstrap.x86
8 \ cell set
@ -16,5 +16,16 @@ IN: bootstrap.x86
: fixnum>slot@ ( -- ) ;
: rex-length ( -- n ) 1 ;
[
arg0 0 MOV ! load stack_chain
arg0 arg0 [] MOV
arg0 [] stack-reg MOV ! save stack pointer
] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
[
arg1 0 MOV ! load XT
arg1 JMP ! go
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
call

6
basis/cpu/x86/bootstrap.factor
View File

@ -44,12 +44,6 @@ big-endian off
ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
[
arg0 0 MOV ! load XT
arg1 stack-reg MOV ! pass callstack pointer as arg 2
arg0 JMP ! go
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
[
(JMP) drop
] rc-relative rt-xt 1 jit-word-jump jit-define

13
basis/cpu/x86/x86.factor
View File

@ -60,19 +60,6 @@ M: x86 %return ( -- ) 0 RET ;
: align-code ( n -- )
0 <repetition> % ;
M:: x86 %dispatch ( src temp -- )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Add jump table base
temp HEX: ffffffff MOV rc-absolute-cell rel-here
src temp ADD
src HEX: 7f [+] JMP
! Fix up the displacement above
cell code-alignment dup bootstrap-cell 8 = 15 9 ? +
building get dup pop* push
align-code ;
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;

7
basis/dlists/dlists-tests.factor
View File

@ -77,3 +77,10 @@ IN: dlists.tests
[ f ] [ <dlist> 3 over push-front 4 over push-back -1 swap deque-member? ] unit-test
[ f ] [ <dlist> 0 swap deque-member? ] unit-test
! Make sure clone does the right thing
[ V{ 2 1 } V{ 2 1 3 } ] [
<dlist> 1 over push-front 2 over push-front
dup clone 3 over push-back
[ dlist>seq ] bi@
] unit-test

8
basis/dlists/dlists.factor
View File

@ -154,6 +154,14 @@ M: dlist clear-deque ( dlist -- )
: dlist-each ( dlist quot -- )
[ obj>> ] prepose dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
[ ] pusher [ dlist-each ] dip ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
M: dlist clone
<dlist> [
[ push-back ] curry dlist-each
] keep ;
INSTANCE: dlist deque

2
basis/editors/emacs/emacs.factor
View File

@ -4,7 +4,7 @@ IN: editors.emacs
: emacsclient ( file line -- )
[
"emacsclient" ,
\ emacsclient get "emacsclient" or ,
"--no-wait" ,
"+" swap number>string append ,
,

1
basis/editors/etexteditor/authors.txt Executable file
View File

@ -0,0 +1 @@
Kibleur Christophe

18
basis/editors/etexteditor/etexteditor.factor Executable file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2008 Kibleur Christophe.
! See http://factorcode.org/license.txt for BSD license.
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 make ;
IN: editors.etexteditor
: etexteditor-path ( -- str )
\ etexteditor-path get-global [
program-files "e\\e.exe" append-path
] unless* ;
: etexteditor ( file line -- )
[
etexteditor-path ,
[ , ] [ "--line" , number>string , ] bi*
] { } make run-detached drop ;
[ etexteditor ] edit-hook set-global

1
basis/editors/etexteditor/summary.txt Executable file
View File

@ -0,0 +1 @@
etexteditor integration

1
basis/editors/etexteditor/tags.txt Executable file
View File

@ -0,0 +1 @@
unportable

170
basis/furnace/actions/actions-docs.factor Normal file
View File

@ -0,0 +1,170 @@
USING: assocs classes help.markup help.syntax io.streams.string
http http.server.dispatchers http.server.responses
furnace.redirection strings multiline ;
IN: furnace.actions
HELP: <action>
{ $values { "action" action } }
{ $description "Creates a new action." } ;
HELP: <chloe-content>
{ $values
{ "path" "a pathname string" }
{ "response" response }
}
{ $description "Creates an HTTP response which serves a Chloe template. See " { $link "html.templates.chloe" } "." } ;
HELP: <page-action>
{ $values { "page" action } }
{ $description "Creates a new action which serves a Chloe template when servicing a GET request." } ;
HELP: action
{ $description "The class of Furnace actions. New instances are created with " { $link <action> } ". New instances of subclasses can be created with " { $link new-action } ". The " { $link page-action } " class is a useful subclass."
$nl
"Action slots are documented in " { $link "furnace.actions.config" } "." } ;
HELP: new-action
{ $values
{ "class" class }
{ "action" action }
}
{ $description "Constructs a subclass of " { $link action } "." } ;
HELP: page-action
{ $description "The class of Chloe page actions. These are actions whose " { $slot "display" } " slot is pre-set to serve the Chloe template stored in the " { $slot "page" } " slot." } ;
HELP: param
{ $values
{ "name" string }
{ "value" string }
}
{ $description "Outputs the value of a query parameter (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
HELP: params
{ $var-description "A variable holding an assoc of query parameters (if the current request is a GET or HEAD request) or POST parameters (if the current request is a POST request)." }
{ $notes "Instead of using this word, it is better to use " { $link validate-params } " and then access parameters via " { $link "html.forms.values" } " words." } ;
HELP: validate-integer-id
{ $description "A utility word which validates an integer parameter named " { $snippet "id" } "." }
{ $examples
{ $code
"<action>"
" ["
" validate-integer-id"
" \"id\" value <person> select-tuple from-object"
" ] >>init"
}
} ;
HELP: validate-params
{ $values
{ "validators" "an association list mapping parameter names to validator quotations" }
}
{ $description "Validates query or POST parameters, depending on the request type, and stores them in " { $link "html.forms.values" } ". The validator quotations can execute " { $link "validators" } "." }
{ $examples
"A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:"
{ $code
<" : validate-todo ( -- )
{
{ "summary" [ v-one-line ] }
{ "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
{ "description" [ v-required ] }
} validate-params ;">
}
} ;
HELP: validation-failed
{ $description "Stops processing the current request and takes action depending on the type of the current request:"
{ $list
{ "For GET or HEAD requests, the client receives a " { $link <400> } " response." }
{ "For POST requests, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." }
}
"This word is called by " { $link validate-params } " and can also be called directly. For more details, see " { $link "furnace.actions.lifecycle" } "." } ;
ARTICLE: "furnace.actions.page.example" "Furnace page action example"
"The " { $vocab-link "webapps.counter" } " vocabulary defines a subclass of " { $link dispatcher } ":"
{ $code "TUPLE: counter-app < dispatcher ;" }
"The " { $snippet "<counter-app>" } " constructor word creates a new instance of the " { $snippet "counter-app" } " class, and adds a " { $link page-action } " instance to the dispatcher. This " { $link page-action } " has its " { $slot "template" } " slot set as follows,"
{ $code "{ counter-app \"counter\" } >>template" }
"This means the action will serve the Chloe template located at " { $snippet "resource:extra/webapps/counter/counter.xml" } " upon receiving a GET request." ;
ARTICLE: "furnace.actions.page" "Furnace page actions"
"Page actions implement the common case of an action that simply serves a Chloe template in response to a GET request."
{ $subsection page-action }
{ $subsection <page-action> }
"When using a page action, instead of setting the " { $slot "display" } " slot, the " { $slot "template" } " slot is set instead. The " { $slot "init" } ", " { $slot "authorize" } ", " { $slot "validate" } " and " { $slot "submit" } " slots can still be set as usual."
$nl
"The " { $slot "template" } " slot of a " { $link page-action } " contains a pair with shape " { $snippet "{ responder name }" } ", where " { $snippet "responder" } " is a responder class, usually a subclass of " { $link dispatcher } ", and " { $snippet "name" } " is the name of a template file, without the " { $snippet ".xml" } " extension, relative to the directory containing the responder's vocabulary source file."
{ $subsection "furnace.actions.page.example" } ;
ARTICLE: "furnace.actions.config" "Furnace action configuration"
"Actions have the following slots:"
{ $table
{ { $slot "rest" } { "A parameter name to map the rest of the URL, after the action name, to. If this is not set, then navigating to a URL where the action is not the last path component will return to the client with an error." } }
{ { $slot "init" } { "A quotation called at the beginning of a GET or HEAD request. Typically this quotation configures " { $link "html.forms" } " and parses query parameters." } }
{ { $slot "authorize" } { "A quotation called at the beginning of a GET, HEAD or POST request. In GET requests, it is called after the " { $slot "init" } " quotation; in POST requests, it is called after the " { $slot "validate" } " quotation. By convention, this quotation performs custom authorization checks which depend on query parameters or POST parameters." } }
{ { $slot "display" } { "A quotation called after the " { $slot "init" } " quotation in a GET request. This quotation must return an HTTP " { $link response } "." } }
{ { $slot "validate" } { "A quotation called at the beginning of a POST request to validate POST parameters." } }
{ { $slot "submit" } { "A quotation called after the " { $slot "validate" } " quotation in a POST request. This quotation must return an HTTP " { $link response } "." } }
}
"At least one of the " { $slot "display" } " and " { $slot "submit" } " slots must be set, otherwise the action will be useless." ;
ARTICLE: "furnace.actions.validation" "Form validation with actions"
"The action code is set up so that the " { $slot "init" } " quotation can validate query parameters, and the " { $slot "validate" } " quotation can validate POST parameters."
$nl
"A word to validate parameters and make them available as HTML form values (see " { $link "html.forms.values" } "); typically this word is invoked from the " { $slot "init" } " and " { $slot "validate" } " quotations:"
{ $subsection validate-params }
"The above word expects an association list mapping parameter names to validator quotations; validator quotations can use the words in the "
"Custom validation logic can invoke a word when validation fails; " { $link validate-params } " invokes this word for you:"
{ $subsection validation-failed }
"If validation fails, no more action code is executed, and the client is redirected back to the originating page, where validation errors can be displayed. Note that validation errors are rendered automatically by the " { $link "html.components" } " words, and in particular, " { $link "html.templates.chloe" } " use these words." ;
ARTICLE: "furnace.actions.lifecycle" "Furnace action lifecycle"
{ $heading "GET request lifecycle" }
"A GET request results in the following sequence of events:"
{ $list
{ "The " { $snippet "init" } " quotation is called." }
{ "The " { $snippet "authorize" } " quotation is called." }
{ "If the GET request was generated as a result of form validation failing during a POST, then the form values entered by the user, along with validation errors, are stored in " { $link "html.forms.values" } "." }
{ "The " { $snippet "display" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack." }
}
"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a GET request, the client receives a " { $link <400> } " error."
{ $heading "HEAD request lifecycle" }
"A HEAD request proceeds exactly like a GET request. The only difference is that the " { $slot "body" } " slot of the " { $link response } " object is never rendered."
{ $heading "POST request lifecycle" }
"A POST request results in the following sequence of events:"
{ $list
{ "The " { $snippet "validate" } " quotation is called." }
{ "The " { $snippet "authorize" } " quotation is called." }
{ "The " { $snippet "submit" } " quotation is called; it is expected to output an HTTP " { $link response } " on the stack. By convention, this response should be a " { $link <redirect> } "." }
}
"Any one of the above steps can perform validation; if " { $link validation-failed } " is called during a POST request, the client is sent back to the page containing the form submission, with current form values and validation errors passed in a " { $link "furnace.conversations" } "." ;
ARTICLE: "furnace.actions.impl" "Furnace actions implementation"
"The following words are used by the action implementation and there is rarely any reason to call them directly:"
{ $subsection new-action }
{ $subsection param }
{ $subsection params } ;
ARTICLE: "furnace.actions" "Furnace actions"
"The " { $vocab-link "furnace.actions" } " vocabulary implements a type of responder, called an " { $emphasis "action" } ", which handles the form validation lifecycle."
$nl
"Other than form validation capability, actions are also often simpler to use than implementing new responders directly, since creating a new class is not required, and the action dispatches on the request type (GET, HEAD, or POST)."
$nl
"The class of actions:"
{ $subsection action }
"Creating a new action:"
{ $subsection <action> }
"Once created, an action needs to be configured; typically the creation and configuration of an action is encapsulated into a single word:"
{ $subsection "furnace.actions.config" }
"Validating forms with actions:"
{ $subsection "furnace.actions.validation" }
"More about the form validation lifecycle:"
{ $subsection "furnace.actions.lifecycle" }
"A convenience class:"
{ $subsection "furnace.actions.page" }
"Low-level features:"
{ $subsection "furnace.actions.impl" } ;
ABOUT: "furnace.actions"

13
basis/furnace/actions/actions.factor
View File

@ -22,18 +22,7 @@ SYMBOL: params
SYMBOL: rest
: render-validation-messages ( -- )
form get errors>>
[
<ul "errors" =class ul>
[ <li> escape-string write </li> ] each
</ul>
] unless-empty ;
CHLOE: validation-messages
drop [ render-validation-messages ] [code] ;
TUPLE: action rest authorize init display validate submit ;
TUPLE: action rest init authorize display validate submit ;
: new-action ( class -- action )
new [ ] >>init [ ] >>validate [ ] >>authorize ; inline

42
basis/furnace/alloy/alloy-docs.factor Normal file
View File

@ -0,0 +1,42 @@
IN: furnace.alloy
USING: help.markup help.syntax db multiline ;
HELP: init-furnace-tables
{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ;
HELP: <alloy>
{ $values { "responder" "a responder" } { "db" db } { "responder'" "an alloy responder" } }
{ $description "Wraps the responder with support for asides, conversations, sessions and database persistence." }
{ $examples
"The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
{ $code
<" : counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- )
<counter-app>
counter-db <alloy>
main-responder set-global
8080 httpd ;">
}
} ;
HELP: start-expiring
{ $values { "db" db } }
{ $description "Starts a timer which expires old session state from the given database." } ;
ARTICLE: "furnace.alloy" "Furnace alloy responder"
"The " { $vocab-link "furnace.alloy" } " vocabulary implements a convenience responder which combines several Furnace features into one easy-to-use wrapper:"
{ $list
{ $link "furnace.asides" }
{ $link "furnace.conversations" }
{ $link "furnace.sessions" }
{ $link "furnace.db" }
}
"A word to wrap a responder in an alloy:"
{ $subsection <alloy> }
"Initializing database tables for asides, conversations and sessions:"
{ $subsection init-furnace-tables }
"Start a timer to expire asides, conversations and sessions:"
{ $subsection start-expiring } ;
ABOUT: "furnace.alloy"

33
basis/furnace/asides/asides-docs.factor Normal file
View File

@ -0,0 +1,33 @@
USING: help.markup help.syntax io.streams.string urls
furnace.redirection http furnace.sessions furnace.db ;
IN: furnace.asides
HELP: <asides>
{ $values
{ "responder" "a responder" }
{ "responder'" asides }
}
{ $description "Creates a new " { $link asides } " responder wrapping an existing responder." } ;
HELP: begin-aside
{ $values { "url" url } }
{ $description "Begins an aside. When the current action returns a " { $link <redirect> } ", the redirect will have query parameters which reference the current page via an opaque handle." } ;
HELP: end-aside
{ $values { "default" url } { "response" response } }
{ $description "Ends an aside. If an aside is currently active, the response redirects the client " } ;
ARTICLE: "furnace.asides" "Furnace asides"
"The " { $vocab-link "furnace.asides" } " vocabulary provides support for sending a user to a page which can then return to the former location."
$nl
"To use asides, wrap your responder in an aside responder:"
{ $subsection <asides> }
"The aside responder must be wrapped inside a session responder (" { $link <sessions> } "), which in turn must be wrapped inside a database persistence responder (" { $link <db-persistence> } "). The " { $vocab-link "furnace.alloy" } " vocabulary combines all of these responders into one."
$nl
"Saving the current page in an aside which propagates through " { $link <redirect> } " responses:"
{ $subsection begin-aside }
"Returning from an aside:"
{ $subsection end-aside }
"Asides are used by " { $vocab-link "furnace.auth.login" } "; when the client requests a protected page, an aside begins and the client is redirected to a login page. Upon a successful login, the aside ends and the client returns to the protected page. If the client directly visits the login page and logs in, there is no current aside, so the client is sent to the default URL passed to " { $link end-aside } ", which in the case of login is the root URL." ;
ABOUT: "furnace.asides"

2
basis/furnace/auth/features/edit-profile/edit-profile.xml
View File

@ -62,7 +62,7 @@
<p>
<button>Update</button>
<t:validation-messages />
<t:validation-errors />
</p>
</t:form>

2
basis/furnace/auth/features/recover-password/recover-3.xml
View File

@ -32,7 +32,7 @@
<p>
<button>Set password</button>
<t:validation-messages />
<t:validation-errors />
</p>
</t:form>

2
basis/furnace/auth/features/registration/register.xml
View File

@ -63,7 +63,7 @@
<p>
<button>Register</button>
<t:validation-messages />
<t:validation-errors />
</p>

2
basis/furnace/auth/login/login.xml
View File

@ -36,7 +36,7 @@
<p>
<button>Log in</button>
<t:validation-messages />
<t:validation-errors />
</p>

27
basis/furnace/boilerplate/boilerplate-docs.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2008 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string ;
IN: furnace.boilerplate
HELP: <boilerplate>
{ $values
{ "responder" null }
{ "boilerplate" null }
}
{ $description "" } ;
HELP: boilerplate
{ $description "" } ;
HELP: wrap-boilerplate?
{ $values
{ "response" null }
{ "?" "a boolean" }
}
{ $description "" } ;
ARTICLE: "furnace.boilerplate" "Furnace boilerplate support"
{ $vocab-link "furnace.boilerplate" }
;
ABOUT: "furnace.boilerplate"

6
basis/furnace/conversations/conversations-docs.factor Normal file
View File

@ -0,0 +1,6 @@
USING: help.markup help.syntax ;
IN: furnace.conversations
ARTICLE: "furnace.conversations" "Furnace conversation scope"
;

16
basis/furnace/db/db-docs.factor Normal file
View File

@ -0,0 +1,16 @@
USING: help.markup help.syntax db http.server ;
IN: furnace.db
HELP: <db-persistence>
{ $values
{ "responder" "a responder" } { "db" db }
{ "responder'" db-persistence }
}
{ $description "Wraps a responder with database persistence support. The responder's " { $link call-responder* } " method will run in a " { $link with-db } " scope." } ;
ARTICLE: "furnace.db" "Furnace database support"
"The " { $vocab-link "furnace.db" } " vocabulary implements a responder which maintains a database connection pool and runs each request in a " { $link with-db } " scope."
{ $subsection <db-persistence> }
"The " { $vocab-link "furnace.alloy" } " vocabulary combines database persistence with several other features." ;
ABOUT: "furnace.db"

189
basis/furnace/furnace-docs.factor Normal file
View File

@ -0,0 +1,189 @@
USING: assocs help.markup help.syntax io.streams.string quotations sequences strings urls ;
IN: furnace
HELP: adjust-redirect-url
{ $values
{ "url" url }
{ "url'" url }
}
{ $description "" } ;
HELP: adjust-url
{ $values
{ "url" url }
{ "url'" url }
}
{ $description "" } ;
HELP: base-path
{ $values
{ "string" string }
{ "pair" null }
}
{ $description "" } ;
HELP: client-state
{ $values
{ "key" null }
{ "value/f" null }
}
{ $description "" } ;
HELP: cookie-client-state
{ $values
{ "key" null } { "request" null }
{ "value/f" null }
}
{ $description "" } ;
HELP: each-responder
{ $values
{ "quot" quotation }
}
{ $description "" } ;
HELP: exit-continuation
{ $description "" } ;
HELP: exit-with
{ $values
{ "value" null }
}
{ $description "" } ;
HELP: hidden-form-field
{ $values
{ "value" null } { "name" null }
}
{ $description "" } ;
HELP: link-attr
{ $values
{ "tag" null } { "responder" null }
}
{ $description "" } ;
HELP: modify-form
{ $values
{ "responder" null }
}
{ $description "" } ;
HELP: modify-query
{ $values
{ "query" null } { "responder" null }
{ "query'" null }
}
{ $description "" } ;
HELP: modify-redirect-query
{ $values
{ "query" null } { "responder" null }
{ "query'" null }
}
{ $description "" } ;
HELP: nested-forms-key
{ $description "" } ;
HELP: nested-responders
{ $values
{ "seq" sequence }
}
{ $description "" } ;
HELP: post-client-state
{ $values
{ "key" null } { "request" null }
{ "value/f" null }
}
{ $description "" } ;
HELP: referrer
{ $values
{ "referrer/f" null }
}
{ $description "" } ;
HELP: request-params
{ $values
{ "request" null }
{ "assoc" assoc }
}
{ $description "" } ;
HELP: resolve-base-path
{ $values
{ "string" string }
{ "string'" string }
}
{ $description "" } ;
HELP: resolve-template-path
{ $values
{ "pair" null }
{ "path" "a pathname string" }
}
{ $description "" } ;
HELP: same-host?
{ $values
{ "url" url }
{ "?" "a boolean" }
}
{ $description "" } ;
HELP: user-agent
{ $values
{ "user-agent" null }
}
{ $description "" } ;
HELP: vocab-path
{ $values
{ "vocab" "a vocabulary specifier" }
{ "path" "a pathname string" }
}
{ $description "" } ;
HELP: with-exit-continuation
{ $values
{ "quot" quotation }
}
{ $description "" } ;
ARTICLE: "furnace" "Furnace web framework"
"The " { $vocab-link "furnace" } " vocabulary implements a full-featured web framework on top of the " { $link "http.server" } ". Some of its features include:"
{ $list
"Session management capable of load-balancing and fail-over"
"Form components and validation"
"Authentication system with basic authentication or login pages, and pluggable authentication backends"
"Easy Atom feed syndication"
"Conversation scope and asides for complex page flow"
}
"Major functionality:"
{ $subsection "furnace.actions" }
{ $subsection "furnace.syndication" }
{ $subsection "furnace.boilerplate" }
{ $subsection "furnace.db" }
"Server-side state:"
{ $subsection "furnace.sessions" }
{ $subsection "furnace.conversations" }
{ $subsection "furnace.asides" }
"HTML components:"
{ $subsection "html.components" }
{ $subsection "html.forms" }
"Content templates:"
{ $subsection "html.templates" }
{ $subsection "html.templates.chloe" }
{ $subsection "html.templates.fhtml" }
"Utilities:"
{ $subsection "furnace.alloy" }
{ $subsection "furnace.json" }
{ $subsection "furnace.redirection" }
{ $subsection "furnace.referrer" } ;
ABOUT: "furnace"

23
basis/furnace/furnace.factor
View File

@ -128,4 +128,27 @@ SYMBOL: exit-continuation
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
USE: vocabs.loader
"furnace.actions" require
"furnace.alloy" require
"furnace.asides" require
"furnace.auth" require
"furnace.auth.basic" require
"furnace.auth.features.deactivate-user" require
"furnace.auth.features.edit-profile" require
"furnace.auth.features.recover-password" require
"furnace.auth.features.registration" require
"furnace.auth.login" require
"furnace.auth.providers.assoc" require
"furnace.auth.providers.db" require
"furnace.auth.providers.null" require
"furnace.boilerplate" require
"furnace.chloe-tags" require
"furnace.conversations" require
"furnace.db" require
"furnace.json" require
"furnace.redirection" require
"furnace.referrer" require
"furnace.scopes" require
"furnace.sessions" require
"furnace.syndication" require

12
basis/furnace/json/json-docs.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel http.server help.markup help.syntax http ;
IN: furnace.json
HELP: <json-content>
{ $values { "body" object } { "response" response } }
{ $description "Creates an HTTP response which serves a serialized JSON object to the client." } ;
ARTICLE: "furnace.json" "Furnace JSON support"
"The " { $vocab-link "furnace.json" } " vocabulary provides a utility word for serving HTTP responses with JSON content."
{ $subsection <json-content> } ;
ABOUT: "furnace.json"

59
basis/furnace/redirection/redirection-docs.factor Normal file
View File

@ -0,0 +1,59 @@
USING: help.markup help.syntax io.streams.string quotations urls
http.server http ;
IN: furnace.redirection
HELP: <redirect-responder>
{ $values { "url" url } { "responder" "a responder" } }
{ $description "Creates a responder which unconditionally redirects the client to the given URL." } ;
HELP: <redirect>
{ $values { "url" url } { "response" response } }
{ $description "Creates a response which redirects the client to the given URL." } ;
HELP: <secure-only> ( responder -- responder' )
{ $values { "responder" "a responder" } { "responder'" "a responder" } }
{ $description "Creates a new responder which ensures that the client is connecting via HTTPS before delegating to the underlying responder. If the client is connecting via HTTP, a redirect is sent instead." } ;
HELP: <secure-redirect>
{ $values
{ "url" url }
{ "response" response }
}
{ $description "Creates a responder which unconditionally redirects the client to the given URL after setting its protocol to HTTPS." }
{ $notes "This word is intended to be used with a relative URL. The client is redirected to the relative URL, but with HTTPS instead of HTTP." } ;
HELP: >secure-url
{ $values
{ "url" url }
{ "url'" url }
}
{ $description "Sets the protocol of a URL to HTTPS." } ;
HELP: if-secure
{ $values
{ "quot" quotation }
{ "response" response }
}
{ $description "Runs a quotation if the current request was made over HTTPS, otherwise returns a redirect to have the client request the current page again via HTTPS." } ;
ARTICLE: "furnace.redirection.secure" "Secure redirection"
"The words in this section help with implementing sites which require SSL/TLS for additional security."
$nl
"Converting a HTTP URL into an HTTPS URL:"
{ $subsection >secure-url }
"Redirecting the client to an HTTPS URL:"
{ $subsection <secure-redirect> }
"Tools for writing responders which require SSL/TLS connections:"
{ $subsection if-secure }
{ $subsection <secure-only> } ;
ARTICLE: "furnace.redirection" "Furnace redirection support"
"The " { $vocab-link "furnace.redirection" } " vocabulary builds additional functionality on top of " { $vocab-link "http.server.redirection" } ", and integrates with various Furnace features such as " { $link "furnace.asides" } " and " { $link "furnace.conversations" } "."
$nl
"A redirection response which takes asides and conversations into account:"
{ $subsection <redirect> }
"A responder which unconditionally redirects the client to another URL:"
{ $subsection <redirect-responder> }
{ $subsection "furnace.redirection.secure" } ;
ABOUT: "furnace.redirection"

15
basis/furnace/referrer/referrer-docs.factor Normal file
View File

@ -0,0 +1,15 @@
USING: help.markup help.syntax io.streams.string ;
IN: furnace.referrer
HELP: <check-form-submissions>
{ $values
{ "responder" "a responder" }
{ "responder'" "a responder" }
}
{ $description "Wraps the responder in a filter responder which ensures that form submissions originate from a page on the same server. Any submissions which do not are sent back with a 403 error." } ;
ARTICLE: "furnace.referrer" "Form submission referrer checking"
"The " { $vocab-link "furnace.referrer" } " implements a simple security measure which can be used to thwart cross-site scripting attacks."
{ $subsection <check-form-submissions> } ;
ABOUT: "furnace.referrer"

149
basis/furnace/sessions/sessions-docs.factor Normal file
View File

@ -0,0 +1,149 @@
! Copyright (C) 2008 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string quotations strings ;
IN: furnace.sessions
HELP: <session-cookie>
{ $values
{ "cookie" null }
}
{ $description "" } ;
HELP: <session>
{ $values
{ "id" null }
{ "session" null }
}
{ $description "" } ;
HELP: <sessions>
{ $values
{ "responder" null }
{ "responder'" null }
}
{ $description "" } ;
HELP: begin-session
{ $values
{ "session" null }
}
{ $description "" } ;
HELP: check-session
{ $values
{ "state/f" null }
{ "state/f" null }
}
{ $description "" } ;
HELP: empty-session
{ $values
{ "session" null }
}
{ $description "" } ;
HELP: existing-session
{ $values
{ "path" "a pathname string" } { "session" null }
{ "response" null }
}
{ $description "" } ;
HELP: get-session
{ $values
{ "id" null }
{ "session" null }
}
{ $description "" } ;
HELP: init-session
{ $values
{ "session" null }
}
{ $description "" } ;
HELP: init-session*
{ $values
{ "responder" null }
}
{ $description "" } ;
HELP: put-session-cookie
{ $values
{ "response" null }
{ "response'" null }
}
{ $description "" } ;
HELP: remote-host
{ $values
{ "string" string }
}
{ $description "" } ;
HELP: request-session
{ $values
{ "session/f" null }
}
{ $description "" } ;
HELP: save-session-after
{ $values
{ "session" null }
}
{ $description "" } ;
HELP: schange
{ $values
{ "key" null } { "quot" quotation }
}
{ $description "" } ;
HELP: session
{ $description "" } ;
HELP: session-changed
{ $description "" } ;
HELP: session-id-key
{ $description "" } ;
HELP: sessions
{ $description "" } ;
HELP: sget
{ $values
{ "key" null }
{ "value" null }
}
{ $description "" } ;
HELP: sset
{ $values
{ "value" null } { "key" null }
}
{ $description "" } ;
HELP: touch-session
{ $values
{ "session" null }
}
{ $description "" } ;
HELP: verify-session
{ $values
{ "session" null }
{ "session" null }
}
{ $description "" } ;
ARTICLE: "furnace.sessions" "Furnace sessions"
{ $vocab-link "furnace.sessions" }
;
ABOUT: "furnace.sessions"

69
basis/furnace/syndication/syndication-docs.factor Normal file
View File

@ -0,0 +1,69 @@
! Copyright (C) 2008 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string kernel sequences strings urls ;
IN: furnace.syndication
HELP: <feed-action>
{ $values
{ "action" null }
}
{ $description "" } ;
HELP: <feed-content>
{ $values
{ "body" null }
{ "response" null }
}
{ $description "" } ;
HELP: >entry
{ $values
{ "object" object }
{ "entry" null }
}
{ $description "" } ;
HELP: feed-action
{ $description "" } ;
HELP: feed-entry-date
{ $values
{ "object" object }
{ "timestamp" null }
}
{ $description "" } ;
HELP: feed-entry-description
{ $values
{ "object" object }
{ "description" null }
}
{ $description "" } ;
HELP: feed-entry-title
{ $values
{ "object" object }
{ "string" string }
}
{ $description "" } ;
HELP: feed-entry-url
{ $values
{ "object" object }
{ "url" url }
}
{ $description "" } ;
HELP: process-entries
{ $values
{ "seq" sequence }
{ "seq'" sequence }
}
{ $description "" } ;
ARTICLE: "furnace.syndication" "Furnace Atom syndication support"
{ $vocab-link "furnace.syndication" }
;
ABOUT: "furnace.syndication"

0
core/grouping/authors.txt → basis/grouping/authors.txt
View File

0
core/grouping/grouping-docs.factor → basis/grouping/grouping-docs.factor
View File

0
core/grouping/grouping-tests.factor → basis/grouping/grouping-tests.factor
View File

74
core/grouping/grouping.factor → basis/grouping/grouping.factor
View File

@ -1,10 +1,12 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
accessors ;
sequences.private accessors ;
IN: grouping
TUPLE: abstract-groups { seq read-only } { n read-only } ;
<PRIVATE
TUPLE: chunking-seq { seq read-only } { n read-only } ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
@ -13,55 +15,73 @@ TUPLE: abstract-groups { seq read-only } { n read-only } ;
GENERIC: group@ ( n groups -- from to seq )
M: abstract-groups nth group@ subseq ;
M: chunking-seq set-nth group@ <slice> 0 swap copy ;
M: abstract-groups set-nth group@ <slice> 0 swap copy ;
M: chunking-seq like drop { } like ;
M: abstract-groups like drop { } like ;
INSTANCE: chunking-seq sequence
INSTANCE: abstract-groups sequence
MIXIN: subseq-chunking
M: subseq-chunking nth group@ subseq ;
MIXIN: slice-chunking
M: slice-chunking nth group@ <slice> ;
M: slice-chunking nth-unsafe group@ slice boa ;
TUPLE: abstract-groups < chunking-seq ;
M: abstract-groups length
[ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
M: abstract-groups set-length
[ n>> * ] [ seq>> ] bi set-length ;
M: abstract-groups group@
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length
[ seq>> length ] [ n>> ] bi - 1+ ;
M: abstract-clumps set-length
[ n>> + 1- ] [ seq>> ] bi set-length ;
M: abstract-clumps group@
[ n>> over + ] [ seq>> ] bi ;
PRIVATE>
TUPLE: groups < abstract-groups ;
: <groups> ( seq n -- groups )
groups new-groups ; inline
M: groups length
[ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
INSTANCE: groups subseq-chunking
M: groups set-length
[ n>> * ] [ seq>> ] bi set-length ;
M: groups group@
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
TUPLE: sliced-groups < groups ;
TUPLE: sliced-groups < abstract-groups ;
: <sliced-groups> ( seq n -- groups )
sliced-groups new-groups ; inline
M: sliced-groups nth group@ <slice> ;
INSTANCE: sliced-groups slice-chunking
TUPLE: clumps < abstract-groups ;
TUPLE: clumps < abstract-clumps ;
: <clumps> ( seq n -- clumps )
clumps new-groups ; inline
M: clumps length
[ seq>> length ] [ n>> ] bi - 1+ ;
INSTANCE: clumps subseq-chunking
M: clumps set-length
[ n>> + 1- ] [ seq>> ] bi set-length ;
M: clumps group@
[ n>> over + ] [ seq>> ] bi ;
TUPLE: sliced-clumps < clumps ;
TUPLE: sliced-clumps < abstract-clumps ;
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline
M: sliced-clumps nth group@ <slice> ;
INSTANCE: sliced-clumps slice-chunking
: group ( seq n -- array ) <groups> { } like ;

0
core/grouping/summary.txt → basis/grouping/summary.txt
View File

0
core/grouping/tags.txt → basis/grouping/tags.txt
View File

2
basis/heaps/heaps.factor
View File

@ -62,7 +62,7 @@ M: heap heap-size ( heap -- n )
: data-set-nth ( entry n heap -- )
>r [ >>index drop ] 2keep r>
data>> set-nth-unsafe ;
data>> set-nth-unsafe ; inline
: data-push ( entry heap -- n )
dup heap-size [

6
basis/help/handbook/handbook.factor
View File

@ -166,16 +166,16 @@ ARTICLE: "io" "Input and output"
{ $heading "Encodings" }
{ $subsection "encodings-introduction" }
{ $subsection "io.encodings" }
"Wrapper streams:"
{ $heading "Wrapper streams" }
{ $subsection "io.streams.duplex" }
{ $subsection "io.streams.plain" }
{ $subsection "io.streams.string" }
{ $subsection "io.streams.byte-array" }
"Utilities:"
{ $heading "Utilities" }
{ $subsection "stream-binary" }
{ $subsection "styles" }
{ $subsection "checksums" }
"Implementation:"
{ $heading "Implementation" }
{ $subsection "io.streams.c" }
{ $subsection "io.ports" }
{ $see-also "destructors" } ;

49
basis/help/tutorial/tutorial.factor
View File

@ -1,29 +1,24 @@
USING: help.markup help.syntax ui.commands ui.operations
ui.tools.search ui.tools.workspace editors vocabs.loader
kernel sequences prettyprint tools.test tools.vocabs strings
unicode.categories unicode.case ;
unicode.categories unicode.case ui.tools.browser ;
IN: help.tutorial
ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
"Factor source code is organized into " { $link "vocabularies" } ". Before we can write our first program, we must create a vocabulary for it."
$nl
"Start by asking Factor for the path to your ``work'' directory, where you will place your own code:"
"Start by loading the scaffold tool:"
{ $code "USE: tools.scaffold" }
"Then, ask the scaffold tool to create a new vocabulary named " { $snippet "palindrome" } ":"
{ $code "\"resource:work\" \"palindrome\" scaffold-vocab" }
"If you look at the output, you will see that a few files were created in your ``work'' directory. The following phrase will print the full path of your work directory:"
{ $code "\"work\" resource-path ." }
"Open the work directory in your file manager, and create a subdirectory named " { $snippet "palindrome" } ". Inside this directory, create a file named " { $snippet "palindrome.factor" } " using your favorite text editor. Leave the file empty for now."
"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". We will be editing this file."
$nl
"Inside the Factor listener, type"
{ $code "USE: palindrome" }
"The source file should now load. Since it is empty, it does nothing. If you get an error message, make sure you created the directory and the file in the right place and gave them the right names."
$nl
"Now, we will start filling out this source file. Go back to your editor, and type:"
{ $code
"! Copyright (C) 2008 <your name here>"
"! See http://factorcode.org/license.txt for BSD license."
}
"This is the standard header for Factor source files; it consists of two " { $link "syntax-comments" } "."
$nl
"Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
{ $code "IN: palindrome" }
"We will add new definitions after the " { $link POSTPONE: IN: } " form."
$nl
"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
ARTICLE: "first-program-logic" "Writing some logic in your first program"
@ -43,20 +38,16 @@ $nl
$nl
"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
$nl
"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary by entering the following in the listener:"
{ $code "\\ dup see" }
"This shows the definition of " { $link dup } ", along with an " { $link POSTPONE: IN: } " form."
"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-follow } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary."
$nl
"Now, add the following at the start of the source file:"
"So now, add the following at the start of the source file:"
{ $code "USING: kernel ;" }
"Next, find out what vocabulary " { $link reverse } " lives in:"
{ $code "\\ reverse see" }
"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the workspace listener's input area, and press " { $operation com-follow } "."
$nl
"It lives in the " { $vocab-link "sequences" } " vocabulary, so we add that to the search path:"
{ $code "USING: kernel sequences ;" }
"Finally, check what vocabulary " { $link = } " lives in:"
{ $code "\\ = see" }
"It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
"Finally, check what vocabulary " { $link = } " lives in, and confirm that it's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
$nl
"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
ARTICLE: "first-program-test" "Testing your first program"
@ -81,9 +72,9 @@ $nl
{ $code "." }
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
$nl
"Create a file named " { $snippet "palindrome-tests.factor" } " in the same directory as " { $snippet "palindrome.factor" } ". Now, we can run unit tests from the listener:"
{ $code "\"palindrome\" test" }
"We will add some unit tests corresponding to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
$nl
"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
$nl
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code
@ -145,7 +136,7 @@ $nl
ARTICLE: "first-program" "Your first program"
"In this tutorial, we will write a simple Factor program which prompts the user to enter a word, and tests if it is a palindrome (that is, the word is spelled the same backwards and forwards)."
$nl
"In this tutorial, you will learn about basic Factor development tools, as well as application deployment."
"In this tutorial, you will learn about basic Factor development tools. You may want to open a second workspace window by pressing " { $command workspace "workflow" workspace-window } "; this will allow you to read this tutorial and browse other documentation at the same time."
{ $subsection "first-program-start" }
{ $subsection "first-program-logic" }
{ $subsection "first-program-test" }

8
basis/html/forms/forms-docs.factor
View File

@ -85,6 +85,14 @@ HELP: validate-values
{ $values { "assoc" assoc } { "validators" "an assoc mapping value names to quotations" } }
{ $description "Validates values in the assoc by looking up the corresponding validation quotation, and storing the results in named values of the current form." } ;
HELP: validation-error
{ $values { "message" string } }
{ $description "Reports a validation error not associated with a specific form field." }
{ $notes "Such errors can be rendered by calling the " { $link render-validation-errors } " word." } ;
HELP: render-validation-errors
{ $description "Renders any validation errors reported by calls to the " { $link validation-error } " word." } ;
ARTICLE: "html.forms.forms" "HTML form infrastructure"
"The below words are used to implement the " { $vocab-link "furnace.actions" } " vocabulary. Calling them directly is rarely necessary."
$nl

13
basis/html/forms/forms.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables
mirrors math fry sequences words continuations ;
USING: kernel accessors strings namespaces assocs hashtables io
mirrors math fry sequences words continuations html.elements
xml.entities ;
IN: html.forms
TUPLE: form errors values validation-failed ;
@ -104,3 +105,11 @@ C: <validation-error> validation-error
: validate-values ( assoc validators -- )
swap '[ [ dup _ at ] dip validate-value ] assoc-each ;
: render-validation-errors ( -- )
form get errors>>
[
<ul "errors" =class ul>
[ <li> escape-string write </li> ] each
</ul>
] unless-empty ;

3
basis/html/templates/chloe/chloe-docs.factor
View File

@ -154,6 +154,9 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
"</t:button>"
}
} }
{ { $snippet "t:validation-errors" } {
"Renders validation errors in the current form which are not associated with any field. Such errors are reported by invoking " { $link validation-error } "."
} }
} ;
ARTICLE: "html.templates.chloe.tags" "Standard Chloe tags"

3
basis/html/templates/chloe/chloe.factor
View File

@ -65,6 +65,9 @@ CHLOE: comment drop ;
CHLOE: call-next-template
drop reset-buffer \ call-next-template , ;
CHLOE: validation-errors
drop [ render-validation-errors ] [code] ;
: attr>word ( value -- word/f )
":" split1 swap lookup ;

3
basis/io/encodings/string/string-docs.factor
View File

@ -4,7 +4,8 @@ USING: help.markup help.syntax byte-arrays strings ;
IN: io.encodings.string
ARTICLE: "io.encodings.string" "Encoding and decoding strings"
"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:"
"Strings can be encoded or decoded to and from byte arrays through an encoding by passing "
{ $link "encodings-descriptors" } " to the following words:"
{ $subsection encode }
{ $subsection decode } ;

0
extra/hexdump/authors.txt → basis/io/files/listing/authors.txt
View File

17
basis/io/files/listing/listing-docs.factor Normal file
View File

@ -0,0 +1,17 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string strings ;
IN: io.files.listing
HELP: directory.
{ $values
{ "path" "a pathname string" }
}
{ $description "Prints information about all files in a directory to the output stream in a cross-platform way similar to the Unix " { $snippet "ls" } " command." } ;
ARTICLE: "io.files.listing" "Listing files"
"The " { $vocab-link "io.files.listing" } " vocabulary implements directory file listing in a cross-platform way." $nl
"Listing a directory:"
{ $subsection directory. } ;
ABOUT: "io.files.listing"

6
basis/io/files/listing/listing-tests.factor Normal file
View File

@ -0,0 +1,6 @@
! Copyright (C) 2008 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test io.files.listing strings kernel ;
IN: io.files.listing.tests
[ ] [ "" directory. ] unit-test

39
basis/io/files/listing/listing.factor Executable file
View File

@ -0,0 +1,39 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators io io.files kernel
math.parser sequences system vocabs.loader calendar ;
IN: io.files.listing
<PRIVATE
: ls-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
: ls-timestamp ( timestamp -- string )
[ month>> month-abbreviation ]
[ day>> number>string 2 CHAR: \s pad-left ]
[
dup year>> dup now year>> =
[ drop ls-time ] [ nip number>string ] if
5 CHAR: \s pad-left
] tri 3array " " join ;
: read>string ( ? -- string ) "r" "-" ? ; inline
: write>string ( ? -- string ) "w" "-" ? ; inline
: execute>string ( ? -- string ) "x" "-" ? ; inline
HOOK: (directory.) os ( path -- lines )
PRIVATE>
: directory. ( path -- )
[ (directory.) ] with-directory-files [ print ] each ;
{
{ [ os unix? ] [ "io.files.listing.unix" ] }
{ [ os windows? ] [ "io.files.listing.windows" ] }
} cond require

1
basis/io/files/listing/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/io/files/listing/unix/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/io/files/listing/unix/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

48
basis/io/files/listing/unix/unix.factor Executable file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel system unicode.case
io.unix.files io.files.listing generalizations strings
arrays sequences io.files math.parser unix.groups unix.users
io.files.listing.private ;
IN: io.files.listing.unix
<PRIVATE
: unix-execute>string ( str bools -- str' )
swap {
{ { t t } [ >lower ] }
{ { t f } [ >upper ] }
{ { f t } [ drop "x" ] }
[ 2drop "-" ]
} case ;
: permissions-string ( permissions -- str )
{
[ type>> file-type>ch 1string ]
[ user-read? read>string ]
[ user-write? write>string ]
[ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
[ group-read? read>string ]
[ group-write? write>string ]
[ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
[ other-read? read>string ]
[ other-write? write>string ]
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave 10 narray concat ;
M: unix (directory.) ( path -- lines )
[ [
[
dup file-info
{
[ permissions-string ]
[ nlink>> number>string 3 CHAR: \s pad-left ]
! [ uid>> ]
! [ gid>> ]
[ size>> number>string 15 CHAR: \s pad-left ]
[ modified>> ls-timestamp ]
} cleave 4 narray swap suffix " " join
] map
] with-group-cache ] with-user-cache ;
PRIVATE>

1
basis/io/files/listing/windows/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/io/files/listing/windows/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

25
basis/io/files/listing/windows/windows.factor Executable file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar.format combinators io.files
kernel math.parser sequences splitting system io.files.listing
generalizations io.files.listing.private ;
IN: io.files.listing.windows
<PRIVATE
: directory-or-size ( file-info -- str )
dup directory? [
drop "<DIR>" 20 CHAR: \s pad-right
] [
size>> number>string 20 CHAR: \s pad-left
] if ;
M: windows (directory.) ( entries -- lines )
[
dup file-info {
[ modified>> timestamp>ymdhms ]
[ directory-or-size ]
} cleave 2 narray swap suffix " " join
] map ;
PRIVATE>

9
basis/io/servers/connection/connection-docs.factor
View File

@ -45,15 +45,20 @@ ARTICLE: "server-config-handler" "Client handler quotation"
$nl
"The two methods are equivalent, representing a functional versus an object-oriented approach to the problem." ;
ARTICLE: "server-examples" "Threaded server examples"
"The " { $vocab-link "time-server" } " vocabulary implements a simple threaded server which sends the current time to the client. The " { $vocab-link "concurrency.distributed" } ", " { $vocab-link "ftp.server" } ", and " { $vocab-link "http.server" } " vocabularies demonstrate more complex usage of the threaded server library." ;
ARTICLE: "io.servers.connection" "Threaded servers"
"The " { $vocab-link "io.servers.connection" } " vocabulary implements a generic server abstraction for " { $link "network-connection" } ". A set of threads listen for connections, and additional threads are spawned for each client connection. In addition to this basic functionality, it provides some advanced features such as logging, connection limits and secure socket support."
{ $subsection threaded-server }
{ $subsection "server-config" }
{ $subsection "server-examples" }
"Creating threaded servers with client handler quotations:"
{ $subsection <threaded-server> }
"Client handlers can also be implemented by subclassing a threaded server; see " { $link "server-config-handler" } " for details:"
{ $subsection threaded-server }
{ $subsection new-threaded-server }
{ $subsection handle-client* }
"The server must be configured before it can be started."
{ $subsection "server-config" }
"Starting the server:"
{ $subsection start-server }
{ $subsection start-server* }

24
basis/io/unix/files/files.factor
View File

@ -172,6 +172,30 @@ M: unix (directory-entries) ( path -- seq )
PRIVATE>
: ch>file-type ( ch -- type )
{
{ CHAR: b [ +block-device+ ] }
{ CHAR: c [ +character-device+ ] }
{ CHAR: d [ +directory+ ] }
{ CHAR: l [ +symbolic-link+ ] }
{ CHAR: s [ +socket+ ] }
{ CHAR: p [ +fifo+ ] }
{ CHAR: - [ +regular-file+ ] }
[ drop +unknown+ ]
} case ;
: file-type>ch ( type -- string )
{
{ +block-device+ [ CHAR: b ] }
{ +character-device+ [ CHAR: c ] }
{ +directory+ [ CHAR: d ] }
{ +symbolic-link+ [ CHAR: l ] }
{ +socket+ [ CHAR: s ] }
{ +fifo+ [ CHAR: p ] }
{ +regular-file+ [ CHAR: - ] }
[ drop CHAR: - ]
} case ;
: UID OCT: 0004000 ; inline
: GID OCT: 0002000 ; inline
: STICKY OCT: 0001000 ; inline

71
basis/io/windows/files/files.factor
View File

@ -149,35 +149,39 @@ SYMBOLS: +read-only+ +hidden+ +system+
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +encrypted+ ;
: win32-file-attribute ( n attr symbol -- n )
>r dupd mask? r> swap [ , ] [ drop ] if ;
TUPLE: windows-file-info < file-info attributes ;
: win32-file-attribute ( n attr symbol -- )
rot mask? [ , ] [ drop ] if ;
: win32-file-attributes ( n -- seq )
[
FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute
FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute
FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute
FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute
FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute
FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute
FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute
FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute
FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute
FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute
FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute
FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute
FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute
FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute
drop
{
[ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
[ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
[ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
[ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
[ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
[ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
[ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
[ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
[ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
[ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
[ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
[ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
[ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
[ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
} cleave
] { } make ;
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ file-info new ] dip
[ \ windows-file-info new ] dip
{
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
[
[ WIN32_FIND_DATA-nFileSizeLow ]
[ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
@ -196,9 +200,10 @@ SYMBOLS: +read-only+ +hidden+ +system+
] keep ;
: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
[ \ file-info new ] dip
[ \ windows-file-info new ] dip
{
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
[
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
[ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
@ -276,18 +281,31 @@ M: winnt file-system-info ( path -- file-system-info )
swap >>type
swap >>mount-point ;
: volume>paths ( string -- array )
16384 "ushort" <c-array> tuck dup length
0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
win32-error-string throw
] [
*uint "ushort" heap-size * head
utf16n alien>string CHAR: \0 split
] if ;
: find-first-volume ( -- string handle )
MAX_PATH 1+ <byte-array> dup length
dupd
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
: find-next-volume ( handle -- string )
: find-next-volume ( handle -- string/f )
MAX_PATH 1+ <byte-array> dup length
[ FindNextVolume win32-error=0/f ] 2keep drop
utf16n alien>string ;
over [ FindNextVolume ] dip swap 0 = [
GetLastError ERROR_NO_MORE_FILES =
[ drop f ] [ win32-error ] if
] [
utf16n alien>string
] if ;
: mounted ( -- array )
: find-volumes ( -- array )
find-first-volume
[
'[
@ -298,6 +316,13 @@ M: winnt file-system-info ( path -- file-system-info )
]
] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
M: winnt file-systems ( -- array )
find-volumes [ volume>paths ] map
concat [
[ file-system-info ]
[ drop winnt-file-system-info new swap >>mount-point ] recover
] map ;
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-path open-existing &dispose handle>>

2
basis/linked-assocs/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
James Cash

23
basis/linked-assocs/linked-assocs-docs.factor Normal file
View File

@ -0,0 +1,23 @@
IN: linked-assocs
USING: help.markup help.syntax assocs ;
HELP: linked-assoc
{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assoc with a dlist. The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
HELP: <linked-assoc>
{ $values { "exemplar" "an exemplar assoc" } { "assoc" linked-assoc } }
{ $description "Creates an empty linked assoc backed by a new instance of the same type as the exemplar." } ;
HELP: <linked-hash>
{ $values { "assoc" linked-assoc } }
{ $description "Creates an empty linked assoc backed by a hashtable." } ;
ARTICLE: "linked-assocs" "Linked assocs"
"A " { $emphasis "linked assoc" } " is an assoc which combines an underlying assoc with a dlist to form a structure which has the insertion and retrieval characteristics of the underlying assoc (typically a hashtable), but with the ability to get the entries in insertion order by calling " { $link >alist } "."
$nl
"Linked assocs are implemented in the " { $vocab-link "linked-assocs" } " vocabulary."
{ $subsection linked-assoc }
{ $subsection <linked-hash> }
{ $subsection <linked-assoc> } ;
ABOUT: "linked-assocs"

Some files were not shown because too many files have changed in this diff Show More