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-26 14:58:40 -08:00
parent cf6fc05527 c7d86ebd55
commit ce4454c223
130 changed files with 1541 additions and 1297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/alien/c-types/c-types-tests.factor
View File

@ -56,3 +56,7 @@ TYPEDEF: uchar* MyLPBYTE
] must-fail
[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
os windows? cpu x86.64? and [
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
] when

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

@ -124,10 +124,10 @@ SYMBOL: jit-primitive-word
SYMBOL: jit-primitive
SYMBOL: jit-word-jump
SYMBOL: jit-word-call
SYMBOL: jit-push-literal
SYMBOL: jit-push-immediate
SYMBOL: jit-if-word
SYMBOL: jit-if-jump
SYMBOL: jit-if-1
SYMBOL: jit-if-2
SYMBOL: jit-dispatch-word
SYMBOL: jit-dispatch
SYMBOL: jit-dip-word
@ -155,9 +155,9 @@ SYMBOL: undefined-quot
{ jit-primitive 25 }
{ jit-word-jump 26 }
{ jit-word-call 27 }
{ jit-push-literal 28 }
{ jit-if-word 29 }
{ jit-if-jump 30 }
{ jit-if-word 28 }
{ jit-if-1 29 }
{ jit-if-2 30 }
{ jit-dispatch-word 31 }
{ jit-dispatch 32 }
{ jit-epilog 33 }
@ -469,10 +469,10 @@ M: quotation '
jit-primitive
jit-word-jump
jit-word-call
jit-push-literal
jit-push-immediate
jit-if-word
jit-if-jump
jit-if-1
jit-if-2
jit-dispatch-word
jit-dispatch
jit-dip-word

10
basis/bootstrap/stage2.factor
View File

@ -32,8 +32,8 @@ SYMBOL: bootstrap-time
: count-words ( pred -- )
all-words swap count number>string write ;
: print-time ( us -- )
1000000 /i
: print-time ( ms -- )
1000 /i
60 /mod swap
number>string write
" minutes and " write number>string write " seconds." print ;
@ -52,7 +52,7 @@ SYMBOL: bootstrap-time
[
! We time bootstrap
micros
millis
default-image-name "output-image" set-global
@ -77,7 +77,7 @@ SYMBOL: bootstrap-time
[
load-components
micros over - core-bootstrap-time set-global
millis over - core-bootstrap-time set-global
run-bootstrap-init
] with-compiler-errors
@ -100,7 +100,7 @@ SYMBOL: bootstrap-time
] [ print-error 1 exit ] recover
] set-boot-quot
micros swap - bootstrap-time set-global
millis swap - bootstrap-time set-global
print-report
"output-image" get save-image-and-exit

2
basis/checksums/common/common.factor
View File

@ -18,4 +18,4 @@ SYMBOL: bytes-read
] "" make 64 group ;
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
[ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline

2
basis/checksums/md5/md5.factor
View File

@ -14,7 +14,7 @@ IN: checksums.md5
SYMBOLS: a b c d old-a old-b old-c old-d ;
: T ( N -- Y )
sin abs 4294967296 * >bignum ; foldable
sin abs 4294967296 * >integer ; foldable
: initialize-md5 ( -- )
0 bytes-read set

21
basis/combinators/short-circuit/short-circuit.factor
View File

@ -3,9 +3,13 @@ locals generalizations macros fry ;
IN: combinators.short-circuit
MACRO:: n&& ( quots n -- quot )
[ f ]
quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
[ n nnip ] suffix 1array
[ f ] quots [| q |
n
[ q '[ drop _ ndup @ dup not ] ]
[ '[ drop _ ndrop f ] ]
bi 2array
] map
n '[ _ nnip ] suffix 1array
[ cond ] 3append ;
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
@ -14,10 +18,13 @@ MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
MACRO:: n|| ( quots n -- quot )
[ f ]
quots
[| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
{ [ drop n ndrop t ] [ f ] } suffix 1array
[ f ] quots [| q |
n
[ q '[ drop _ ndup @ dup ] ]
[ '[ _ nnip ] ]
bi 2array
] map
n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
[ cond ] 3append ;
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;

7
basis/compiler/cfg/def-use/def-use.factor
View File

@ -12,9 +12,12 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp defs-vregs dst/tmp-vregs ;
M: ##allot defs-vregs dst/tmp-vregs ;
M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: ##slot defs-vregs dst/tmp-vregs ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: ##string-nth defs-vregs dst/tmp-vregs ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;

6
basis/compiler/cfg/hats/hats.factor
View File

@ -65,9 +65,9 @@ IN: compiler.cfg.hats
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline

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

@ -198,11 +198,11 @@ TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ;
INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
INSN: ##compare < ##binary cc ;
INSN: ##compare-imm < ##binary-imm cc ;
INSN: ##compare < ##binary cc temp ;
INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc ;
INSN: ##compare-float < ##binary cc temp ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;

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

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
math fry
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
@ -63,7 +64,7 @@ M: ##compare-imm-branch rewrite-tagged-comparison
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
f \ ##compare-imm boa ;
i f \ ##compare-imm boa ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@ -78,7 +79,7 @@ M: ##compare-imm-branch rewrite
[ dst>> ]
[ src2>> ]
[ src1>> vreg>vn vn>constant ] tri
cc= f \ ##compare-imm boa ;
cc= f i \ ##compare-imm boa ;
M: ##compare rewrite
dup flip-comparison? [
@ -95,9 +96,9 @@ M: ##compare rewrite
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
{ \ ##compare [ >compare-expr< i f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;

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

@ -1,6 +1,17 @@
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test kernel math ;
compiler.cfg.registers cpu.architecture tools.test kernel math
combinators.short-circuit accessors sequences ;
: trim-temps ( insns -- insns )
[
dup {
[ ##compare? ]
[ ##compare-imm? ]
[ ##compare-float? ]
} 1|| [ f >>temp ] when
] map ;
[
{
T{ ##peek f V int-regs 45 D 1 }
@ -82,7 +93,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
} value-numbering trim-temps
] unit-test
[
@ -100,7 +111,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
} value-numbering trim-temps
] unit-test
[
@ -122,7 +133,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
T{ ##replace f V int-regs 14 D 0 }
} value-numbering
} value-numbering trim-temps
] unit-test
[
@ -138,5 +149,5 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
} value-numbering
} value-numbering trim-temps
] unit-test

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

@ -491,9 +491,10 @@ M: _label generate-insn
M: _branch generate-insn
label>> lookup-label %jump-label ;
: >compare< ( insn -- label cc src1 src2 )
: >compare< ( insn -- dst temp cc src1 src2 )
{
[ dst>> register ]
[ temp>> register ]
[ cc>> ]
[ src1>> register ]
[ src2>> ?register ]

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

@ -66,8 +66,8 @@ SYMBOL: literal-table
: rel-primitive ( word class -- )
>r def>> first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
: rel-immediate ( literal class -- )
>r add-literal r> rt-immediate rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;

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

@ -39,13 +39,12 @@ IN: compiler.constants
! Relocation types
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-literal 2 ; inline
: rt-dispatch 3 ; inline
: rt-xt 4 ; inline
: rt-here 5 ; inline
: rt-label 6 ; inline
: rt-immediate 7 ; inline
: rt-stack-chain 8 ; inline
: rt-dispatch 2 ; inline
: rt-xt 3 ; inline
: rt-here 4 ; inline
: rt-label 5 ; inline
: rt-immediate 6 ; inline
: rt-stack-chain 7 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]

15
basis/compiler/tests/codegen.factor
View File

@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors float-arrays ;
combinators vectors float-arrays grouping make ;
IN: compiler.tests
! Originally, this file did black box testing of templating
@ -241,3 +241,16 @@ TUPLE: id obj ;
[ "a" ] [ 1 test-2 ] unit-test
[ "b" ] [ 2 test-2 ] unit-test
! I accidentally fixnum/i-fast on PowerPC
[ { { 1 2 } { 3 4 } } ] [
{ 1 2 3 4 }
[
[ { array } declare 2 <groups> [ , ] each ] compile-call
] { } make
] unit-test
[ 2 ] [
{ 1 2 3 4 }
[ { array } declare 2 <groups> length ] compile-call
] unit-test

5
basis/compiler/tests/intrinsics.factor
View File

@ -160,6 +160,11 @@ IN: compiler.tests
[ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
[ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test
[ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test
[ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test
[ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
[ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test

2
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -85,6 +85,8 @@ DEFER: (flat-length)
: word-flat-length ( word -- n )
{
! special-case
{ [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! recursive and inline

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

@ -119,9 +119,9 @@ HOOK: %gc cpu ( -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
HOOK: %compare cpu ( dst cc src1 src2 -- )
HOOK: %compare-imm cpu ( dst cc src1 src2 -- )
HOOK: %compare-float cpu ( dst cc src1 src2 -- )
HOOK: %compare cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-float cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )

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

@ -24,7 +24,6 @@ big-endian on
[
0 6 LOAD32
6 dup 0 LWZ
11 6 profile-count-offset LWZ
11 11 1 tag-fixnum ADDI
11 6 profile-count-offset STW
@ -32,7 +31,7 @@ big-endian on
11 11 compiled-header-size ADDI
11 MTCTR
BCTR
] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define
] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define
[
0 6 LOAD32
@ -44,12 +43,6 @@ big-endian on
0 1 lr-save stack-frame + STW
] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
[
0 6 LOAD32
6 dup 0 LWZ
6 ds-reg 4 STWU
] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define
[
0 6 LOAD32
6 ds-reg 4 STWU
@ -71,40 +64,32 @@ big-endian on
[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
0 3 \ f tag-number CMPI
2 BEQ
0 B
] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define
[
0 B
] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define
: jit-jump-quot ( -- )
4 3 quot-xt-offset LWZ
4 MTCTR
BCTR ;
: jit-call-quot ( -- )
4 3 quot-xt-offset LWZ
4 MTLR
BLRL ;
[
0 3 LOAD32
6 ds-reg 0 LWZ
0 6 \ f tag-number CMPI
2 BNE
3 3 4 ADDI
3 3 0 LWZ
ds-reg dup 4 SUBI
jit-jump-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
[
0 3 LOAD32
3 3 0 LWZ
6 ds-reg 0 LWZ
6 6 1 SRAWI
3 3 6 ADD
3 3 array-start-offset LWZ
ds-reg dup 4 SUBI
jit-jump-quot
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
! These should not clobber r3 since we store a quotation in there
! in jit-dip
] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define
: jit->r ( -- )
4 ds-reg 0 LWZ
@ -130,9 +115,9 @@ big-endian on
6 rs-reg -8 STW ;
: jit-r> ( -- )
4 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 rs-reg 4 STWU ;
4 rs-reg 0 LWZ
rs-reg dup 4 SUBI
4 ds-reg 4 STWU ;
: jit-2r> ( -- )
4 rs-reg 0 LWZ
@ -152,30 +137,23 @@ big-endian on
5 ds-reg -4 STW
6 ds-reg -8 STW ;
: prepare-dip ( -- )
0 3 LOAD32
3 3 0 LWZ ;
[
prepare-dip
jit->r
jit-call-quot
0 BL
jit-r>
] rc-absolute-ppc-2/2 rt-literal 1 jit-dip jit-define
] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define
[
prepare-dip
jit-2>r
jit-call-quot
0 BL
jit-2r>
] rc-absolute-ppc-2/2 rt-literal 1 jit-2dip jit-define
] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define
[
prepare-dip
jit-3>r
jit-call-quot
0 BL
jit-3r>
] rc-absolute-ppc-2/2 rt-literal 1 jit-3dip jit-define
] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define
[
0 1 lr-save stack-frame + LWZ
@ -331,7 +309,6 @@ big-endian on
! Comparisons
: jit-compare ( insn -- )
0 3 LOAD32
3 3 0 LWZ
4 ds-reg 0 LWZ
5 ds-reg -4 LWZU
5 0 4 CMP
@ -340,7 +317,7 @@ big-endian on
3 ds-reg 0 STW ;
: define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip
[ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip
define-sub-primitive ;
\ BEQ \ eq? define-jit-compare
@ -411,6 +388,7 @@ big-endian on
ds-reg ds-reg 4 SUBI
4 ds-reg 0 LWZ
5 4 3 DIVW
5 5 tag-bits get SLWI
5 ds-reg 0 STW
] f f f \ fixnum/i-fast define-sub-primitive
@ -420,6 +398,7 @@ big-endian on
5 4 3 DIVW
6 5 3 MULLW
7 6 4 SUBF
5 5 tag-bits get SLWI
5 ds-reg -4 STW
7 ds-reg 0 STW
] f f f \ fixnum/mod-fast define-sub-primitive

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

@ -34,10 +34,8 @@ M: ppc two-operand? f ;
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M:: ppc %load-indirect ( reg obj -- )
0 reg LOAD32
obj rc-absolute-ppc-2/2 rel-literal
reg reg 0 LWZ ;
M: ppc %load-indirect ( reg obj -- )
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
: ds-reg 29 ; inline
: rs-reg 30 ; inline
@ -398,14 +396,14 @@ M: ppc %epilogue ( n -- )
1 1 rot ADDI
0 MTLR ;
:: (%boolean) ( dst word -- )
:: (%boolean) ( dst temp word -- )
"end" define-label
dst \ f tag-number %load-immediate
"end" get word execute
dst \ t %load-indirect
"end" get resolve-label ; inline
: %boolean ( dst cc -- )
: %boolean ( dst temp cc -- )
negate-cc {
{ cc< [ \ BLT (%boolean) ] }
{ cc<= [ \ BLE (%boolean) ] }

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

@ -88,8 +88,6 @@ M: float-regs store-return-reg
[ [ align-sub ] [ call ] bi* ]
[ [ align-add ] [ drop ] bi* ] 2bi ; inline
M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ;
M: x86.32 %prologue ( n -- )
dup PUSH
0 PUSH rc-absolute-cell rel-this

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

@ -44,8 +44,6 @@ M:: x86.64 %dispatch ( src temp offset -- )
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;
M: x86.64 rel-literal-x86 rc-relative rel-literal ;
M: x86.64 %prologue ( n -- )
temp-reg-1 0 MOV rc-absolute-cell rel-this
dup PUSH

4
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -23,6 +23,6 @@ M: x86.64 dummy-fp-params? t ;
<<
"longlong" "ptrdiff_t" typedef
"longlong" "intptr_t" typedef
"int" "long" typedef
"uint" "ulong" typedef
"int" c-type "long" define-primitive-type
"uint" c-type "ulong" define-primitive-type
>>

3
basis/cpu/x86/assembler/assembler.factor
View File

@ -308,18 +308,21 @@ M: operand MOV HEX: 88 2-operand ;
! Control flow
GENERIC: JMP ( op -- )
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
M: f JMP (JMP) 2drop ;
M: callable JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: f CALL (CALL) 2drop ;
M: callable CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
M: f JUMPcc nip (JUMPcc) drop ;
M: callable JUMPcc (JUMPcc) rel-word ;
M: label JUMPcc (JUMPcc) label-fixup ;

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

@ -13,7 +13,6 @@ big-endian off
[
! Load word
temp-reg 0 MOV
temp-reg dup [] MOV
! Bump profiling counter
temp-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
@ -22,7 +21,7 @@ big-endian off
temp-reg compiled-header-size ADD
! Jump to XT
temp-reg JMP
] rc-absolute-cell rt-literal 1 rex-length + jit-profiling jit-define
] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
[
temp-reg 0 MOV ! load XT
@ -31,13 +30,6 @@ big-endian off
stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment
] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
[
arg0 0 MOV ! load literal
arg0 dup [] MOV
ds-reg bootstrap-cell ADD ! increment datastack pointer
ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define
[
arg0 0 MOV ! load literal
ds-reg bootstrap-cell ADD ! increment datastack pointer
@ -45,107 +37,99 @@ big-endian off
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
[
(JMP) drop
f JMP
] rc-relative rt-xt 1 jit-word-jump jit-define
[
(CALL) drop
f CALL
] rc-relative rt-xt 1 jit-word-call jit-define
[
arg1 0 MOV ! load addr of true quotation
arg0 ds-reg [] MOV ! load boolean
ds-reg bootstrap-cell SUB ! pop boolean
arg0 \ f tag-number CMP ! compare it with f
arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
arg0 quot-xt-offset [+] JMP ! jump to quotation-xt
] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
arg0 \ f tag-number CMP ! compare boolean with f
f JNE ! jump to true branch if not equal
] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
[
f JMP ! jump to false branch if equal
] rc-relative rt-xt 1 jit-if-2 jit-define
[
arg1 0 MOV ! load dispatch table
arg1 dup [] MOV
arg0 ds-reg [] MOV ! load index
fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location
arg0 arg0 array-start-offset [+] MOV ! load quotation
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
! The jit->r words cannot clobber arg0
] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
temp-reg ds-reg [] MOV
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
rs-reg [] temp-reg MOV ;
rs-reg [] arg0 MOV ;
: jit-2>r ( -- )
rs-reg 2 bootstrap-cells ADD
temp-reg ds-reg [] MOV
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg 2 bootstrap-cells SUB
rs-reg [] temp-reg MOV
rs-reg [] arg0 MOV
rs-reg -1 bootstrap-cells [+] arg1 MOV ;
: jit-3>r ( -- )
rs-reg 3 bootstrap-cells ADD
temp-reg ds-reg [] MOV
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
arg2 ds-reg -2 bootstrap-cells [+] MOV
ds-reg 3 bootstrap-cells SUB
rs-reg [] temp-reg MOV
rs-reg [] arg0 MOV
rs-reg -1 bootstrap-cells [+] arg1 MOV
rs-reg -2 bootstrap-cells [+] arg2 MOV ;
: jit-r> ( -- )
ds-reg bootstrap-cell ADD
temp-reg rs-reg [] MOV
arg0 rs-reg [] MOV
rs-reg bootstrap-cell SUB
ds-reg [] temp-reg MOV ;
ds-reg [] arg0 MOV ;
: jit-2r> ( -- )
ds-reg 2 bootstrap-cells ADD
temp-reg rs-reg [] MOV
arg0 rs-reg [] MOV
arg1 rs-reg -1 bootstrap-cells [+] MOV
rs-reg 2 bootstrap-cells SUB
ds-reg [] temp-reg MOV
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV ;
: jit-3r> ( -- )
ds-reg 3 bootstrap-cells ADD
temp-reg rs-reg [] MOV
arg0 rs-reg [] MOV
arg1 rs-reg -1 bootstrap-cells [+] MOV
arg2 rs-reg -2 bootstrap-cells [+] MOV
rs-reg 3 bootstrap-cells SUB
ds-reg [] temp-reg MOV
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV
ds-reg -2 bootstrap-cells [+] arg2 MOV ;
[
arg0 0 MOV ! load quotation addr
arg0 arg0 [] MOV ! load quotation
jit->r
arg0 quot-xt-offset [+] CALL ! call quotation
f CALL
jit-r>
] rc-absolute-cell rt-literal 1 rex-length + jit-dip jit-define
] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
[
arg0 0 MOV ! load quotation addr
arg0 arg0 [] MOV ! load quotation
jit-2>r
arg0 quot-xt-offset [+] CALL ! call quotation
f CALL
jit-2r>
] rc-absolute-cell rt-literal 1 rex-length + jit-2dip jit-define
] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
[
arg0 0 MOV ! load quotation addr
arg0 arg0 [] MOV ! load quotation
jit-3>r
arg0 quot-xt-offset [+] CALL ! call quotation
f CALL
jit-3r>
] rc-absolute-cell rt-literal 1 rex-length + jit-3dip jit-define
] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
@ -303,9 +287,8 @@ big-endian off
! Comparisons
: jit-compare ( insn -- )
arg1 0 MOV ! load t
arg1 dup [] MOV
temp-reg \ f tag-number MOV ! load f
temp-reg 0 MOV ! load t
arg1 \ f tag-number MOV ! load f
arg0 ds-reg [] MOV ! load first value
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] arg0 CMP ! compare with second value
@ -314,14 +297,14 @@ big-endian off
;
: define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip
[ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
define-sub-primitive ;
\ CMOVNE \ eq? define-jit-compare
\ CMOVL \ fixnum>= define-jit-compare
\ CMOVG \ fixnum<= define-jit-compare
\ CMOVLE \ fixnum> define-jit-compare
\ CMOVGE \ fixnum< define-jit-compare
\ CMOVE \ eq? define-jit-compare
\ CMOVGE \ fixnum>= define-jit-compare
\ CMOVLE \ fixnum<= define-jit-compare
\ CMOVG \ fixnum> define-jit-compare
\ CMOVL \ fixnum< define-jit-compare
! Math
: jit-math ( insn -- )

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

@ -16,9 +16,7 @@ HOOK: temp-reg-2 cpu ( -- reg )
M: x86 %load-immediate MOV ;
HOOK: rel-literal-x86 cpu ( literal -- )
M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ;
M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
@ -401,12 +399,12 @@ HOOK: stack-reg cpu ( -- reg )
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
: %boolean ( dst word -- )
over \ f tag-number MOV
0 [] swap execute
\ t rel-literal-x86 ; inline
:: %boolean ( dst temp word -- )
dst \ f tag-number MOV
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
M: x86 %compare ( dst cc src1 src2 -- )
M: x86 %compare ( dst temp cc src1 src2 -- )
CMP {
{ cc< [ \ CMOVL %boolean ] }
{ cc<= [ \ CMOVLE %boolean ] }
@ -416,10 +414,10 @@ M: x86 %compare ( dst cc src1 src2 -- )
{ cc/= [ \ CMOVNE %boolean ] }
} case ;
M: x86 %compare-imm ( dst cc src1 src2 -- )
M: x86 %compare-imm ( dst temp cc src1 src2 -- )
%compare ;
M: x86 %compare-float ( dst cc src1 src2 -- )
M: x86 %compare-float ( dst temp cc src1 src2 -- )
UCOMISD {
{ cc< [ \ CMOVB %boolean ] }
{ cc<= [ \ CMOVBE %boolean ] }

150
basis/db/postgresql/postgresql-tests.factor
View File

@ -1,6 +1,6 @@
USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db
db.tuples db.types unicode.case accessors ;
db.tuples db.types unicode.case accessors system ;
IN: db.postgresql.tests
: test-db ( -- postgresql-db )
@ -10,86 +10,88 @@ IN: db.postgresql.tests
"thepasswordistrust" >>password
"factor-test" >>database ;
[ ] [ test-db [ ] with-db ] unit-test
os windows? cpu x86.64? and [
[ ] [ test-db [ ] with-db ] unit-test
[ ] [
test-db [
[ "drop table person;" sql-command ] ignore-errors
"create table person (name varchar(30), country varchar(30));"
[ ] [
test-db [
[ "drop table person;" sql-command ] ignore-errors
"create table person (name varchar(30), country varchar(30));"
sql-command
"insert into person values('John', 'America');" sql-command
"insert into person values('Jane', 'New Zealand');" sql-command
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [
test-db [
"select * from person" sql-query
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[
] [
test-db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-db
] unit-test
"insert into person values('John', 'America');" sql-command
"insert into person values('Jane', 'New Zealand');" sql-command
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
{ "Jimmy" "Canada" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [
test-db [
"select * from person" sql-query
] with-db
] unit-test
[
test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"oops" throw
] with-transaction
] with-db
] must-fail
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[ 3 ] [
test-db [
"select * from person" sql-query length
] with-db
] unit-test
[
] [
test-db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-db
] unit-test
[
] [
test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] with-transaction
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
{ "Jimmy" "Canada" }
}
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
[
test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"oops" throw
] with-transaction
] with-db
] must-fail
[ 3 ] [
test-db [
"select * from person" sql-query length
] with-db
] unit-test
[
] [
test-db [
[
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] with-transaction
] with-db
] unit-test
[ 5 ] [
test-db [
"select * from person" sql-query length
] with-db
] unit-test
[ 5 ] [
test-db [
"select * from person" sql-query length
] with-db
] unit-test
] unless
: with-dummy-db ( quot -- )

6
basis/db/tuples/tuples-tests.factor
View File

@ -3,7 +3,7 @@
USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise
db.postgresql accessors random math.bitwise system
math.ranges strings urls fry db.tuples.private ;
IN: db.tuples.tests
@ -26,7 +26,9 @@ IN: db.tuples.tests
: test-postgresql ( quot -- )
'[
[ ] [ postgresql-db _ with-db ] unit-test
os windows? cpu x86.64? and [
[ ] [ postgresql-db _ with-db ] unit-test
] unless
] call ; inline
! These words leak resources, but are useful for interactivel testing

12
basis/delegate/delegate.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
prettyprint math hashtables sets macros namespaces make ;
prettyprint math hashtables sets generalizations namespaces make ;
IN: delegate
: protocol-words ( protocol -- words )
@ -25,15 +25,7 @@ M: tuple-class group-words
: consult-method ( word class quot -- )
[ drop swap first create-method ]
[
nip
[
over second saver %
%
dup second restorer %
first ,
] [ ] make
] 3bi
[ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi
define ;
: change-word-prop ( word prop quot -- )

7
basis/editors/editors.factor
View File

@ -64,10 +64,13 @@ M: object error-file
M: object error-line
drop f ;
: :edit ( -- )
error get [ error-file ] [ error-line ] bi
: (:edit) ( error -- )
[ error-file ] [ error-line ] bi
2dup and [ edit-location ] [ 2drop ] if ;
: :edit ( -- )
error get (:edit) ;
: edit-each ( seq -- )
[
[ "Editing " write . ]

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

@ -6,7 +6,7 @@ io arrays math boxes splitting urls
xml.entities
http.server
http.server.responses
furnace
furnace.utilities
furnace.redirection
furnace.conversations
html.forms

2
basis/furnace/asides/asides.factor
View File

@ -4,9 +4,9 @@ USING: namespaces assocs kernel sequences accessors hashtables
urls db.types db.tuples math.parser fry logging combinators
html.templates.chloe.syntax
http http.server http.server.filters http.server.redirection
furnace
furnace.cache
furnace.sessions
furnace.utilities
furnace.redirection ;
IN: furnace.asides

2
basis/furnace/auth/auth.factor
View File

@ -8,8 +8,8 @@ html.forms
http.server
http.server.filters
http.server.dispatchers
furnace
furnace.actions
furnace.utilities
furnace.redirection
furnace.boilerplate
furnace.auth.providers

9
basis/furnace/auth/features/recover-password/recover-password.factor
View File

@ -1,11 +1,10 @@
! Copyright (c) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make accessors kernel assocs arrays io.sockets
threads fry urls smtp validators html.forms present
http http.server.responses http.server.redirection
http.server.dispatchers
furnace furnace.actions furnace.auth furnace.auth.providers
furnace.redirection ;
threads fry urls smtp validators html.forms present http
http.server.responses http.server.redirection
http.server.dispatchers furnace.actions furnace.auth
furnace.auth.providers furnace.redirection furnace.utilities ;
IN: furnace.auth.features.recover-password
SYMBOL: lost-password-from

2
basis/furnace/auth/features/registration/registration.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces validators html.forms urls
http.server.dispatchers
furnace furnace.auth furnace.auth.providers furnace.actions
furnace.auth furnace.auth.providers furnace.actions
furnace.redirection ;
IN: furnace.auth.features.registration

1
basis/furnace/auth/login/login.factor
View File

@ -3,7 +3,6 @@
USING: kernel accessors namespaces sequences math.parser
calendar validators urls logging html.forms
http http.server http.server.dispatchers
furnace
furnace.auth
furnace.asides
furnace.actions

5
basis/furnace/boilerplate/boilerplate.factor
View File

@ -1,12 +1,13 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math.order namespaces furnace combinators.short-circuit
USING: accessors kernel math.order namespaces combinators.short-circuit
html.forms
html.templates
html.templates.chloe
locals
http.server
http.server.filters ;
http.server.filters
furnace.utilities ;
IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template init ;

2
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -19,7 +19,7 @@ http
http.server
http.server.redirection
http.server.responses
furnace ;
furnace.utilities ;
QUALIFIED-WITH: assocs a
IN: furnace.chloe-tags

2
basis/furnace/conversations/conversations.factor
View File

@ -4,10 +4,10 @@ USING: namespaces assocs kernel sequences accessors hashtables
urls db.types db.tuples math.parser fry logging combinators
html.templates.chloe.syntax
http http.server http.server.filters http.server.redirection
furnace
furnace.cache
furnace.scopes
furnace.sessions
furnace.utilities
furnace.redirection ;
IN: furnace.conversations

123
basis/furnace/furnace-docs.factor
View File

@ -2,129 +2,6 @@ USING: assocs help.markup help.syntax kernel
quotations sequences strings urls xml.data http ;
IN: furnace
HELP: adjust-redirect-url
{ $values { "url" url } { "url'" url } }
{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ;
HELP: adjust-url
{ $values { "url" url } { "url'" url } }
{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ;
HELP: client-state
{ $values { "key" string } { "value/f" { $maybe string } } }
{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
{ $notes "This word is used by session management, conversation scope and asides." } ;
HELP: each-responder
{ $values { "quot" { $quotation "( responder -- )" } } }
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
HELP: hidden-form-field
{ $values { "value" string } { "name" string } }
{ $description "Renders an HTML hidden form field tag." }
{ $notes "This word is used by session management, conversation scope and asides." }
{ $examples
{ $example
"USING: furnace io ;"
"\"bar\" \"foo\" hidden-form-field nl"
"<input type='hidden' name='foo' value='bar'/>"
}
} ;
HELP: link-attr
{ $values { "tag" tag } { "responder" "a responder" } }
{ $contract "Modifies an XHTML " { $snippet "a" } " tag." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Conversation scope adds attributes to link tags." } ;
HELP: modify-form
{ $values { "responder" "a responder" } }
{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
HELP: modify-query
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Asides add query parameters to URLs." } ;
HELP: modify-redirect-query
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." }
{ $notes "This word is called by " { $link "furnace.redirection" } "." }
{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ;
HELP: nested-responders
{ $values { "seq" "a sequence of responders" } }
{ $description "" } ;
HELP: referrer
{ $values { "referrer/f" { $maybe string } } }
{ $description "Outputs the current request's referrer URL." } ;
HELP: request-params
{ $values { "request" request } { "assoc" assoc } }
{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
HELP: resolve-base-path
{ $values { "string" string } { "string'" string } }
{ $description "" } ;
HELP: resolve-template-path
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
{ $description "" } ;
HELP: same-host?
{ $values { "url" url } { "?" "a boolean" } }
{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ;
HELP: user-agent
{ $values { "user-agent" { $maybe string } } }
{ $description "Outputs the user agent reported by the client for the current request." } ;
HELP: vocab-path
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
{ $description "" } ;
HELP: exit-with
{ $values { "value" object } }
{ $description "Exits from an outer " { $link with-exit-continuation } "." } ;
HELP: with-exit-continuation
{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } }
{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." }
{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
ARTICLE: "furnace.extension-points" "Furnace extension points"
"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
$nl
"Responders can implement methods on the following generic words:"
{ $subsection modify-query }
{ $subsection modify-redirect-query }
{ $subsection link-attr }
{ $subsection modify-form }
"Presentation-level code can call the following words:"
{ $subsection adjust-url }
{ $subsection adjust-redirect-url } ;
ARTICLE: "furnace.misc" "Miscellaneous Furnace features"
"Inspecting the chain of responders handling the current request:"
{ $subsection nested-responders }
{ $subsection each-responder }
{ $subsection resolve-base-path }
"Vocabulary root-relative resources:"
{ $subsection vocab-path }
{ $subsection resolve-template-path }
"Early return from a responder:"
{ $subsection with-exit-continuation }
{ $subsection exit-with }
"Other useful words:"
{ $subsection hidden-form-field }
{ $subsection request-params }
{ $subsection client-state }
{ $subsection user-agent } ;
ARTICLE: "furnace.persistence" "Furnace persistence layer"
{ $subsection "furnace.db" }
"Server-side state:"

4
basis/furnace/furnace-tests.factor
View File

@ -1,7 +1,7 @@
IN: furnace.tests
USING: http http.server.dispatchers http.server.responses
http.server furnace tools.test kernel namespaces accessors
io.streams.string urls ;
http.server furnace furnace.utilities tools.test kernel
namespaces accessors io.streams.string urls ;
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;

126
basis/furnace/furnace.factor
View File

@ -1,133 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make assocs sequences kernel classes splitting
vocabs.loader accessors strings combinators arrays
continuations present fry
urls html.elements
http http.server http.server.redirection http.server.remapping ;
IN: furnace
: nested-responders ( -- seq )
responder-nesting get values ;
: each-responder ( quot -- )
nested-responders swap each ; inline
: base-path ( string -- pair )
dup responder-nesting get
[ second class superclasses [ name>> = ] with contains? ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
[
"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
] "" make
] when ;
: vocab-path ( vocab -- path )
dup vocab-dir vocab-append-path ;
: resolve-template-path ( pair -- path )
[
first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
] "" make ;
GENERIC: modify-query ( query responder -- query' )
M: object modify-query drop ;
GENERIC: modify-redirect-query ( query responder -- query' )
M: object modify-redirect-query drop ;
GENERIC: adjust-url ( url -- url' )
M: url adjust-url
clone
[ [ modify-query ] each-responder ] change-query
[ resolve-base-path ] change-path
relative-to-request ;
M: string adjust-url ;
GENERIC: adjust-redirect-url ( url -- url' )
M: url adjust-redirect-url
adjust-url
[ [ modify-redirect-query ] each-responder ] change-query ;
M: string adjust-redirect-url ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
: nested-forms-key "__n" ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
{ "POST" [
post-data>>
dup content-type>> "application/x-www-form-urlencoded" =
[ content>> ] [ drop f ] if
] }
} case ;
: referrer ( -- referrer/f )
#! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at
dup [ >url ensure-port [ remap-port ] change-port ] when ;
: user-agent ( -- user-agent )
"user-agent" request get header>> at "" or ;
: same-host? ( url -- ? )
dup [
url get [
[ protocol>> ]
[ host>> ]
[ port>> remap-port ]
tri 3array
] bi@ =
] when ;
: cookie-client-state ( key request -- value/f )
swap get-cookie dup [ value>> ] when ;
: post-client-state ( key request -- value/f )
request-params at ;
: client-state ( key -- value/f )
request get dup method>> {
{ "GET" [ cookie-client-state ] }
{ "HEAD" [ cookie-client-state ] }
{ "POST" [ post-client-state ] }
} case ;
SYMBOL: exit-continuation
: exit-with ( value -- )
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
USE: vocabs.loader
"furnace.actions" require
"furnace.alloy" require

2
basis/furnace/redirection/redirection.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry urls http
http.server http.server.redirection http.server.responses
http.server.remapping http.server.filters furnace ;
http.server.remapping http.server.filters furnace.utilities ;
IN: furnace.redirection
: <redirect> ( url -- response )

2
basis/furnace/referrer/referrer-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io.streams.string
furnace ;
furnace.utilities ;
IN: furnace.referrer
HELP: <check-form-submissions>

2
basis/furnace/referrer/referrer.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel http.server http.server.filters
http.server.responses furnace ;
http.server.responses furnace.utilities ;
IN: furnace.referrer
TUPLE: referrer-check < filter-responder quot ;

3
basis/furnace/sessions/sessions-tests.factor
View File

@ -3,7 +3,8 @@ USING: tools.test http furnace.sessions furnace.actions
http.server http.server.responses math namespaces make kernel
accessors io.sockets io.servers.connection prettyprint
io.streams.string io.files splitting destructors sequences db
db.tuples db.sqlite continuations urls math.parser furnace ;
db.tuples db.sqlite continuations urls math.parser furnace
furnace.utilities ;
: with-session
[

10
basis/furnace/sessions/sessions.factor
View File

@ -1,13 +1,11 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.intervals math.parser namespaces
strings random accessors quotations hashtables sequences continuations
fry calendar combinators combinators.short-circuit destructors alarms
io.servers.connection
db db.tuples db.types
strings random accessors quotations hashtables sequences
continuations fry calendar combinators combinators.short-circuit
destructors alarms io.servers.connection db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements
furnace furnace.cache furnace.scopes ;
html.elements furnace.cache furnace.scopes furnace.utilities ;
IN: furnace.sessions
TUPLE: session < scope user-agent client ;

7
basis/furnace/syndication/syndication.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences fry
combinators syndication
http.server.responses http.server.redirection
furnace furnace.actions ;
USING: accessors kernel sequences fry combinators syndication
http.server.responses http.server.redirection furnace.actions
furnace.utilities ;
IN: furnace.syndication
GENERIC: feed-entry-title ( object -- string )

126
basis/furnace/utilities/utilities-docs.factor Normal file
View File

@ -0,0 +1,126 @@
USING: assocs help.markup help.syntax kernel
quotations sequences strings urls xml.data http ;
IN: furnace.utilities
HELP: adjust-redirect-url
{ $values { "url" url } { "url'" url } }
{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ;
HELP: adjust-url
{ $values { "url" url } { "url'" url } }
{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ;
HELP: client-state
{ $values { "key" string } { "value/f" { $maybe string } } }
{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
{ $notes "This word is used by session management, conversation scope and asides." } ;
HELP: each-responder
{ $values { "quot" { $quotation "( responder -- )" } } }
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
HELP: hidden-form-field
{ $values { "value" string } { "name" string } }
{ $description "Renders an HTML hidden form field tag." }
{ $notes "This word is used by session management, conversation scope and asides." }
{ $examples
{ $example
"USING: furnace.utilities io ;"
"\"bar\" \"foo\" hidden-form-field nl"
"<input type='hidden' name='foo' value='bar'/>"
}
} ;
HELP: link-attr
{ $values { "tag" tag } { "responder" "a responder" } }
{ $contract "Modifies an XHTML " { $snippet "a" } " tag." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Conversation scope adds attributes to link tags." } ;
HELP: modify-form
{ $values { "responder" "a responder" } }
{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
HELP: modify-query
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Asides add query parameters to URLs." } ;
HELP: modify-redirect-query
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." }
{ $notes "This word is called by " { $link "furnace.redirection" } "." }
{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ;
HELP: nested-responders
{ $values { "seq" "a sequence of responders" } }
{ $description "" } ;
HELP: referrer
{ $values { "referrer/f" { $maybe string } } }
{ $description "Outputs the current request's referrer URL." } ;
HELP: request-params
{ $values { "request" request } { "assoc" assoc } }
{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
HELP: resolve-base-path
{ $values { "string" string } { "string'" string } }
{ $description "" } ;
HELP: resolve-template-path
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
{ $description "" } ;
HELP: same-host?
{ $values { "url" url } { "?" "a boolean" } }
{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ;
HELP: user-agent
{ $values { "user-agent" { $maybe string } } }
{ $description "Outputs the user agent reported by the client for the current request." } ;
HELP: vocab-path
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
{ $description "" } ;
HELP: exit-with
{ $values { "value" object } }
{ $description "Exits from an outer " { $link with-exit-continuation } "." } ;
HELP: with-exit-continuation
{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } }
{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." }
{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
ARTICLE: "furnace.extension-points" "Furnace extension points"
"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
$nl
"Responders can implement methods on the following generic words:"
{ $subsection modify-query }
{ $subsection modify-redirect-query }
{ $subsection link-attr }
{ $subsection modify-form }
"Presentation-level code can call the following words:"
{ $subsection adjust-url }
{ $subsection adjust-redirect-url } ;
ARTICLE: "furnace.misc" "Miscellaneous Furnace features"
"Inspecting the chain of responders handling the current request:"
{ $subsection nested-responders }
{ $subsection each-responder }
{ $subsection resolve-base-path }
"Vocabulary root-relative resources:"
{ $subsection vocab-path }
{ $subsection resolve-template-path }
"Early return from a responder:"
{ $subsection with-exit-continuation }
{ $subsection exit-with }
"Other useful words:"
{ $subsection hidden-form-field }
{ $subsection request-params }
{ $subsection client-state }
{ $subsection user-agent } ;

128
basis/furnace/utilities/utilities.factor
View File

@ -1,6 +1,9 @@
! Copyright (c) 2008 Slava Pestov
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors words kernel sequences splitting ;
USING: namespaces make assocs sequences kernel classes splitting
words vocabs.loader accessors strings combinators arrays
continuations present fry urls html.elements http http.server
http.server.redirection http.server.remapping ;
IN: furnace.utilities
: word>string ( word -- string )
@ -17,3 +20,124 @@ ERROR: no-such-word name vocab ;
: strings>words ( seq -- seq' )
[ string>word ] map ;
: nested-responders ( -- seq )
responder-nesting get values ;
: each-responder ( quot -- )
nested-responders swap each ; inline
: base-path ( string -- pair )
dup responder-nesting get
[ second class superclasses [ name>> = ] with contains? ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
[
"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
] "" make
] when ;
: vocab-path ( vocab -- path )
dup vocab-dir vocab-append-path ;
: resolve-template-path ( pair -- path )
[
first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
] "" make ;
GENERIC: modify-query ( query responder -- query' )
M: object modify-query drop ;
GENERIC: modify-redirect-query ( query responder -- query' )
M: object modify-redirect-query drop ;
GENERIC: adjust-url ( url -- url' )
M: url adjust-url
clone
[ [ modify-query ] each-responder ] change-query
[ resolve-base-path ] change-path
relative-to-request ;
M: string adjust-url ;
GENERIC: adjust-redirect-url ( url -- url' )
M: url adjust-redirect-url
adjust-url
[ [ modify-redirect-query ] each-responder ] change-query ;
M: string adjust-redirect-url ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
: nested-forms-key "__n" ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
{ "POST" [
post-data>>
dup content-type>> "application/x-www-form-urlencoded" =
[ content>> ] [ drop f ] if
] }
} case ;
: referrer ( -- referrer/f )
#! Typo is intentional, it's in the HTTP spec!
"referer" request get header>> at
dup [ >url ensure-port [ remap-port ] change-port ] when ;
: user-agent ( -- user-agent )
"user-agent" request get header>> at "" or ;
: same-host? ( url -- ? )
dup [
url get [
[ protocol>> ]
[ host>> ]
[ port>> remap-port ]
tri 3array
] bi@ =
] when ;
: cookie-client-state ( key request -- value/f )
swap get-cookie dup [ value>> ] when ;
: post-client-state ( key request -- value/f )
request-params at ;
: client-state ( key -- value/f )
request get dup method>> {
{ "GET" [ cookie-client-state ] }
{ "HEAD" [ cookie-client-state ] }
{ "POST" [ post-client-state ] }
} case ;
SYMBOL: exit-continuation
: exit-with ( value -- )
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;

143
basis/generalizations/generalizations.factor
View File

@ -1,68 +1,75 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private namespaces math
math.ranges combinators macros quotations fry arrays ;
IN: generalizations
MACRO: nsequence ( n seq -- quot )
[
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
MACRO: narray ( n -- quot )
'[ _ { } nsequence ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
[ 1- '[ [ _ ] dip bounds-check 2drop ] ]
bi prefix '[ _ cleave ]
] if ;
MACRO: npick ( n -- )
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
MACRO: ndup ( n -- )
dup '[ _ npick ] n*quot ;
MACRO: nrot ( n -- )
1- dup saver swap [ r> swap ] n*quot append ;
MACRO: -nrot ( n -- )
1- dup [ swap >r ] n*quot swap restorer append ;
MACRO: ndrop ( n -- )
[ drop ] n*quot ;
: nnip ( n -- )
swap >r ndrop r> ; inline
MACRO: ntuck ( n -- )
2 + [ dupd -nrot ] curry ;
MACRO: nrev ( n -- quot )
1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
MACRO: ndip ( quot n -- )
dup saver -rot restorer 3append ;
MACRO: nslip ( n -- )
dup saver [ call ] rot restorer 3append ;
MACRO: nkeep ( n -- )
[ ] [ 1+ ] [ ] tri
'[ [ _ ndup ] dip _ -nrot _ nslip ] ;
MACRO: ncurry ( n -- )
[ curry ] n*quot ;
MACRO: nwith ( n -- )
[ with ] n*quot ;
MACRO: napply ( n -- )
2 [a,b]
[ [ 1- ] keep '[ _ ntuck _ nslip ] ]
map concat >quotation [ call ] append ;
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math math.ranges
combinators macros quotations fry ;
IN: generalizations
<<
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
: repeat ( n obj quot -- ) swapd times ; inline
>>
MACRO: nsequence ( n seq -- quot )
[
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
MACRO: narray ( n -- quot )
'[ _ { } nsequence ] ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
[ 1- '[ [ _ ] dip bounds-check 2drop ] ]
bi prefix '[ _ cleave ]
] if ;
MACRO: npick ( n -- quot )
1- [ dup ] [ '[ _ dip swap ] ] repeat ;
MACRO: ndup ( n -- )
dup '[ _ npick ] n*quot ;
MACRO: nrot ( n -- )
1- [ ] [ '[ _ dip swap ] ] repeat ;
MACRO: -nrot ( n -- )
1- [ ] [ '[ swap _ dip ] ] repeat ;
MACRO: ndrop ( n -- )
[ drop ] n*quot ;
MACRO: nnip ( n -- )
'[ [ _ ndrop ] dip ] ;
MACRO: ntuck ( n -- )
2 + '[ dup _ -nrot ] ;
MACRO: nrev ( n -- quot )
1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
MACRO: ndip ( quot n -- )
[ '[ _ dip ] ] times ;
MACRO: nslip ( n -- )
'[ [ call ] _ ndip ] ;
MACRO: nkeep ( quot n -- )
tuck '[ _ ndup _ _ ndip ] ;
MACRO: ncurry ( n -- )
[ curry ] n*quot ;
MACRO: nwith ( n -- )
[ with ] n*quot ;
MACRO: napply ( n -- )
2 [a,b]
[ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
map concat >quotation [ call ] append ;

7
basis/help/help.factor
View File

@ -155,10 +155,13 @@ help-hook global [ [ print-topic ] or ] change-at
":get ( var -- value ) accesses variables at time of the error" print
":vars - list all variables at error time" print ;
: :help ( -- )
error get error-help [ help ] [ "No help for this error. " print ] if*
: (:help) ( error -- )
error-help [ help ] [ "No help for this error. " print ] if*
:help-debugger ;
: :help ( -- )
error get (:help) ;
: remove-article ( name -- )
dup articles get key? [
dup unxref-article

9
basis/http/http-tests.factor
View File

@ -2,7 +2,7 @@ USING: http http.server http.client tools.test multiline
io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string kernel arrays splitting
sequences assocs io.sockets db db.sqlite continuations urls
hashtables accessors ;
hashtables accessors namespaces ;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
@ -11,6 +11,12 @@ IN: http.tests
[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
[ { } ] [ "" parse-cookie ] unit-test
[ { } ] [ "" parse-set-cookie ] unit-test
! Make sure that totally invalid cookies don't confuse us
[ { } ] [ "hello world; how are you" parse-cookie ] unit-test
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
@ -126,6 +132,7 @@ content-type: text/html; charset=UTF-8
;
read-response-test-1' 1array [
URL" http://localhost/" url set
read-response-test-1 lf>crlf
[ read-response ] with-string-reader
[ write-response ] with-string-writer

14
basis/http/parsers/parsers.factor
View File

@ -142,16 +142,15 @@ PEG: parse-header-line ( string -- pair )
'space' ,
'attr' ,
'space' ,
[ "=" token , 'space' , 'value' , ] seq* [ peek ] action
epsilon [ drop f ] action
2choice ,
[ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional ,
'space' ,
] seq* ;
: 'av-pairs' ( -- parser )
'av-pair' ";" token list-of optional ;
PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
PEG: (parse-set-cookie) ( string -- alist )
'av-pairs' just [ sift ] action ;
: 'cookie-value' ( -- parser )
[
@ -162,7 +161,10 @@ PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
'space' ,
'value' ,
'space' ,
] seq* ;
] seq*
[ ";,=" member? not ] satisfy repeat1 [ drop f ] action
2choice ;
PEG: (parse-cookie) ( string -- alist )
'cookie-value' [ ";," member? ] satisfy list-of optional just ;
'cookie-value' [ ";," member? ] satisfy list-of
optional just [ sift ] action ;

8
basis/io/windows/nt/backend/backend.factor
View File

@ -48,12 +48,12 @@ M: winnt add-completion ( win32-handle -- )
} cond
] with-timeout ;
:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? )
:: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
master-completion-port get-global
0 <int> [ ! bytes
f <void*> ! key
f <void*> [ ! overlapped
ms INFINITE or ! timeout
us [ 1000 /i ] [ INFINITE ] if* ! timeout
GetQueuedCompletionStatus zero?
] keep *void*
] keep *int spin ;
@ -61,7 +61,7 @@ M: winnt add-completion ( win32-handle -- )
: resume-callback ( result overlapped -- )
pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( timeout -- ? )
: handle-overlapped ( us -- ? )
wait-for-overlapped [
dup [
>r drop GetLastError 1array r> resume-callback t
@ -75,7 +75,7 @@ M: winnt add-completion ( win32-handle -- )
M: win32-handle cancel-operation
[ check-disposed ] [ handle>> CancelIo drop ] bi ;
M: winnt io-multiplex ( ms -- )
M: winnt io-multiplex ( us -- )
handle-overlapped [ 0 io-multiplex ] when ;
M: winnt init-io ( -- )

13
basis/locals/locals-tests.factor
View File

@ -418,6 +418,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
:: FAILdog-1 ( -- b ) { [| c | c ] } ;
\ FAILdog-1 must-infer
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
\ FAILdog-2 must-infer
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]

18
basis/locals/locals.factor
View File

@ -206,6 +206,8 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ;
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
M: wrapper rewrite-literal? drop t ;
M: hashtable rewrite-literal? drop t ;
M: vector rewrite-literal? drop t ;
@ -235,12 +237,17 @@ M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element
[ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
M: lambda rewrite-element local-rewrite* ;
M: local rewrite-element , ;
M: local-reader rewrite-element , ;
M: word rewrite-element literalize , ;
M: wrapper rewrite-element
dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
M: object rewrite-element , ;
M: array local-rewrite* rewrite-element ;
@ -251,8 +258,10 @@ M: tuple local-rewrite* rewrite-element ;
M: hashtable local-rewrite* rewrite-element ;
M: wrapper local-rewrite* rewrite-element ;
M: word local-rewrite*
dup { >r r> } memq?
dup { >r r> load-locals get-local drop-locals } memq?
[ >r/r>-in-lambda-error ] [ call-next-method ] if ;
M: object lambda-rewrite* , ;
@ -350,10 +359,15 @@ M: wlet local-rewrite*
word [ over "declared-effect" set-word-prop ] when*
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
ERROR: bad-lambda-rewrite output ;
M: bad-lambda-rewrite summary
drop "You have found a bug in locals. Please report." ;
: parse-locals-definition ( word -- word quot )
"(" expect parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;

6
basis/macros/macros.factor
View File

@ -22,9 +22,3 @@ M: macro definition "macro" word-prop ;
M: macro reset-word
[ call-next-method ] [ f "macro" set-word-prop ] bi ;
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
: saver ( n -- quot ) \ >r <repetition> >quotation ;
: restorer ( n -- quot ) \ r> <repetition> >quotation ;

7
basis/math/bitwise/bitwise.factor
View File

@ -23,17 +23,12 @@ IN: math.bitwise
: bitroll ( x s w -- y )
[ wrap ] keep
[ shift-mod ]
[ [ - ] keep shift-mod ] 3bi bitor ; inline
[ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
HINTS: bitroll-32 bignum fixnum ;
: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
HINTS: bitroll-64 bignum fixnum ;
! 32-bit arithmetic
: w+ ( int int -- int ) + 32 bits ; inline
: w- ( int int -- int ) - 32 bits ; inline

17
basis/opengl/opengl.factor
View File

@ -71,18 +71,22 @@ MACRO: all-enabled-client-state ( seq quot -- )
line-vertices GL_LINES 0 2 glDrawArrays ;
: (rect-vertices) ( dim -- vertices )
#! We use GL_LINE_STRIP with a duplicated first vertex
#! instead of GL_LINE_LOOP to work around a bug in Apple's
#! X3100 driver.
{
[ drop 0.5 0.5 ]
[ first 0.3 - 0.5 ]
[ [ first 0.3 - ] [ second 0.3 - ] bi ]
[ second 0.3 - 0.5 swap ]
} cleave 8 narray >c-float-array ;
[ drop 0.5 0.5 ]
} cleave 10 narray >c-float-array ;
: rect-vertices ( dim -- )
(rect-vertices) gl-vertex-pointer ;
: (gl-rect) ( -- )
GL_LINE_LOOP 0 4 glDrawArrays ;
GL_LINE_STRIP 0 5 glDrawArrays ;
: gl-rect ( dim -- )
rect-vertices (gl-rect) ;
@ -119,7 +123,16 @@ MACRO: all-enabled-client-state ( seq quot -- )
: circle-points ( loc dim steps -- points )
circle-steps unit-circle adjust-points scale-points ;
: close-path ( points -- points' )
dup first suffix ;
: circle-vertices ( loc dim steps -- vertices )
#! We use GL_LINE_STRIP with a duplicated first vertex
#! instead of GL_LINE_LOOP to work around a bug in Apple's
#! X3100 driver.
circle-points close-path concat >c-float-array ;
: fill-circle-vertices ( loc dim steps -- vertices )
circle-points concat >c-float-array ;
: (gen-gl-object) ( quot -- id )

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

@ -8,6 +8,6 @@ ARTICLE: "present" "Converting objects to human-readable strings"
HELP: present
{ $values { "object" object } { "string" string } }
{ $contract "Outputs a human-readable string from an object." }
{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $link "urls" } " vocabularies." } ;
{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $vocab-link "urls" } " vocabularies." } ;
ABOUT: "present"

2
basis/regexp/backend/backend.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors hashtables kernel math state-tables vectors ;
USING: accessors hashtables kernel math vectors ;
IN: regexp.backend
TUPLE: regexp

10
basis/regexp/classes/classes.factor
View File

@ -7,6 +7,7 @@ IN: regexp.classes
GENERIC: class-member? ( obj class -- ? )
M: word class-member? ( obj class -- ? ) 2drop f ;
M: integer class-member? ( obj class -- ? ) 2drop f ;
M: character-class-range class-member? ( obj class -- ? )
@ -60,3 +61,12 @@ M: java-blank-class class-member? ( obj class -- ? )
M: unmatchable-class class-member? ( obj class -- ? )
2drop f ;
M: terminator-class class-member? ( obj class -- ? )
drop {
[ CHAR: \r = ]
[ CHAR: \n = ]
[ CHAR: \u000085 = ]
[ CHAR: \u002028 = ]
[ CHAR: \u002029 = ]
} 1|| ;

3
basis/regexp/dfa/dfa.factor
View File

@ -43,7 +43,8 @@ IN: regexp.dfa
dupd pop dup pick find-transitions rot
[
[ [ find-closure ] 2keep nip dupd add-todo-state ] 3keep
>r swapd transition make-transition r> dfa-table>> add-transition
[ swapd transition make-transition ] dip
dfa-table>> add-transition
] curry with each
new-transitions
] if-empty ;

32
basis/regexp/nfa/nfa.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs grouping kernel regexp.backend
locals math namespaces regexp.parser sequences state-tables fry
quotations math.order math.ranges vectors unicode.categories
regexp.utils regexp.transition-tables words sets ;
locals math namespaces regexp.parser sequences fry quotations
math.order math.ranges vectors unicode.categories regexp.utils
regexp.transition-tables words sets ;
IN: regexp.nfa
SYMBOL: negation-mode
@ -18,6 +18,12 @@ SINGLETON: lookbehind-on INSTANCE: lookbehind-on traversal-flag
SINGLETON: lookbehind-off INSTANCE: lookbehind-off traversal-flag
SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag
SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag
SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag
: add-global-flag ( flag -- )
current-regexp get nfa-table>> flags>> conjoin ;
: next-state ( regexp -- state )
[ state>> ] [ [ 1+ ] change-state drop ] bi ;
@ -135,7 +141,25 @@ M: non-capture-group nfa-node ( node -- )
M: reluctant-kleene-star nfa-node ( node -- )
term>> <kleene-star> nfa-node ;
!
M: beginning-of-line nfa-node ( node -- )
drop
eps literal-transition add-simple-entry
beginning-of-line add-global-flag ;
M: end-of-line nfa-node ( node -- )
drop
eps literal-transition add-simple-entry
end-of-line add-global-flag ;
M: beginning-of-input nfa-node ( node -- )
drop
eps literal-transition add-simple-entry
beginning-of-input add-global-flag ;
M: end-of-input nfa-node ( node -- )
drop
eps literal-transition add-simple-entry
end-of-input add-global-flag ;
M: negation nfa-node ( node -- )
negation-mode inc

102
basis/regexp/parser/parser.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays assocs combinators io io.streams.string
kernel math math.parser namespaces qualified sets
quotations sequences splitting symbols vectors math.order
unicode.categories strings regexp.backend regexp.utils
unicode.case words ;
unicode.case words locals ;
IN: regexp.parser
FROM: math.ranges => [a,b] ;
@ -44,18 +44,21 @@ TUPLE: character-class-range from to ; INSTANCE: character-class-range node
SINGLETON: epsilon INSTANCE: epsilon node
SINGLETON: any-char INSTANCE: any-char node
SINGLETON: any-char-no-nl INSTANCE: any-char-no-nl node
SINGLETON: front-anchor INSTANCE: front-anchor node
SINGLETON: back-anchor INSTANCE: back-anchor node
SINGLETON: beginning-of-input INSTANCE: beginning-of-input node
SINGLETON: end-of-input INSTANCE: end-of-input node
SINGLETON: beginning-of-line INSTANCE: beginning-of-line node
SINGLETON: end-of-line INSTANCE: end-of-line node
TUPLE: option-on option ; INSTANCE: option-on node
TUPLE: option-off option ; INSTANCE: option-off node
SINGLETONS: unix-lines dotall multiline comments case-insensitive unicode-case reversed-regexp ;
SINGLETONS: unix-lines dotall multiline comments case-insensitive
unicode-case reversed-regexp ;
SINGLETONS: letter-class LETTER-class Letter-class digit-class
alpha-class non-newline-blank-class
ascii-class punctuation-class java-printable-class blank-class
control-character-class hex-digit-class java-blank-class c-identifier-class
unmatchable-class ;
unmatchable-class terminator-class word-boundary-class ;
SINGLETONS: beginning-of-group end-of-group
beginning-of-character-class end-of-character-class
@ -84,8 +87,8 @@ left-parenthesis pipe caret dash ;
: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
: <constant> ( obj -- constant )
dup Letter? get-case-insensitive and [
[ ch>lower constant boa ]
[ ch>upper constant boa ] bi 2array <alternation>
[ ch>lower ] [ ch>upper ] bi
[ constant boa ] bi@ 2array <alternation>
] [
constant boa
] if ;
@ -225,26 +228,12 @@ ERROR: invalid-range a b ;
: handle-left-brace ( -- )
parse-repetition
>r 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ r>
[ 2dup [ [ 0 < [ invalid-range ] when ] when* ] bi@ ] dip
[
2dup and [ from-m-to-n ]
[ [ nip at-most-n ] [ at-least-n ] if* ] if
] [ drop 0 max exactly-n ] if ;
SINGLETON: beginning-of-input
SINGLETON: end-of-input
: newlines ( -- obj1 obj2 obj3 )
CHAR: \r <constant>
CHAR: \n <constant>
2dup 2array <concatenation> ;
: beginning-of-line ( -- obj )
beginning-of-input newlines 4array <alternation> lookbehind boa ;
: end-of-line ( -- obj )
end-of-input newlines 4array <alternation> lookahead boa ;
: handle-front-anchor ( -- )
get-multiline beginning-of-line beginning-of-input ? push-stack ;
@ -281,13 +270,26 @@ ERROR: expected-posix-class ;
: parse-control-character ( -- n ) read1 ;
ERROR: bad-escaped-literals seq ;
: parse-escaped-literals ( -- obj )
"\\E" read-until [ bad-escaped-literals ] unless
: parse-til-E ( -- obj )
"\\E" read-until [ bad-escaped-literals ] unless ;
:: (parse-escaped-literals) ( quot: ( obj -- obj' ) -- obj )
parse-til-E
drop1
[ epsilon ] [
[ <constant> ] V{ } map-as
[ quot call <constant> ] V{ } map-as
first|concatenation
] if-empty ;
] if-empty ; inline
: parse-escaped-literals ( -- obj )
[ ] (parse-escaped-literals) ;
: lower-case-literals ( -- obj )
[ ch>lower ] (parse-escaped-literals) ;
: upper-case-literals ( -- obj )
[ ch>upper ] (parse-escaped-literals) ;
: parse-escaped ( -- obj )
read1
@ -299,12 +301,12 @@ ERROR: bad-escaped-literals seq ;
{ CHAR: a [ HEX: 7 <constant> ] }
{ CHAR: e [ HEX: 1b <constant> ] }
{ CHAR: d [ digit-class ] }
{ CHAR: D [ digit-class <negation> ] }
{ CHAR: s [ java-blank-class ] }
{ CHAR: S [ java-blank-class <negation> ] }
{ CHAR: w [ c-identifier-class ] }
{ CHAR: W [ c-identifier-class <negation> ] }
{ CHAR: s [ java-blank-class ] }
{ CHAR: S [ java-blank-class <negation> ] }
{ CHAR: d [ digit-class ] }
{ CHAR: D [ digit-class <negation> ] }
{ CHAR: p [ parse-posix-class ] }
{ CHAR: P [ parse-posix-class <negation> ] }
@ -313,13 +315,19 @@ ERROR: bad-escaped-literals seq ;
{ CHAR: 0 [ parse-octal <constant> ] }
{ CHAR: c [ parse-control-character ] }
! { CHAR: b [ handle-word-boundary ] }
! { CHAR: B [ handle-word-boundary <negation> ] }
! { CHAR: A [ handle-beginning-of-input ] }
! { CHAR: G [ end of previous match ] }
! { CHAR: Z [ handle-end-of-input ] }
! { CHAR: z [ handle-end-of-input ] } ! except for terminator
{ CHAR: Q [ parse-escaped-literals ] }
! { CHAR: b [ word-boundary-class ] }
! { CHAR: B [ word-boundary-class <negation> ] }
! { CHAR: A [ handle-beginning-of-input ] }
! { CHAR: z [ handle-end-of-input ] }
! { CHAR: Z [ handle-end-of-input ] } ! plus a final terminator
! m//g mode
! { CHAR: G [ end of previous match ] }
! Group capture
! { CHAR: 1 [ CHAR: 1 <constant> ] }
! { CHAR: 2 [ CHAR: 2 <constant> ] }
! { CHAR: 3 [ CHAR: 3 <constant> ] }
@ -330,7 +338,11 @@ ERROR: bad-escaped-literals seq ;
! { CHAR: 8 [ CHAR: 8 <constant> ] }
! { CHAR: 9 [ CHAR: 9 <constant> ] }
{ CHAR: Q [ parse-escaped-literals ] }
! Perl extensions
! can't do \l and \u because \u is already a 4-hex
{ CHAR: L [ lower-case-literals ] }
{ CHAR: U [ upper-case-literals ] }
[ <constant> ]
} case ;
@ -372,20 +384,22 @@ DEFER: handle-left-bracket
} case
[ (parse-character-class) ] when ;
: push-constant ( ch -- ) <constant> push-stack ;
: parse-character-class-second ( -- )
read1 {
{ CHAR: [ [ CHAR: [ <constant> push-stack ] }
{ CHAR: ] [ CHAR: ] <constant> push-stack ] }
{ CHAR: - [ CHAR: - <constant> push-stack ] }
{ CHAR: [ [ CHAR: [ push-constant ] }
{ CHAR: ] [ CHAR: ] push-constant ] }
{ CHAR: - [ CHAR: - push-constant ] }
[ push1 ]
} case ;
: parse-character-class-first ( -- )
read1 {
{ CHAR: ^ [ caret push-stack parse-character-class-second ] }
{ CHAR: [ [ CHAR: [ <constant> push-stack ] }
{ CHAR: ] [ CHAR: ] <constant> push-stack ] }
{ CHAR: - [ CHAR: - <constant> push-stack ] }
{ CHAR: [ [ CHAR: [ push-constant ] }
{ CHAR: ] [ CHAR: ] push-constant ] }
{ CHAR: - [ CHAR: - push-constant ] }
[ push1 ]
} case ;
@ -419,7 +433,7 @@ DEFER: handle-left-bracket
drop
handle-back-anchor f
] [
<constant> push-stack t
push-constant t
] if
]
} case ;

6
basis/regexp/regexp-docs.factor
View File

@ -6,9 +6,3 @@ IN: regexp
HELP: <regexp>
{ $values { "string" string } { "regexp" regexp } }
{ $description "Compiles a regular expression into a DFA and returns this object. Regular expressions only have to be compiled once and can then be used multiple times to match input strings." } ;
HELP: <iregexp>
{ $values { "string" string } { "regexp" regexp } }
{ $description "Compiles a case-insensitive regular expression into a DFA and returns this object. Otherwise, exactly the same as " { $link <regexp> } } ;
{ <regexp> <iregexp> } related-words

165
basis/regexp/regexp-tests.factor
View File

@ -45,6 +45,7 @@ IN: regexp-tests
! Off by default.
[ f ] [ "\n" "." <regexp> matches? ] unit-test
[ t ] [ "\n" "(?s)." <regexp> matches? ] unit-test
[ t ] [ "\n" R/ ./s matches? ] unit-test
[ f ] [ "\n\n" "(?s).(?-s)." <regexp> matches? ] unit-test
[ f ] [ "" ".+" <regexp> matches? ] unit-test
@ -210,34 +211,34 @@ IN: regexp-tests
[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
[ t ] [ "aaa" "AAA" <iregexp> matches? ] unit-test
[ f ] [ "aax" "AAA" <iregexp> matches? ] unit-test
[ t ] [ "aaa" "A*" <iregexp> matches? ] unit-test
[ f ] [ "aaba" "A*" <iregexp> matches? ] unit-test
[ t ] [ "b" "[AB]" <iregexp> matches? ] unit-test
[ f ] [ "c" "[AB]" <iregexp> matches? ] unit-test
[ t ] [ "c" "[A-Z]" <iregexp> matches? ] unit-test
[ f ] [ "3" "[A-Z]" <iregexp> matches? ] unit-test
[ t ] [ "aaa" R/ AAA/i matches? ] unit-test
[ f ] [ "aax" R/ AAA/i matches? ] unit-test
[ t ] [ "aaa" R/ A*/i matches? ] unit-test
[ f ] [ "aaba" R/ A*/i matches? ] unit-test
[ t ] [ "b" R/ [AB]/i matches? ] unit-test
[ f ] [ "c" R/ [AB]/i matches? ] unit-test
[ t ] [ "c" R/ [A-Z]/i matches? ] unit-test
[ f ] [ "3" R/ [A-Z]/i matches? ] unit-test
[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "a" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "A" "(?i)a" <regexp> matches? ] unit-test
[ t ] [ "a" "(?-i)a" <iregexp> matches? ] unit-test
[ t ] [ "a" "(?-i)a" <iregexp> matches? ] unit-test
[ f ] [ "A" "(?-i)a" <iregexp> matches? ] unit-test
[ f ] [ "A" "(?-i)a" <iregexp> matches? ] unit-test
[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
[ t ] [ "a" R/ (?-i)a/i matches? ] unit-test
[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
[ f ] [ "A" R/ (?-i)a/i matches? ] unit-test
[ f ] [ "A" "[a-z]" <regexp> matches? ] unit-test
[ t ] [ "A" "[a-z]" <iregexp> matches? ] unit-test
[ t ] [ "A" R/ [a-z]/i matches? ] unit-test
[ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
[ t ] [ "A" "\\p{Lower}" <iregexp> matches? ] unit-test
[ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test
[ t ] [ "abc" <reversed> "abc" <rregexp> matches? ] unit-test
[ t ] [ "abc" <reversed> "a[bB][cC]" <rregexp> matches? ] unit-test
[ t ] [ "adcbe" "a(?r)(bcd)(?-r)e" <rregexp> matches? ] unit-test
[ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
[ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/r matches? ] unit-test
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
@ -253,7 +254,7 @@ IN: regexp-tests
[ ] [ "(\\$[\\p{XDigit}]|[\\p{Digit}])" <regexp> drop ] unit-test
! Comment
! Comment inside a regular expression
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test
@ -283,32 +284,90 @@ IN: regexp-tests
[ { "ABC" "DEF" "GHI" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test
[ 3 ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ count-matches ] unit-test
[ 0 ]
[ "123" R/ [A-Z]+/ count-matches ] unit-test
[ "1.2.3.4" ]
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match >string ] unit-test
! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
! [ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
! [ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
! [ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
! [ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
! [ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
! Bug in parsing word
[ t ] [ "a" R' a' matches? ] unit-test
! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
[ t ] [ "a" R/ ^a/ matches? ] unit-test
[ f ] [ "\na" R/ ^a/ matches? ] unit-test
[ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
[ f ] [ "\ra" R/ ^a/ matches? ] unit-test
[ t ] [ "a" R/ a$/ matches? ] unit-test
[ f ] [ "a\n" R/ a$/ matches? ] unit-test
[ f ] [ "a\r" R/ a$/ matches? ] unit-test
[ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
! [ t ] [ "a" R/ \Aa/ matches? ] unit-test
! [ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
! [ f ] [ "\r\na" R/ \Aa/ matches? ] unit-test
! [ f ] [ "\ra" R/ \Aa/ matches? ] unit-test
! [ t ] [ "a" R/ \Aa/m matches? ] unit-test
! [ f ] [ "\na" R/ \Aaa/m matches? ] unit-test
! [ f ] [ "\r\na" R/ \Aa/m matches? ] unit-test
! [ f ] [ "\ra" R/ \Aa/m matches? ] unit-test
! [ t ] [ "\r\n\n\n\nam" R/ ^am/m matches? ] unit-test
! [ t ] [ "a" R/ \Aa\z/m matches? ] unit-test
! [ f ] [ "a\n" R/ \Aa\z/m matches? ] unit-test
! [ t ] [ "a\r\n" R/ \Aa\Z/m matches? ] unit-test
! [ t ] [ "a\n" R/ \Aa\Z/m matches? ] unit-test
! [ t ] [ "a" R/ \Aa\Z/m matches? ] unit-test
! [ f ] [ "\na" R/ \Aaa\Z/m matches? ] unit-test
! [ f ] [ "\r\na" R/ \Aa\Z/m matches? ] unit-test
! [ f ] [ "\ra" R/ \Aa\Z/m matches? ] unit-test
! [ t ] [ "a" R/ ^a/m matches? ] unit-test
! [ t ] [ "\na" R/ ^a/m matches? ] unit-test
! [ t ] [ "\r\na" R/ ^a/m matches? ] unit-test
! [ t ] [ "\ra" R/ ^a/m matches? ] unit-test
! Convert to lowercase until E
[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test
! Convert to uppercase until E
[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test
[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test
! [ t ] [ "a" "a$" R/ a$/m matches? ] unit-test
! [ t ] [ "a\n" "a$" R/ a$/m matches? ] unit-test
! [ t ] [ "a\r" "a$" R/ a$/m matches? ] unit-test
! [ t ] [ "a\r\n" "a$" R/ a$/m matches? ] unit-test
! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
! [ t ] [ "foo" "\\bfoo\\b" <regexp> matches? ] unit-test
! [ t ] [ "afoob" "\\Bfoo\\B" <regexp> matches? ] unit-test
! [ t ] [ "afoob" "\\bfoo\\b" <regexp> matches? ] unit-test
! [ f ] [ "foo" "\\Bfoo\\B" <regexp> matches? ] unit-test
! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
@ -323,39 +382,29 @@ IN: regexp-tests
! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
! [ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
! [ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
! [ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
! [ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
! [ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
! [ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
! Bug in parsing word
! [ t ] [ "a" R' a' matches? ] unit-test
! "ab" "a(?=b*)" <regexp> match
! "abbbbbc" "a(?=b*c)" <regexp> match
! "ab" "a(?=b*)" <regexp> match
! clear "a(?=b*)" <regexp> "ab" over match
! clear "a(?=b*c)" <regexp> "abbbbbc" over match
! clear "a(?=b*)" <regexp> "ab" over match
! "baz" "(az)(?<=b)" <regexp> first-match
! "cbaz" "a(?<=b*)" <regexp> first-match
! "baz" "a(?<=b)" <regexp> first-match
! clear "^a" <regexp> "a" over match
! clear "^a" <regexp> "\na" over match
! clear "^a" <regexp> "\r\na" over match
! clear "^a" <regexp> "\ra" over match
! "baz" "a(?<!b)" <regexp> first-match
! "caz" "a(?<!b)" <regexp> first-match
! clear "a$" <regexp> "a" over match
! clear "a$" <regexp> "a\n" over match
! clear "a$" <regexp> "a\r" over match
! clear "a$" <regexp> "a\r\n" over match
! "(az)(?<=b)" <regexp> "baz" over first-match
! "a(?<=b*)" <regexp> "cbaz" over first-match
! "a(?<=b)" <regexp> "baz" over first-match
! "a(?<!b)" <regexp> "baz" over first-match
! "a(?<!b)" <regexp> "caz" over first-match
! "a(?=bcdefg)bcd" <regexp> "abcdefg" over first-match
! "a(?#bcdefg)bcd" <regexp> "abcdefg" over first-match
! "a(?:bcdefg)" <regexp> "abcdefg" over first-match
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
! "a(?<=b)" <regexp> "caba" over first-match
! "abcdefg" "a(?=bcdefg)bcd" <regexp> first-match
! "abcdefg" "a(?#bcdefg)bcd" <regexp> first-match
! "abcdefg" "a(?:bcdefg)" <regexp> first-match
! "caba" "a(?<=b)" <regexp> first-match
! capture group 1: "aaaa" 2: ""
! "aaaa" "(a*)(a*)" <regexp> match*

105
basis/regexp/regexp.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel math sequences
USING: accessors combinators kernel math sequences strings
sets assocs prettyprint.backend make lexer namespaces parser
arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
regexp.dfa regexp.traversal regexp.transition-tables splitting ;
regexp.dfa regexp.traversal regexp.transition-tables splitting
sorting ;
IN: regexp
: default-regexp ( string -- regexp )
@ -73,42 +74,9 @@ IN: regexp
[ dup ] swap '[ _ next-match ] [ ] produce nip harvest ;
: count-matches ( string regexp -- n )
all-matches length 1- ;
all-matches length ;
: initial-option ( regexp option -- regexp' )
over options>> conjoin ;
: <regexp> ( string -- regexp )
default-regexp construct-regexp ;
: <iregexp> ( string -- regexp )
default-regexp
case-insensitive initial-option
construct-regexp ;
: <rregexp> ( string -- regexp )
default-regexp
reversed-regexp initial-option
construct-regexp ;
: parsing-regexp ( accum end -- accum )
lexer get dup skip-blank
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
lexer get dup still-parsing-line?
[ (parse-token) ] [ drop f ] if
"i" = [ <iregexp> ] [ <regexp> ] if parsed ;
: R! CHAR: ! parsing-regexp ; parsing
: R" CHAR: " parsing-regexp ; parsing
: R# CHAR: # parsing-regexp ; parsing
: R' CHAR: ' parsing-regexp ; parsing
: R( CHAR: ) parsing-regexp ; parsing
: R/ CHAR: / parsing-regexp ; parsing
: R@ CHAR: @ parsing-regexp ; parsing
: R[ CHAR: ] parsing-regexp ; parsing
: R` CHAR: ` parsing-regexp ; parsing
: R{ CHAR: } parsing-regexp ; parsing
: R| CHAR: | parsing-regexp ; parsing
<PRIVATE
: find-regexp-syntax ( string -- prefix suffix )
{
@ -125,14 +93,67 @@ IN: regexp
{ "R| " "|" }
} swap [ subseq? not nip ] curry assoc-find drop ;
: option? ( option regexp -- ? )
options>> key? ;
ERROR: unknown-regexp-option option ;
: option>ch ( option -- string )
{
{ case-insensitive [ CHAR: i ] }
{ multiline [ CHAR: m ] }
{ reversed-regexp [ CHAR: r ] }
{ dotall [ CHAR: s ] }
[ unknown-regexp-option ]
} case ;
: ch>option ( ch -- option )
{
{ CHAR: i [ case-insensitive ] }
{ CHAR: m [ multiline ] }
{ CHAR: r [ reversed-regexp ] }
{ CHAR: s [ dotall ] }
[ unknown-regexp-option ]
} case ;
: string>options ( string -- options )
[ ch>option dup ] H{ } map>assoc ;
: options>string ( options -- string )
keys [ option>ch ] map natural-sort >string ;
PRIVATE>
: <optioned-regexp> ( string option-string -- regexp )
[ default-regexp ] [ string>options ] bi* >>options
construct-regexp ;
: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
<PRIVATE
: parsing-regexp ( accum end -- accum )
lexer get dup skip-blank
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
lexer get dup still-parsing-line?
[ (parse-token) ] [ drop f ] if
<optioned-regexp> parsed ;
PRIVATE>
: R! CHAR: ! parsing-regexp ; parsing
: R" CHAR: " parsing-regexp ; parsing
: R# CHAR: # parsing-regexp ; parsing
: R' CHAR: ' parsing-regexp ; parsing
: R( CHAR: ) parsing-regexp ; parsing
: R/ CHAR: / parsing-regexp ; parsing
: R@ CHAR: @ parsing-regexp ; parsing
: R[ CHAR: ] parsing-regexp ; parsing
: R` CHAR: ` parsing-regexp ; parsing
: R{ CHAR: } parsing-regexp ; parsing
: R| CHAR: | parsing-regexp ; parsing
M: regexp pprint*
[
[
dup raw>>
dup find-regexp-syntax swap % swap % %
case-insensitive swap option? [ "i" % ] when
[ raw>> dup find-regexp-syntax swap % swap % % ]
[ options>> options>string % ] bi
] "" make
] keep present-text ;

7
basis/regexp/transition-tables/transition-tables.factor
View File

@ -25,12 +25,13 @@ TUPLE: default ;
: <default-transition> ( from to -- transition )
t default-transition make-transition ;
TUPLE: transition-table transitions start-state final-states ;
TUPLE: transition-table transitions start-state final-states flags ;
: <transition-table> ( -- transition-table )
transition-table new
H{ } clone >>transitions
H{ } clone >>final-states ;
H{ } clone >>final-states
H{ } clone >>flags ;
: maybe-initialize-key ( key hashtable -- )
2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
@ -40,7 +41,7 @@ TUPLE: transition-table transitions start-state final-states ;
2dup [ to>> ] dip maybe-initialize-key
[ [ to>> ] [ obj>> ] [ from>> ] tri ] dip
2dup at* [ 2nip insert-at ]
[ drop >r >r H{ } clone [ insert-at ] keep r> r> set-at ] if ;
[ drop [ H{ } clone [ insert-at ] keep ] 2dip set-at ] if ;
: add-transition ( transition transition-table -- )
transitions>> set-transition ;

71
basis/regexp/traversal/traversal.factor
View File

@ -17,6 +17,7 @@ TUPLE: dfa-traverser
capture-group-index
last-state current-state
text
match-failed?
start-index current-index
matches ;
@ -37,14 +38,20 @@ TUPLE: dfa-traverser
H{ } clone >>captured-groups ;
: final-state? ( dfa-traverser -- ? )
[ current-state>> ] [ dfa-table>> final-states>> ] bi
key? ;
[ current-state>> ]
[ dfa-table>> final-states>> ] bi key? ;
: beginning-of-text? ( dfa-traverser -- ? )
current-index>> 0 <= ; inline
: end-of-text? ( dfa-traverser -- ? )
[ current-index>> ] [ text>> length ] bi >= ; inline
: text-finished? ( dfa-traverser -- ? )
{
[ current-state>> empty? ]
[ [ current-index>> ] [ text>> length ] bi >= ]
! [ current-index>> 0 < ]
[ end-of-text? ]
[ match-failed?>> ]
} 1|| ;
: save-final-state ( dfa-straverser -- )
@ -55,8 +62,50 @@ TUPLE: dfa-traverser
dup save-final-state
] when text-finished? ;
: previous-text-character ( dfa-traverser -- ch )
[ text>> ] [ current-index>> 1- ] bi nth ;
: current-text-character ( dfa-traverser -- ch )
[ text>> ] [ current-index>> ] bi nth ;
: next-text-character ( dfa-traverser -- ch )
[ text>> ] [ current-index>> 1+ ] bi nth ;
GENERIC: flag-action ( dfa-traverser flag -- )
M: beginning-of-input flag-action ( dfa-traverser flag -- )
drop
dup beginning-of-text? [ t >>match-failed? ] unless drop ;
M: end-of-input flag-action ( dfa-traverser flag -- )
drop
dup end-of-text? [ t >>match-failed? ] unless drop ;
M: beginning-of-line flag-action ( dfa-traverser flag -- )
drop
dup {
[ beginning-of-text? ]
[ previous-text-character terminator-class class-member? ]
} 1|| [ t >>match-failed? ] unless drop ;
M: end-of-line flag-action ( dfa-traverser flag -- )
drop
dup {
[ end-of-text? ]
[ next-text-character terminator-class class-member? ]
} 1|| [ t >>match-failed? ] unless drop ;
M: word-boundary flag-action ( dfa-traverser flag -- )
drop
dup {
[ end-of-text? ]
[ current-text-character terminator-class class-member? ]
} 1|| [ t >>match-failed? ] unless drop ;
M: lookahead-on flag-action ( dfa-traverser flag -- )
drop
lookahead-counters>> 0 swap push ;
@ -110,11 +159,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
[ [ 1+ ] change-current-index ]
[ [ 1- ] change-current-index ] if
dup current-state>> >>last-state
] dip
first >>current-state ;
: match-failed ( dfa-traverser -- dfa-traverser )
V{ } clone >>matches ;
] [ first ] bi* >>current-state ;
: match-literal ( transition from-state table -- to-state/f )
transitions>> at at ;
@ -131,11 +176,9 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
: setup-match ( match -- obj state dfa-table )
{
[ current-index>> ] [ text>> ]
[ current-state>> ] [ dfa-table>> ]
} cleave
[ nth ] 2dip ;
[ [ current-index>> ] [ text>> ] bi nth ]
[ current-state>> ]
[ dfa-table>> ] tri ;
: do-match ( dfa-traverser -- dfa-traverser )
dup process-flags

6
basis/sequences/deep/deep-tests.factor
View File

@ -4,11 +4,11 @@ IN: sequences.deep.tests
[ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test
[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find-from ] unit-test
[ "foo" t ] [ { { "foo" } "bar" } [ string? ] (deep-find) ] unit-test
[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find-from ] unit-test
[ f f ] [ { { "foo" } "bar" } [ number? ] (deep-find) ] unit-test
[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find-from ] unit-test
[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] (deep-find) ] unit-test
: change-something ( seq -- newseq )
dup array? [ "hi" suffix ] [ "hello" append ] if ;

6
basis/stack-checker/known-words/known-words.factor
View File

@ -614,3 +614,9 @@ M: object infer-call*
\ modify-code-heap { array object } { } define-primitive
\ unimplemented { } { } define-primitive
\ gc-reset { } { } define-primitive
\ gc-stats { } { array } define-primitive
\ jit-compile { quotation } { } define-primitive

1
basis/state-tables/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

56
basis/state-tables/state-tables-tests.factor
View File

@ -1,56 +0,0 @@
USING: kernel state-tables tools.test ;
IN: state-tables.tests
: test-table
<table>
"a" "c" "z" <entry> over set-entry
"a" "o" "y" <entry> over set-entry
"a" "l" "x" <entry> over set-entry
"b" "o" "y" <entry> over set-entry
"b" "l" "x" <entry> over set-entry
"b" "s" "u" <entry> over set-entry ;
[
T{
table
f
H{
{ "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } }
{ "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
}
H{ { "l" t } { "s" t } { "c" t } { "o" t } }
f
H{ }
}
] [ test-table ] unit-test
[ "x" t ] [ "a" "l" test-table get-entry ] unit-test
[ "har" t ] [
"a" "z" "har" <entry> test-table [ set-entry ] keep
>r "a" "z" r> get-entry
] unit-test
: vector-test-table
<vector-table>
"a" "c" "z" <entry> over add-entry
"a" "c" "r" <entry> over add-entry
"a" "o" "y" <entry> over add-entry
"a" "l" "x" <entry> over add-entry
"b" "o" "y" <entry> over add-entry
"b" "l" "x" <entry> over add-entry
"b" "s" "u" <entry> over add-entry ;
[
T{ vector-table f
H{
{ "a"
H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } }
{ "b"
H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
}
H{ { "l" t } { "s" t } { "c" t } { "o" t } }
f
H{ }
}
] [ vector-test-table ] unit-test

123
basis/state-tables/state-tables.factor
View File

@ -1,123 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make sequences vectors assocs accessors ;
IN: state-tables
TUPLE: table rows columns start-state final-states ;
TUPLE: entry row-key column-key value ;
GENERIC: add-entry ( entry table -- )
: make-table ( class -- obj )
new
H{ } clone >>rows
H{ } clone >>columns
H{ } clone >>final-states ;
: <table> ( -- obj )
table make-table ;
C: <entry> entry
: (add-row) ( row-key table -- row )
2dup rows>> at* [
2nip
] [
drop H{ } clone [ -rot rows>> set-at ] keep
] if ;
: add-row ( row-key table -- )
(add-row) drop ;
: add-column ( column-key table -- )
t -rot columns>> set-at ;
: set-row ( row row-key table -- )
rows>> set-at ;
: lookup-row ( row-key table -- row/f ? )
rows>> at* ;
: row-exists? ( row-key table -- ? )
lookup-row nip ;
: lookup-column ( column-key table -- column/f ? )
columns>> at* ;
: column-exists? ( column-key table -- ? )
lookup-column nip ;
ERROR: no-row key ;
ERROR: no-column key ;
: get-row ( row-key table -- row )
dupd lookup-row [
nip
] [
drop no-row
] if ;
: get-column ( column-key table -- column )
dupd lookup-column [
nip
] [
drop no-column
] if ;
: get-entry ( row-key column-key table -- obj ? )
swapd lookup-row [
at*
] [
2drop f f
] if ;
: (set-entry) ( entry table -- value column-key row )
[ >r column-key>> r> add-column ] 2keep
dupd >r row-key>> r> (add-row)
>r [ value>> ] keep column-key>> r> ;
: set-entry ( entry table -- )
(set-entry) set-at ;
: delete-entry ( entry table -- )
>r [ column-key>> ] [ row-key>> ] bi r>
lookup-row [ delete-at ] [ 2drop ] if ;
: swap-rows ( row-key1 row-key2 table -- )
[ tuck get-row >r get-row r> ] 3keep
>r >r rot r> r> [ set-row ] keep set-row ;
: member?* ( obj obj -- bool )
2dup = [ 2drop t ] [ member? ] if ;
: find-by-column ( column-key data table -- seq )
swapd 2dup lookup-column 2drop
[
rows>> [
pick swap at* [
>r pick r> member?* [ , ] [ drop ] if
] [
2drop
] if
] assoc-each
] { } make 2nip ;
TUPLE: vector-table < table ;
: <vector-table> ( -- obj )
vector-table make-table ;
: add-hash-vector ( value key hash -- )
2dup at* [
dup vector? [
2nip push
] [
V{ } clone [ push ] keep
-rot >r >r [ push ] keep r> r> set-at
] if
] [
drop set-at
] if ;
M: vector-table add-entry ( entry table -- )
(set-entry) add-hash-vector ;

2
basis/threads/threads.factor
View File

@ -89,7 +89,7 @@ PRIVATE>
f >>state
check-registered 2array run-queue push-front ;
: sleep-time ( -- ms/f )
: sleep-time ( -- us/f )
{
{ [ run-queue deque-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }

19
basis/tools/deploy/shaker/shaker.factor
View File

@ -321,20 +321,27 @@ IN: tools.deploy.shaker
] with-compilation-unit
] unless ;
: compress ( pred string -- )
: compress ( pred post-process string -- )
"Compressing " prepend show
instances
dup H{ } clone [ [ ] cache ] curry map
[ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
become ; inline
: compress-byte-arrays ( -- )
[ byte-array? ] "byte arrays" compress ;
[ byte-array? ] [ ] "byte arrays" compress ;
: remain-compiled ( old new -- old new )
#! Quotations which were formerly compiled must remain
#! compiled.
2dup [
2dup [ compiled>> ] [ compiled>> not ] bi* and
[ nip jit-compile ] [ 2drop ] if
] 2each ;
: compress-quotations ( -- )
[ quotation? ] "quotations" compress ;
[ quotation? ] [ remain-compiled ] "quotations" compress ;
: compress-strings ( -- )
[ string? ] "strings" compress ;
[ string? ] [ ] "strings" compress ;
: finish-deploy ( final-image -- )
"Finishing up" show

4
basis/ui/gadgets/buttons/buttons.factor
View File

@ -177,7 +177,7 @@ PRIVATE>
M: radio-paint recompute-pen
swap dim>>
[ { 4 4 } swap { 9 9 } v- circle-steps circle-vertices >>interior-vertices ]
[ { 4 4 } swap { 9 9 } v- circle-steps fill-circle-vertices >>interior-vertices ]
[ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
drop ;
@ -194,7 +194,7 @@ M: radio-paint draw-interior
M: radio-paint draw-boundary
[ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
GL_LINE_LOOP 0 circle-steps glDrawArrays ;
GL_LINE_STRIP 0 circle-steps 1+ glDrawArrays ;
:: radio-knob-theme ( gadget -- gadget )
[let | radio-paint [ black <radio-paint> ] |

3
basis/ui/gadgets/canvas/canvas.factor
View File

@ -12,8 +12,7 @@ TUPLE: canvas < gadget dlist ;
: delete-canvas-dlist ( canvas -- )
[ find-gl-context ]
[ dlist>> [ delete-dlist ] when* ]
[ f >>dlist drop ] tri ;
[ [ [ delete-dlist ] when* f ] change-dlist drop ] bi ;
: make-canvas-dlist ( canvas quot -- dlist )
[ drop ] [ GL_COMPILE swap make-dlist ] 2bi

65
basis/ui/gadgets/editors/editors.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents io kernel math models
namespaces make opengl opengl.gl sequences strings io.styles
math.vectors sorting colors combinators assocs math.order fry
calendar alarms ui.clipboards ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
ui.render ui.gestures math.geometry.rect ;
namespaces locals fry make opengl opengl.gl sequences strings
io.styles math.vectors sorting colors combinators assocs
math.order fry calendar alarms ui.clipboards ui.commands
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
ui.gadgets.wrappers ui.render ui.gestures math.geometry.rect ;
IN: ui.gadgets.editors
TUPLE: editor < gadget
@ -104,14 +104,20 @@ M: editor ungraft*
editor-font* "" string-height ;
: y>line ( y editor -- line# )
[ line-height / >fixnum ] keep model>> validate-line ;
line-height / >fixnum ;
: point>loc ( point editor -- loc )
[
[ first2 ] dip tuck y>line dup ,
[ dup editor-font* ] dip
rot editor-line x>offset ,
] { } make ;
:: point>loc ( point editor -- loc )
point second editor y>line {
{ [ dup 0 < ] [ drop { 0 0 } ] }
{ [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
[| n |
n
point first
editor editor-font*
n editor editor-line
x>offset 2array
]
} cond ;
: clicked-loc ( editor -- loc )
[ hand-rel ] keep point>loc ;
@ -141,8 +147,8 @@ M: editor ungraft*
line-height * ;
: caret-loc ( editor -- loc )
[ editor-caret* ] keep 2dup loc>x
rot first rot line>y 2array ;
[ editor-caret* ] keep
[ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
: caret-dim ( editor -- dim )
line-height 0 swap 2array ;
@ -175,12 +181,16 @@ M: editor ungraft*
[ font>> ] dip { 0 0 } draw-string ;
: first-visible-line ( editor -- n )
clip get rect-loc second origin get second -
swap y>line ;
[
[ clip get rect-loc second origin get second - ] dip
y>line
] keep model>> validate-line ;
: last-visible-line ( editor -- n )
clip get rect-extent nip second origin get second -
swap y>line 1+ ;
[
[ clip get rect-extent nip second origin get second - ] dip
y>line
] keep model>> validate-line 1+ ;
: with-editor ( editor quot -- )
[
@ -193,9 +203,8 @@ M: editor ungraft*
] with-scope ; inline
: visible-lines ( editor -- seq )
\ first-visible-line get
\ last-visible-line get
rot control-value <slice> ;
[ \ first-visible-line get \ last-visible-line get ] dip
control-value <slice> ;
: with-editor-translation ( n quot -- )
[ line-translation origin get v+ ] dip with-translation ;
@ -313,9 +322,9 @@ M: editor gadget-text* editor-string % ;
: editor-cut ( editor clipboard -- )
dupd gadget-copy remove-selection ;
: delete/backspace ( elt editor quot -- )
: delete/backspace ( editor quot -- )
over gadget-selection? [
drop nip remove-selection
drop remove-selection
] [
[ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
[ drop model>> ]
@ -323,19 +332,19 @@ M: editor gadget-text* editor-string % ;
] if ; inline
: editor-delete ( editor elt -- )
swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
'[ dupd _ next-elt ] delete/backspace ;
: editor-backspace ( editor elt -- )
swap [ over [ rot prev-elt ] dip ] delete/backspace ;
'[ over [ _ prev-elt ] dip ] delete/backspace ;
: editor-select-prev ( editor elt -- )
swap [ rot prev-elt ] change-caret ;
'[ _ prev-elt ] change-caret ;
: editor-prev ( editor elt -- )
dupd editor-select-prev mark>caret ;
: editor-select-next ( editor elt -- )
swap [ rot next-elt ] change-caret ;
'[ _ next-elt ] change-caret ;
: editor-next ( editor elt -- )
dupd editor-select-next mark>caret ;

15
basis/ui/gadgets/frames/frames-tests.factor
View File

@ -1,4 +1,17 @@
USING: accessors kernel namespaces tools.test ui.gadgets
ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ;
IN: ui.gadgets.frames.tests
USING: ui.gadgets.frames ui.gadgets tools.test ;
[ ] [ <frame> layout ] unit-test
[ t ] [
<frame>
"Hello world" <label> @top grid-add
"Hello world" <label> @center grid-add
dup pref-dim "dim1" set
{ 1000 1000 } >>dim
dup layout*
dup pref-dim "dim2" set
drop
"dim1" get "dim2" get =
] unit-test

22
basis/ui/gadgets/frames/frames.factor
View File

@ -1,15 +1,17 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel math namespaces sequences words
splitting grouping math.vectors ui.gadgets.grids ui.gadgets
math.geometry.rect ;
USING: accessors arrays generic kernel math namespaces sequences
words splitting grouping math.vectors ui.gadgets.grids
ui.gadgets math.geometry.rect ;
IN: ui.gadgets.frames
! A frame arranges gadgets in a 3x3 grid, where the center
! gadgets gets left-over space.
TUPLE: frame < grid ;
TUPLE: glue < gadget ;
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
M: glue pref-dim* drop { 0 0 } ;
: <glue> ( -- glue ) glue new-gadget ;
: <frame-grid> ( -- grid ) 9 [ <glue> ] replicate 3 group ;
: @center 1 1 ; inline
: @left 0 1 ; inline
@ -22,13 +24,15 @@ TUPLE: frame < grid ;
: @bottom-left 0 2 ; inline
: @bottom-right 2 2 ; inline
TUPLE: frame < grid ;
: new-frame ( class -- frame )
<frame-grid> swap new-grid ; inline
: <frame> ( -- frame )
frame new-frame ;
: (fill-center) ( n vec -- )
: (fill-center) ( dim vec -- )
[ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
: fill-center ( dim horiz vert -- )
@ -36,4 +40,4 @@ TUPLE: frame < grid ;
M: frame layout*
dup compute-grid
[ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;
[ [ dim>> ] 2dip fill-center ] [ grid-layout ] 3bi ;

3
basis/ui/gadgets/menus/menus.factor
View File

@ -46,7 +46,6 @@ M: menu-glass layout* gadget-child prefer ;
faint-boundary ;
: <commands-menu> ( hook target commands -- gadget )
<filled-pile>
-roll
[ <filled-pile> ] 3dip
[ <menu-item> add-gadget ] with with each
5 <border> menu-theme ;

29
basis/ui/render/render.factor
View File

@ -168,24 +168,29 @@ M: gradient draw-interior
} cleave ;
! Polygon pen
TUPLE: polygon color vertex-array count ;
TUPLE: polygon color
interior-vertices
interior-count
boundary-vertices
boundary-count ;
: <polygon> ( color points -- polygon )
[ concat >c-float-array ] [ length ] bi polygon boa ;
: draw-polygon ( polygon mode -- )
swap
[ color>> gl-color ]
[ vertex-array>> gl-vertex-pointer ]
[ 0 swap count>> glDrawArrays ]
tri ;
dup close-path [ [ concat >c-float-array ] [ length ] bi ] bi@
polygon boa ;
M: polygon draw-boundary
GL_LINE_LOOP draw-polygon drop ;
nip
[ color>> gl-color ]
[ boundary-vertices>> gl-vertex-pointer ]
[ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
tri ;
M: polygon draw-interior
dup count>> 2 > GL_POLYGON GL_LINES ?
draw-polygon drop ;
nip
[ color>> gl-color ]
[ interior-vertices>> gl-vertex-pointer ]
[ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
tri ;
: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;

62
basis/ui/tools/debugger/debugger.factor
View File

@ -1,35 +1,43 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
models namespaces sequences sequences words continuations
debugger prettyprint ui.tools.traceback help editors ;
USING: accessors arrays hashtables io kernel math models
namespaces sequences sequences words continuations debugger
prettyprint help editors ui ui.commands ui.gestures ui.gadgets
ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
ui.gadgets.scrollers ui.gadgets.panes ui.tools.traceback ;
IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget )
[ name>> ] rot <model> <list> ;
TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
TUPLE: debugger < track restarts ;
<PRIVATE
: <debugger-display> ( restart-list error -- gadget )
: <restart-list> ( debugger -- gadget )
[ restart-hook>> ] [ restarts>> ] bi
[ name>> ] swap <model> <list> ; inline
: <error-pane> ( error -- pane )
<pane> [ [ print-error ] with-pane ] keep ; inline
: <debugger-display> ( debugger -- gadget )
<filled-pile>
<pane>
swapd tuck [ print-error ] with-pane
add-gadget
over error>> <error-pane> add-gadget
swap restart-list>> add-gadget ; inline
swap add-gadget ;
PRIVATE>
: <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track
add-toolbar
-rot <restart-list> >>restarts
dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
swap >>restart-hook
swap >>restarts
swap >>error
error-continuation get >>continuation
dup <restart-list> >>restart-list
dup <debugger-display> <scroller> 1 track-add ;
M: debugger focusable-child* restarts>> ;
M: debugger focusable-child* restart-list>> ;
: debugger-window ( error -- )
#! No restarts for the debugger window
@ -55,16 +63,20 @@ debugger "gestures" f {
{ T{ button-down } request-focus }
} define-command-map
: com-traceback ( -- ) error-continuation get traceback-window ;
: com-traceback ( debugger -- ) continuation>> traceback-window ;
\ com-traceback H{ { +nullary+ t } } define-command
\ com-traceback H{ } define-command
\ :help H{ { +nullary+ t } { +listener+ t } } define-command
: com-help ( debugger -- ) error>> (:help) ;
\ :edit H{ { +nullary+ t } { +listener+ t } } define-command
\ com-help H{ { +listener+ t } } define-command
: com-edit ( debugger -- ) error>> (:edit) ;
\ com-edit H{ { +listener+ t } } define-command
debugger "toolbar" f {
{ T{ key-down f f "s" } com-traceback }
{ T{ key-down f f "h" } :help }
{ T{ key-down f f "e" } :edit }
{ T{ key-down f f "h" } com-help }
{ T{ key-down f f "e" } com-edit }
} define-command-map

12
basis/ui/tools/listener/listener.factor
View File

@ -6,9 +6,9 @@ listener debugger threads boxes concurrency.flags math arrays
generic accessors combinators assocs fry ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
ui.tools.browser ui.tools.interactor ui.tools.inspector
ui.tools.workspace ;
ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
ui.tools.interactor ui.tools.inspector ui.tools.workspace ;
IN: ui.tools.listener
TUPLE: listener-gadget < track input output ;
@ -153,9 +153,9 @@ M: engine-word word-completion-string
dup <listener-input> >>input ;
: <listener-scroller> ( listener -- scroller )
<filled-pile>
over output>> add-gadget
swap input>> add-gadget
<frame>
over output>> @top grid-add
swap input>> @center grid-add
<scroller> ;
: <listener-gadget> ( -- gadget )

2
basis/ui/tools/traceback/traceback.factor
View File

@ -53,4 +53,4 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
"Dynamic variables" open-status-window ;
: traceback-window ( continuation -- )
<model> <traceback-gadget> "Traceback" open-window ;
<model> <traceback-gadget> "Traceback" open-status-window ;

10
basis/ui/traverse/traverse.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces make sequences kernel math arrays io
ui.gadgets generic combinators ;
@ -7,7 +7,7 @@ IN: ui.traverse
TUPLE: node value children ;
: traverse-step ( path gadget -- path' gadget' )
>r unclip r> children>> ?nth ;
[ unclip ] dip children>> ?nth ;
: make-node ( quot -- ) { } make node boa , ; inline
@ -43,7 +43,7 @@ TUPLE: node value children ;
traverse-step traverse-from-path ;
: (traverse-middle) ( frompath topath gadget -- )
>r >r first 1+ r> first r> children>> <slice> % ;
[ first 1+ ] [ first ] [ children>> ] tri* <slice> % ;
: traverse-post ( topath gadget -- )
traverse-step traverse-to-path ;
@ -59,8 +59,8 @@ TUPLE: node value children ;
DEFER: (gadget-subtree)
: traverse-child ( frompath topath gadget -- )
dup -roll [
>r >r rest-slice r> r> traverse-step (gadget-subtree)
[ -rot ] keep [
[ rest-slice ] 2dip traverse-step (gadget-subtree)
] make-node ;
: (gadget-subtree) ( frompath topath gadget -- )

4
basis/ui/windows/windows.factor
View File

@ -9,7 +9,7 @@ windows.user32 windows.opengl32 windows.messages windows.types
windows.nt windows threads libc combinators
combinators.short-circuit continuations command-line shuffle
opengl ui.render ascii math.bitwise locals symbols accessors
math.geometry.rect math.order ascii ;
math.geometry.rect math.order ascii calendar ;
IN: ui.windows
SINGLETON: windows-ui-backend
@ -472,7 +472,7 @@ M: windows-ui-backend do-events
"MSG" malloc-object msg-obj set-global
"Factor-window" utf16n malloc-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
GetDoubleClickTime milliseconds double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
class-name-ptr get-global [ dup f UnregisterClass drop free ] when*

1
core/bootstrap/primitives.factor
View File

@ -533,6 +533,7 @@ tuple
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
{ "jit-compile" "quotations" }
}
[ [ first2 ] dip make-primitive ] each-index

2
core/combinators/combinators.factor
View File

@ -45,7 +45,7 @@ ERROR: no-cond ;
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot )
[ dup callable? [ [ t ] swap 2array ] when ] map
[ dup pair? [ [ t ] swap 2array ] unless ] map
reverse [ no-cond ] swap alist>quot ;
! case

2
core/generic/parser/parser.factor
View File

@ -16,7 +16,7 @@ ERROR: not-in-a-method-error ;
SYMBOL: current-method
: with-method-definition ( method quot -- )
[ dup current-method ] dip with-variable ; inline
over current-method set call current-method off ; inline
: (M:) ( method def -- )
CREATE-METHOD [ parse-definition ] with-method-definition ;

4
core/io/backend/backend.factor
View File

@ -8,7 +8,7 @@ SYMBOL: io-backend
SINGLETON: c-io-backend
c-io-backend io-backend set-global
io-backend global [ c-io-backend or ] change-at
HOOK: init-io io-backend ( -- )
@ -20,7 +20,7 @@ HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
[ utf8 <encoder> output-stream set-global ]
[ utf8 <encoder> error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( ms -- )
HOOK: io-multiplex io-backend ( us -- )
HOOK: normalize-directory io-backend ( str -- newstr )

18
core/kernel/kernel-docs.factor
View File

@ -205,18 +205,18 @@ HELP: 3slip
{ $description "Calls a quotation while hiding the top three stack elements." } ;
HELP: keep
{ $values { "quot" { $quotation "( x -- )" } } { "x" object } }
{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
{ $examples
{ $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ <array> ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" }
} ;
HELP: 2keep
{ $values { "quot" { $quotation "( x y -- )" } } { "x" object } { "y" object } }
{ $values { "quot" { $quotation "( x y -- ... )" } } { "x" object } { "y" object } }
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
HELP: 3keep
{ $values { "quot" { $quotation "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
{ $values { "quot" { $quotation "( x y z -- ... )" } } { "x" object } { "y" object } { "z" object } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: bi
@ -371,7 +371,7 @@ HELP: tri*
} ;
HELP: bi@
{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- )" } } }
{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ... )" } } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." }
{ $examples
"The following two lines are equivalent:"
@ -387,7 +387,7 @@ HELP: bi@
} ;
HELP: 2bi@
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- )" } } }
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- ... )" } } }
{ $description "Applies the quotation to " { $snippet "w" } " and " { $snippet "x" } ", then to " { $snippet "y" } " and " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@ -403,7 +403,7 @@ HELP: 2bi@
} ;
HELP: tri@
{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj -- )" } } }
{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj -- ... )" } } }
{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } ", and finally to " { $snippet "z" } "." }
{ $examples
"The following two lines are equivalent:"
@ -437,7 +437,7 @@ $nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: if*
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" quotation } }
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" quotation } }
{ $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
$nl
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
@ -446,7 +446,7 @@ $nl
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
HELP: when*
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } }
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } }
{ $description "Variant of " { $link if* } " with no false quotation."
$nl
"The following two lines are equivalent:"
@ -460,7 +460,7 @@ HELP: unless*
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
HELP: ?if
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- )" } } { "false" { $quotation "( default -- )" } } }
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" { $quotation "( default -- ... )" } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
"The following two lines are equivalent:"

3
core/system/system-docs.factor
View File

@ -12,6 +12,7 @@ ARTICLE: "system" "System interface"
{ $subsection image }
"Getting the current time:"
{ $subsection micros }
{ $subsection millis }
"Exiting the Factor VM:"
{ $subsection exit } ;
@ -70,7 +71,7 @@ HELP: micros ( -- us )
{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
HELP: millis ( -- ms )
{ $values { "us" integer } }
{ $values { "ms" integer } }
{ $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." }
{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;

6
extra/benchmark/benchmark.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
continuations debugger ;
continuations debugger math ;
IN: benchmark
: run-benchmark ( vocab -- result )
@ -17,12 +17,12 @@ IN: benchmark
standard-table-style [
[
[ "Benchmark" write ] with-cell
[ "Time (ms)" write ] with-cell
[ "Time (seconds)" write ] with-cell
] with-row
[
[
[ [ 1array $vocab-link ] with-cell ]
[ pprint-cell ] bi*
[ 1000000 /f pprint-cell ] bi*
] with-row
] assoc-each
] tabular-output ;

16
extra/benchmark/regex-dna/regex-dna.factor
View File

@ -11,14 +11,14 @@ IN: benchmark.regex-dna
: count-patterns ( string -- )
{
R/ agggtaaa|tttaccct/i,
R/ [cgt]gggtaaa|tttaccc[acg]/i,
R/ a[act]ggtaaa|tttacc[agt]t/i,
R/ ag[act]gtaaa|tttac[agt]ct/i,
R/ agg[act]taaa|ttta[agt]cct/i,
R/ aggg[acg]aaa|ttt[cgt]ccct/i,
R/ agggt[cgt]aa|tt[acg]accct/i,
R/ agggta[cgt]a|t[acg]taccct/i,
R/ agggtaaa|tttaccct/i
R/ [cgt]gggtaaa|tttaccc[acg]/i
R/ a[act]ggtaaa|tttacc[agt]t/i
R/ ag[act]gtaaa|tttac[agt]ct/i
R/ agg[act]taaa|ttta[agt]cct/i
R/ aggg[acg]aaa|ttt[cgt]ccct/i
R/ agggt[cgt]aa|tt[acg]accct/i
R/ agggta[cgt]a|t[acg]taccct/i
R/ agggtaa[cgt]|[acg]ttaccct/i
} [
[ raw>> write bl ]

13
extra/hello-world/deploy.factor
View File

@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-c-types? f }
{ deploy-name "Hello world (console)" }
{ deploy-threads? f }
{ deploy-name "Hello world (console)" }
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-reflection 2 }
{ deploy-io 2 }
{ deploy-math? f }
{ deploy-ui? f }
{ deploy-compiler? f }
{ deploy-io 2 }
{ deploy-math? f }
{ deploy-reflection 1 }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-c-types? f }
}

22
extra/irc/client/client-tests.factor
View File

@ -169,6 +169,20 @@ M: mb-writer dispose drop ;
] unit-test
] with-irc
[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
participants>>
] unit-test
] with-irc
! Namelist change notification
[ { T{ participant-changed f f f f } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
@ -195,3 +209,11 @@ M: mb-writer dispose drop ;
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
! Mode change
[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net MODE #factortest +o ircuser" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc

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