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

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

db4
U-SLAVA-DFB8FF805\Slava 2008-05-09 16:20:17 -05:00
parent d9e615c040 8babbe05d9
commit 17f395281a
175 changed files with 1847 additions and 1086 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/bootstrap/primitives.factor
View File

@ -607,7 +607,7 @@ tuple
{ "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" }
{ "gc" "memory" }
{ "gc-time" "memory" }
{ "gc-stats" "memory" }
{ "save-image" "memory" }
{ "save-image-and-exit" "memory" }
{ "datastack" "kernel" }
@ -702,6 +702,7 @@ tuple
{ "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
}
dup length [ >r first2 r> make-primitive ] 2each

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

@ -48,4 +48,5 @@ $nl
{ $subsection "checksums.crc32" }
{ $vocab-subsection "MD5 checksum" "checksums.md5" }
{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } ;
{ $vocab-subsection "SHA2 checksum" "checksums.sha2" }
{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } ;

7
core/checksums/checksums-tests.factor Normal file
View File

@ -0,0 +1,7 @@
IN: checksums.tests
USING: checksums tools.test ;
\ checksum-bytes must-infer
\ checksum-stream must-infer
\ checksum-lines must-infer
\ checksum-file must-infer

12
core/classes/tuple/tuple-tests.factor
View File

@ -542,3 +542,15 @@ TUPLE: another-forget-accessors-test ;
! Missing error check
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
TUPLE: subclass-forget-test ;
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
TUPLE: subclass-forget-test-2 < subclass-forget-test ;
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail

2
core/classes/tuple/tuple.factor
View File

@ -102,7 +102,7 @@ ERROR: bad-superclass class ;
dup tuple-predicate-quot define-predicate ;
: superclass-size ( class -- n )
superclasses 1 head-slice*
superclasses but-last-slice
[ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs )

59
core/compiler/compiler.factor
View File

@ -4,38 +4,55 @@ USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger words compiler.units
continuations vocabs assocs alien.compiler dlists optimizer
definitions math compiler.errors threads graphs generic
inference ;
inference combinators ;
IN: compiler
: ripple-up ( word -- )
compiled-usage [ drop queue-compile ] assoc-each ;
: save-effect ( word effect -- )
over "compiled-uses" word-prop [
2dup swap "compiled-effect" word-prop =
[ over ripple-up ] unless
] when
"compiled-effect" set-word-prop ;
: finish-compile ( word effect dependencies -- )
>r dupd save-effect r>
over compiled-unxref
over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[
[ word-dataflow optimize ] keep dup generate
] computing-dependencies ;
over "compiled-effect" word-prop = [
dup "compiled-uses" word-prop
[ dup ripple-up ] when
] unless drop
]
[ "compiled-effect" set-word-prop ] 2bi ;
: compile-begins ( word -- )
f swap compiler-error ;
: compile-failed ( word error -- )
f pick compiled get set-at
swap compiler-error ;
[ swap compiler-error ]
[
drop
[ f swap compiled get set-at ]
[ f save-effect ]
bi
] 2bi ;
: compile-succeeded ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
dup compiled-crossref?
[ dependencies get compiled-xref ] [ drop ] if
] tri ;
: (compile) ( word -- )
f over compiler-error
[ dup compile-succeeded finish-compile ]
[ dupd compile-failed f save-effect ]
recover ;
[
H{ } clone dependencies set
{
[ compile-begins ]
[
[ word-dataflow ] [ compile-failed return ] recover
optimize
]
[ dup generate ]
[ compile-succeeded ]
} cleave
] curry with-return ;
: compile-loop ( assoc -- )
dup assoc-empty? [ drop ] [

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

@ -5,6 +5,7 @@ IN: compiler.constants
! These constants must match vm/memory.h
: card-bits 6 ;
: deck-bits 12 ;
: card-mark HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h

2
core/continuations/continuations-tests.factor
View File

@ -117,3 +117,5 @@ T{ dispose-dummy } "b" set
[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
[ t ] [ "b" get disposed?>> ] unit-test
[ ] [ [ return ] with-return ] unit-test

8
core/continuations/continuations.factor
View File

@ -101,6 +101,14 @@ PRIVATE>
: continue ( continuation -- )
f swap continue-with ;
SYMBOL: return-continuation
: with-return ( quot -- )
[ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
: return ( -- )
return-continuation get continue ;
GENERIC: compute-restarts ( error -- seq )
<PRIVATE

20
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -56,14 +56,22 @@ IN: cpu.ppc.intrinsics
: load-cards-offset ( dest -- )
"cards_offset" f pick %load-dlsym dup 0 LWZ ;
: load-decks-offset ( dest -- )
"decks_offset" f pick %load-dlsym dup 0 LWZ ;
: %write-barrier ( -- )
"val" get operand-immediate? "obj" get fresh-object? or [
"obj" operand "scratch" operand card-bits SRWI
"scratch1" operand card-mark LI
! Mark the card
"val" operand load-cards-offset
"scratch" operand dup "val" operand ADD
"val" operand "scratch" operand 0 LBZ
"val" operand dup card-mark ORI
"val" operand "scratch" operand 0 STB
"obj" operand "scratch2" operand card-bits SRWI
"val" operand "scratch2" operand "val" operand STBX
! Mark the card deck
"val" operand load-decks-offset
"obj" operand "scratch" operand deck-bits SRWI
"val" operand "scratch" operand "val" operand STBX
] unless ;
\ set-slot {
@ -71,7 +79,7 @@ IN: cpu.ppc.intrinsics
{
[ %slot-literal-known-tag STW %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +scratch+ { { f "scratch1" } { f "scratch2" } } }
{ +clobber+ { "val" } }
}
}

5
core/cpu/x86/32/32.factor
View File

@ -22,8 +22,9 @@ M: x86.32 temp-reg-2 ECX ;
M: temp-reg v>operand drop EBX ;
M: x86.32 %alien-invoke ( symbol dll -- )
(CALL) rel-dlsym ;
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;

5
core/cpu/x86/64/64.factor
View File

@ -130,7 +130,10 @@ M: x86.64 %prepare-box-struct ( size -- )
M: x86.64 %prepare-var-args RAX RAX XOR ;
M: x86.64 %alien-invoke ( symbol dll -- )
M: x86.64 %alien-global
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
M: x86.64 %alien-invoke
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
M: x86.64 %prepare-alien-indirect ( -- )

11
core/cpu/x86/architecture/architecture.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators compiler.constants
math.order ;
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
kernel kernel.private math memory namespaces sequences words
generator generator.registers generator.fixup system layouts
combinators compiler.constants math.order ;
IN: cpu.x86.architecture
HOOK: ds-reg cpu
@ -63,8 +63,7 @@ M: x86 %prologue ( n -- )
M: x86 %epilogue ( n -- )
stack-reg swap ADD ;
: %alien-global ( symbol dll register -- )
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
HOOK: %alien-global cpu ( symbol dll register -- )
M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a

3
core/cpu/x86/assembler/assembler-tests.factor
View File

@ -36,3 +36,6 @@ IN: cpu.x86.assembler.tests
[ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
[ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test

202
core/cpu/x86/assembler/assembler.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator.fixup io.binary kernel
combinators kernel.private math namespaces parser sequences
words system layouts math.order ;
words system layouts math.order accessors ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
@ -11,11 +11,6 @@ IN: cpu.x86.assembler
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
: n, >le % ; inline
: 4, 4 n, ; inline
: 2, 2 n, ; inline
: cell, bootstrap-cell n, ; inline
! Register operands -- eg, ECX
<<
@ -45,6 +40,10 @@ REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
TUPLE: byte value ;
C: <byte> byte
<PRIVATE
#! Extended AMD64 registers (R8-R15) return true.
@ -75,50 +74,38 @@ M: register extended? "register" word-prop 7 > ;
! Addressing modes
TUPLE: indirect base index scale displacement ;
M: indirect extended? indirect-base extended? ;
M: indirect extended? base>> extended? ;
: canonicalize-EBP
#! { EBP } ==> { EBP 0 }
dup indirect-base { EBP RBP R13 } memq? [
dup indirect-displacement [
drop
] [
0 swap set-indirect-displacement
] if
] [
drop
] if ;
dup base>> { EBP RBP R13 } member? [
dup displacement>> [ 0 >>displacement ] unless
] when drop ;
: canonicalize-ESP
#! { ESP } ==> { ESP ESP }
dup indirect-base { ESP RSP R12 } memq? [
ESP swap set-indirect-index
] [
drop
] if ;
dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ;
: canonicalize ( indirect -- )
#! Modify the indirect to work around certain addressing mode
#! quirks.
dup canonicalize-EBP
canonicalize-ESP ;
[ canonicalize-EBP ] [ canonicalize-ESP ] bi ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa dup canonicalize ;
: reg-code "register" word-prop 7 bitand ;
: indirect-base* indirect-base EBP or reg-code ;
: indirect-base* base>> EBP or reg-code ;
: indirect-index* indirect-index ESP or reg-code ;
: indirect-index* index>> ESP or reg-code ;
: indirect-scale* indirect-scale 0 or ;
: indirect-scale* scale>> 0 or ;
GENERIC: sib-present? ( op -- ? )
M: indirect sib-present?
dup indirect-base { ESP RSP } memq?
over indirect-index rot indirect-scale or or ;
[ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
M: register sib-present? drop f ;
@ -130,16 +117,23 @@ M: indirect r/m
M: register r/m reg-code ;
: byte? -128 127 between? ;
! Immediate operands
UNION: immediate byte integer ;
GENERIC: fits-in-byte? ( value -- ? )
M: byte fits-in-byte? drop t ;
M: integer fits-in-byte? -128 127 between? ;
GENERIC: modifier ( op -- n )
M: indirect modifier
dup indirect-base [
indirect-displacement {
{ [ dup not ] [ BIN: 00 ] }
{ [ dup byte? ] [ BIN: 01 ] }
{ [ dup integer? ] [ BIN: 10 ] }
dup base>> [
displacement>> {
{ [ dup not ] [ BIN: 00 ] }
{ [ dup fits-in-byte? ] [ BIN: 01 ] }
{ [ dup immediate? ] [ BIN: 10 ] }
} cond nip
] [
drop BIN: 00
@ -147,14 +141,23 @@ M: indirect modifier
M: register modifier drop BIN: 11 ;
GENERIC# n, 1 ( value n -- )
M: integer n, >le % ;
M: byte n, >r value>> r> n, ;
: 1, 1 n, ; inline
: 4, 4 n, ; inline
: 2, 2 n, ; inline
: cell, bootstrap-cell n, ; inline
: mod-r/m, ( reg# indirect -- )
dup modifier 6 shift rot 3 shift rot r/m bitor bitor , ;
[ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
: sib, ( indirect -- )
dup sib-present? [
dup indirect-base*
over indirect-index* 3 shift bitor
swap indirect-scale* 6 shift bitor ,
[ indirect-base* ]
[ indirect-index* 3 shift ]
[ indirect-scale* 6 shift ] tri bitor bitor ,
] [
drop
] if ;
@ -162,9 +165,9 @@ M: register modifier drop BIN: 11 ;
GENERIC: displacement, ( op -- )
M: indirect displacement,
dup indirect-displacement dup [
swap indirect-base
[ dup byte? [ , ] [ 4, ] if ] [ 4, ] if
dup displacement>> dup [
swap base>>
[ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
] [
2drop
] if ;
@ -172,18 +175,19 @@ M: indirect displacement,
M: register displacement, drop ;
: addressing ( reg# indirect -- )
[ mod-r/m, ] keep [ sib, ] keep displacement, ;
[ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
! Utilities
UNION: operand register indirect ;
: operand-64? ( operand -- ? )
dup indirect? [
dup indirect-base register-64?
swap indirect-index register-64? or
] [
register-64?
] if ;
GENERIC: operand-64? ( operand -- ? )
M: indirect operand-64?
[ base>> ] [ index>> ] bi [ operand-64? ] either? ;
M: register-64 operand-64? drop t ;
M: object operand-64? drop f ;
: rex.w? ( rex.w reg r/m -- ? )
{
@ -198,8 +202,7 @@ UNION: operand register indirect ;
: rex.b
[ extended? [ BIN: 00000001 bitor ] when ] keep
dup indirect? [
indirect-index extended?
[ BIN: 00000010 bitor ] when
index>> extended? [ BIN: 00000010 bitor ] when
] [
drop
] if ;
@ -230,25 +233,34 @@ UNION: operand register indirect ;
: opcode-or ( opcode mask -- opcode' )
swap dup array?
[ 1 cut* first rot bitor suffix ] [ bitor ] if ;
[ unclip-last rot bitor suffix ] [ bitor ] if ;
: 1-operand ( op reg rex.w opcode -- )
: 1-operand ( op reg,rex.w,opcode -- )
#! The 'reg' is not really a register, but a value for the
#! 'reg' field of the mod-r/m byte.
>r >r over r> prefix-1 r> opcode, swap addressing ;
first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
: immediate-1 ( imm dst reg rex.w opcode -- )
1-operand , ;
: immediate-operand-size-bit
pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
: immediate-1/4 ( imm dst reg rex.w opcode -- )
: immediate-1 ( imm dst reg,rex.w,opcode -- )
immediate-operand-size-bit 1-operand 1, ;
: immediate-4 ( imm dst reg,rex.w,opcode -- )
immediate-operand-size-bit 1-operand 4, ;
: immediate-fits-in-size-bit
pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
#! If imm is a byte, compile the opcode and the byte.
#! Otherwise, set the 32-bit operand flag in the opcode, and
#! Otherwise, set the 8-bit operand flag in the opcode, and
#! compile the cell. The 'reg' is not really a register, but
#! a value for the 'reg' field of the mod-r/m byte.
>r >r pick byte? [
r> r> BIN: 10 opcode-or immediate-1
pick fits-in-byte? [
immediate-fits-in-size-bit immediate-1
] [
r> r> 1-operand 4,
immediate-4
] if ;
: (2-operand) ( dst src op -- )
@ -283,22 +295,24 @@ PRIVATE>
! Moving stuff
GENERIC: PUSH ( op -- )
M: register PUSH f HEX: 50 short-operand ;
M: integer PUSH HEX: 68 , 4, ;
M: operand PUSH BIN: 110 f HEX: ff 1-operand ;
M: immediate PUSH HEX: 68 , 4, ;
M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
GENERIC: POP ( op -- )
M: register POP f HEX: 58 short-operand ;
M: operand POP BIN: 000 f HEX: 8f 1-operand ;
M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
! MOV where the src is immediate.
GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
PREDICATE: callable < word register? not ;
GENERIC: MOV ( dst src -- )
M: integer MOV swap (MOV-I) ;
M: immediate MOV swap (MOV-I) ;
M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
M: operand MOV HEX: 88 2-operand ;
@ -309,13 +323,13 @@ GENERIC: JMP ( op -- )
: (JMP) HEX: e9 , 0 4, rc-relative ;
M: callable JMP (JMP) rel-word ;
M: label JMP (JMP) label-fixup ;
M: operand JMP BIN: 100 t HEX: ff 1-operand ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
: (CALL) HEX: e8 , 0 4, rc-relative ;
M: callable CALL (CALL) rel-word ;
M: label CALL (CALL) label-fixup ;
M: operand CALL BIN: 010 t HEX: ff 1-operand ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
: (JUMPcc) extended-opcode, 0 4, rc-relative ;
@ -347,57 +361,57 @@ M: label JUMPcc (JUMPcc) label-fixup ;
! Arithmetic
GENERIC: ADD ( dst src -- )
M: integer ADD swap BIN: 000 t HEX: 81 immediate-1/4 ;
M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
M: operand ADD OCT: 000 2-operand ;
GENERIC: OR ( dst src -- )
M: integer OR swap BIN: 001 t HEX: 81 immediate-1/4 ;
M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
M: operand OR OCT: 010 2-operand ;
GENERIC: ADC ( dst src -- )
M: integer ADC swap BIN: 010 t HEX: 81 immediate-1/4 ;
M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
M: operand ADC OCT: 020 2-operand ;
GENERIC: SBB ( dst src -- )
M: integer SBB swap BIN: 011 t HEX: 81 immediate-1/4 ;
M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
M: operand SBB OCT: 030 2-operand ;
GENERIC: AND ( dst src -- )
M: integer AND swap BIN: 100 t HEX: 81 immediate-1/4 ;
M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
M: operand AND OCT: 040 2-operand ;
GENERIC: SUB ( dst src -- )
M: integer SUB swap BIN: 101 t HEX: 81 immediate-1/4 ;
M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
M: operand SUB OCT: 050 2-operand ;
GENERIC: XOR ( dst src -- )
M: integer XOR swap BIN: 110 t HEX: 81 immediate-1/4 ;
M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
M: operand XOR OCT: 060 2-operand ;
GENERIC: CMP ( dst src -- )
M: integer CMP swap BIN: 111 t HEX: 81 immediate-1/4 ;
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ;
: NOT ( dst -- ) BIN: 010 t HEX: f7 1-operand ;
: NEG ( dst -- ) BIN: 011 t HEX: f7 1-operand ;
: MUL ( dst -- ) BIN: 100 t HEX: f7 1-operand ;
: IMUL ( src -- ) BIN: 101 t HEX: f7 1-operand ;
: DIV ( dst -- ) BIN: 110 t HEX: f7 1-operand ;
: IDIV ( src -- ) BIN: 111 t HEX: f7 1-operand ;
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
: CDQ HEX: 99 , ;
: CQO HEX: 48 , CDQ ;
: ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ;
: ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ;
: RCL ( dst n -- ) swap BIN: 010 t HEX: c1 immediate-1 ;
: RCR ( dst n -- ) swap BIN: 011 t HEX: c1 immediate-1 ;
: SHL ( dst n -- ) swap BIN: 100 t HEX: c1 immediate-1 ;
: SHR ( dst n -- ) swap BIN: 101 t HEX: c1 immediate-1 ;
: SAR ( dst n -- ) swap BIN: 111 t HEX: c1 immediate-1 ;
: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
GENERIC: IMUL2 ( dst src -- )
M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ;
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
: MOVSX ( dst src -- )
@ -432,11 +446,11 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
! x87 Floating Point Unit
: FSTPS ( operand -- ) BIN: 011 f HEX: d9 1-operand ;
: FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ;
: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
: FLDS ( operand -- ) BIN: 000 f HEX: d9 1-operand ;
: FLDL ( operand -- ) BIN: 000 f HEX: dd 1-operand ;
: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
! SSE multimedia instructions

8
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -63,9 +63,15 @@ IN: cpu.x86.intrinsics
: generate-write-barrier ( -- )
#! Mark the card pointed to by vreg.
"val" get operand-immediate? "obj" get fresh-object? or [
! Mark the card
"obj" operand card-bits SHR
"cards_offset" f temp-reg v>operand %alien-global
temp-reg v>operand "obj" operand [+] card-mark OR
temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
! Mark the card deck
"obj" operand deck-bits card-bits - SHR
"decks_offset" f temp-reg v>operand %alien-global
temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
] unless ;
\ set-slot {

8
core/debugger/debugger-docs.factor
View File

@ -1,7 +1,7 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations system debugger.private
io.files.private ;
io.files.private listener ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"
@ -81,13 +81,9 @@ HELP: print-error
HELP: restarts.
{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
HELP: error-hook
{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
HELP: try
{ $values { "quot" "a quotation" } }
{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
{ $description "Attempts to call a quotation; if it throws an error, the error is printed to " { $link output-stream } ", stacks are restored, and execution continues after the call to " { $link try } "." }
{ $examples
"The following example prints an error and keeps going:"
{ $code

18
core/debugger/debugger.factor
View File

@ -64,13 +64,14 @@ M: string error. print ;
[ global [ "Error in print-error!" print drop ] bind ]
recover ;
: print-error-and-restarts ( error -- )
print-error
restarts.
nl
"Type :help for debugging help." print flush ;
: try ( quot -- )
[
print-error
restarts.
nl
"Type :help for debugging help." print flush
] recover ;
[ print-error-and-restarts ] recover ;
ERROR: assert got expect ;
@ -269,8 +270,7 @@ M: double-free summary
M: realloc-error summary
drop "Memory reallocation failed" ;
: error-in-thread. ( -- )
error-thread get-global
: error-in-thread. ( thread -- )
"Error in thread " write
[
dup thread-id #
@ -284,7 +284,7 @@ M: thread error-in-thread ( error thread -- )
die drop
] [
global [
error-in-thread. print-error flush
error-thread get-global error-in-thread. print-error flush
] bind
] if ;

4
core/inference/known-words/known-words.factor
View File

@ -362,7 +362,7 @@ M: object infer-call
\ gc { } { } <effect> set-primitive-effect
\ gc-time { } { integer } <effect> set-primitive-effect
\ gc-stats { } { array } <effect> set-primitive-effect
\ save-image { string } { } <effect> set-primitive-effect
@ -372,7 +372,7 @@ M: object infer-call
t over set-effect-terminated?
set-primitive-effect
\ data-room { } { integer array } <effect> set-primitive-effect
\ data-room { } { integer integer array } <effect> set-primitive-effect
\ data-room make-flushable
\ code-room { } { integer integer integer integer } <effect> set-primitive-effect

6
core/inference/state/state-tests.factor
View File

@ -1,5 +1,9 @@
IN: inference.state.tests
USING: tools.test inference.state words ;
USING: tools.test inference.state words kernel namespaces ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep ;
inline
SYMBOL: a
SYMBOL: b

4
core/inference/state/state.factor
View File

@ -36,10 +36,6 @@ SYMBOL: dependencies
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
] [ 3drop ] if ;
: computing-dependencies ( quot -- dependencies )
H{ } clone [ dependencies rot with-variable ] keep ;
inline
! Did the current control-flow path throw an error?
SYMBOL: terminated?

2
core/inference/transforms/transforms.factor
View File

@ -32,7 +32,7 @@ IN: inference.transforms
drop [ no-case ]
] [
dup peek quotation? [
dup peek swap 1 head*
dup peek swap but-last
] [
[ no-case ] swap
] if case>quot

14
core/io/encodings/encodings-tests.factor
View File

@ -2,11 +2,8 @@ USING: io.files io.streams.string io
tools.test kernel io.encodings.ascii ;
IN: io.streams.encodings.tests
: <resource-reader> ( resource -- stream )
resource-path ascii <file-reader> ;
[ { } ]
[ "core/io/test/empty-file.txt" <resource-reader> lines ]
[ "resource:core/io/test/empty-file.txt" ascii <file-reader> lines ]
unit-test
: lines-test ( stream -- line1 line2 )
@ -16,21 +13,24 @@ unit-test
"This is a line."
"This is another line."
] [
"core/io/test/windows-eol.txt" <resource-reader> lines-test
"resource:core/io/test/windows-eol.txt"
ascii <file-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
"core/io/test/mac-os-eol.txt" <resource-reader> lines-test
"resource:core/io/test/mac-os-eol.txt"
ascii <file-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
"core/io/test/unix-eol.txt" <resource-reader> lines-test
"resource:core/io/test/unix-eol.txt"
ascii <file-reader> lines-test
] unit-test
[

4
core/io/files/files-docs.factor
View File

@ -273,11 +273,11 @@ $nl
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two pathnames." } ;
{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
HELP: prepend-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two pathnames." } ;
{ $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ;
{ append-path prepend-path } related-words

4
core/io/io-docs.factor
View File

@ -125,7 +125,7 @@ $nl
ABOUT: "streams"
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" string } }
{ $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link readln } "; see " { $link "stdio" } "." }
$io-error ;
@ -139,7 +139,7 @@ $io-error ;
HELP: stream-read
{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
{ $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link read } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-read-until

10
core/io/io-tests.factor
View File

@ -8,20 +8,17 @@ IN: io.tests
"foo" "io.tests" lookup
] unit-test
: <resource-reader> ( resource -- stream )
resource-path latin1 <file-reader> ;
[
"This is a line.\rThis is another line.\r"
] [
"core/io/test/mac-os-eol.txt" <resource-reader>
"resource:core/io/test/mac-os-eol.txt" latin1 <file-reader>
[ 500 read ] with-input-stream
] unit-test
[
255
] [
"core/io/test/binary.txt" <resource-reader>
"resource:core/io/test/binary.txt" latin1 <file-reader>
[ read1 ] with-input-stream >fixnum
] unit-test
@ -36,7 +33,8 @@ IN: io.tests
}
] [
[
"core/io/test/separator-test.txt" <resource-reader> [
"resource:core/io/test/separator-test.txt"
latin1 <file-reader> [
"J" read-until 2array ,
"i" read-until 2array ,
"X" read-until 2array ,

2
core/io/io.factor
View File

@ -4,7 +4,7 @@ USING: hashtables generic kernel math namespaces sequences
continuations assocs io.styles ;
IN: io
GENERIC: stream-readln ( stream -- str )
GENERIC: stream-readln ( stream -- str/f )
GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f )
GENERIC: stream-read-until ( seps stream -- str/f sep/f )

2
core/listener/listener.factor
View File

@ -45,6 +45,8 @@ M: object stream-read-quot
SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global
: listen ( -- )
listener-hook get call prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]

4
core/memory/memory-docs.factor
View File

@ -40,10 +40,6 @@ HELP: instances
HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ;
HELP: gc-time ( -- n )
{ $values { "n" "a timestamp in milliseconds" } }
{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
HELP: data-room ( -- cards generations )
{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
{ $description "Queries the runtime for memory usage information." } ;

2
core/prettyprint/prettyprint-tests.factor
View File

@ -114,7 +114,7 @@ unit-test
[ parse-fresh drop ] with-compilation-unit
[
"prettyprint.tests" lookup see
] with-string-writer "\n" split 1 head*
] with-string-writer "\n" split but-last
] keep =
] with-scope ;

11
core/prettyprint/sections/sections.factor
View File

@ -15,9 +15,9 @@ SYMBOL: pprinter-stack
SYMBOL: pprinter-in
SYMBOL: pprinter-use
TUPLE: pprinter last-newline line-count end-printing indent ;
TUPLE: pprinter last-newline line-count indent ;
: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter boa ;
: <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
@ -34,7 +34,7 @@ TUPLE: pprinter last-newline line-count end-printing indent ;
] [
pprinter get (>>last-newline)
line-limit? [
"..." write pprinter get end-printing>> continue
"..." write pprinter get return
] when
pprinter get [ 1+ ] change-line-count drop
nl do-indent
@ -275,16 +275,15 @@ M: colon unindent-first-line? drop t ;
[
dup style>> [
[
>r pprinter get (>>end-printing) r>
short-section
] curry callcc0
] curry with-return
] with-nesting
] if-nonempty
] with-variable ;
! Long section layout algorithm
: chop-break ( seq -- seq )
dup peek line-break? [ 1 head-slice* chop-break ] when ;
dup peek line-break? [ but-last-slice chop-break ] when ;
SYMBOL: prev
SYMBOL: next

17
core/sequences/sequences-docs.factor
View File

@ -92,9 +92,11 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection subseq }
{ $subsection head }
{ $subsection tail }
{ $subsection rest }
{ $subsection head* }
{ $subsection tail* }
"Removing the first or last element:"
{ $subsection rest }
{ $subsection but-last }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip }
{ $subsection cut }
@ -106,6 +108,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
{ $subsection but-last-slice }
{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
@ -836,11 +839,16 @@ HELP: tail-slice
{ $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: but-last-slice
{ $values { "seq" sequence } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all but the last element of the input sequence." }
{ $errors "Throws an error on an empty sequence." } ;
HELP: rest-slice
{ $values { "seq" sequence } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements from the 1st index until the end of the input sequence." }
{ $notes "Equivalent to " { $snippet "1 tail" } }
{ $errors "Throws an error if the index is out of bounds." } ;
{ $errors "Throws an error on an empty sequence." } ;
HELP: head-slice*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } }
@ -862,6 +870,11 @@ HELP: tail
{ $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: but-last
{ $values { "seq" sequence } { "headseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the last item removed." }
{ $errors "Throws an error on an empty sequence." } ;
HELP: rest
{ $values { "seq" sequence } { "tailseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the first item removed." }

8
core/sequences/sequences.factor
View File

@ -216,6 +216,8 @@ M: slice length dup slice-to swap slice-from - ;
: tail-slice* ( seq n -- slice ) from-end tail-slice ;
: but-last-slice ( seq -- slice ) 1 head-slice* ;
INSTANCE: slice virtual-sequence
! One element repeated many times
@ -263,6 +265,8 @@ PRIVATE>
: tail* ( seq n -- tailseq ) from-end tail ;
: but-last ( seq -- headseq ) 1 head* ;
: copy ( src i dst -- )
pick length >r 3dup check-copy spin 0 r>
(copy) drop ; inline
@ -671,13 +675,13 @@ PRIVATE>
[ rest ] [ first ] bi ;
: unclip-last ( seq -- butfirst last )
[ 1 head* ] [ peek ] bi ;
[ but-last ] [ peek ] bi ;
: unclip-slice ( seq -- rest first )
[ rest-slice ] [ first ] bi ;
: unclip-last-slice ( seq -- butfirst last )
[ 1 head-slice* ] [ peek ] bi ;
[ but-last-slice ] [ peek ] bi ;
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ;

2
core/splitting/splitting.factor
View File

@ -104,7 +104,7 @@ M: sliced-clumps nth group@ <slice> ;
1array
] [
"\n" split [
1 head-slice* [
but-last-slice [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split suffix concat

16
core/threads/threads-tests.factor
View File

@ -1,5 +1,6 @@
USING: namespaces io tools.test threads kernel
concurrency.combinators math ;
concurrency.combinators concurrency.promises locals math
words ;
IN: threads.tests
3 "x" set
@ -27,3 +28,16 @@ yield
"i" tget
] parallel-map
] unit-test
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
:: spawn-namespace-test ( -- )
[let | p [ <promise> ] g [ gensym ] |
[
g "x" set
[ "x" get p fulfill ] "B" spawn drop
] with-scope
p ?promise g eq?
] ;
[ t ] [ spawn-namespace-test ] unit-test

77
core/threads/threads.factor
View File

@ -12,7 +12,7 @@ SYMBOL: initial-thread
TUPLE: thread
name quot exit-handler
id
continuation state
continuation state runnable
mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline
@ -91,6 +91,8 @@ PRIVATE>
[ sleep-queue heap-peek nip millis [-] ]
} cond ;
DEFER: stop
<PRIVATE
: schedule-sleep ( thread dt -- )
@ -111,36 +113,57 @@ PRIVATE>
[ ] while
drop ;
: start ( namestack thread -- )
[
set-self
set-namestack
V{ } set-catchstack
{ } set-retainstack
{ } set-datastack
self quot>> [ call stop ] call-clear
] 2 (throw) ;
DEFER: next
: no-runnable-threads ( -- * )
! We should never be in a state where the only threads
! are sleeping; the I/O wait thread is always runnable.
! However, if it dies, we handle this case
! semi-gracefully.
!
! And if sleep-time outputs f, there are no sleeping
! threads either... so WTF.
sleep-time [ die 0 ] unless* (sleep) next ;
: (next) ( arg thread -- * )
f >>state
dup set-self
dup runnable>> [
continuation>> box> continue-with
] [
t >>runnable start
] if ;
: next ( -- * )
expire-sleep-loop
run-queue dup dlist-empty? [
! We should never be in a state where the only threads
! are sleeping; the I/O wait thread is always runnable.
! However, if it dies, we handle this case
! semi-gracefully.
!
! And if sleep-time outputs f, there are no sleeping
! threads either... so WTF.
drop sleep-time [ die 0 ] unless* (sleep) next
drop no-runnable-threads
] [
pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f >>state
continuation>> box>
continue-with
pop-back dup array? [ first2 ] [ f swap ] if (next)
] if ;
PRIVATE>
: stop ( -- )
self dup exit-handler>> call
unregister-thread next ;
self [ exit-handler>> call ] [ unregister-thread ] bi next ;
: suspend ( quot state -- obj )
[
self continuation>> >box
self (>>state)
self swap call next
>r
>r self swap call
r> self (>>state)
r> self continuation>> >box
next
] callcc1 2nip ; inline
: yield ( -- ) [ resume ] f suspend drop ;
@ -166,16 +189,7 @@ M: real sleep
] when drop ;
: (spawn) ( thread -- )
[
resume-now [
dup set-self
dup register-thread
V{ } set-catchstack
{ } set-retainstack
>r { } set-datastack r>
quot>> [ call stop ] call-clear
] 1 (throw)
] "spawn" suspend 2drop ;
[ register-thread ] [ namestack swap resume-with ] bi ;
: spawn ( quot name -- thread )
<thread> [ (spawn) ] keep ;
@ -184,8 +198,8 @@ M: real sleep
>r [ [ ] [ ] while ] curry r> spawn ;
: in-thread ( quot -- )
>r datastack namestack r>
[ >r set-namestack set-datastack r> call ] 3curry
>r datastack r>
[ >r set-datastack r> call ] 2curry
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
@ -199,6 +213,7 @@ GENERIC: error-in-thread ( error thread -- )
initial-thread global
[ drop f "Initial" <thread> ] cache
<box> >>continuation
t >>runnable
f >>state
dup register-thread
set-self ;

2
extra/benchmark/benchmark.factor
View File

@ -6,7 +6,7 @@ continuations debugger ;
IN: benchmark
: run-benchmark ( vocab -- result )
[ [ require ] [ [ run ] benchmark nip ] bi ] curry
[ [ require ] [ [ run ] benchmark ] bi ] curry
[ error. f ] recover ;
: run-benchmarks ( -- assoc )

2
extra/benchmark/binary-trees/binary-trees.factor
View File

@ -53,3 +53,5 @@ M: f item-check drop 0 ;
: binary-trees-main ( -- )
16 binary-trees ;
MAIN: binary-trees-main

4
extra/benchmark/fasta/fasta.factor
View File

@ -81,7 +81,7 @@ HINTS: random fixnum ;
write-description
[let | k! [ 0 ] alu [ ] |
[| len | k len alu make-repeat-fasta k! ] split-lines
] with-locals ; inline
] ; inline
: fasta ( n out -- )
homo-sapiens make-cumulative
@ -103,7 +103,7 @@ HINTS: random fixnum ;
drop
] with-file-writer
] with-locals ;
] ;
: run-fasta 2500000 reverse-complement-in fasta ;

2
extra/benchmark/knucleotide/knucleotide.factor
View File

@ -56,7 +56,7 @@ IN: benchmark.knucleotide
drop ;
: knucleotide ( -- )
"extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
"resource:extra/benchmark/knucleotide/knucleotide-input.txt"
ascii [ read-input ] with-file-reader
process-input ;

3
extra/benchmark/partial-sums/partial-sums.factor
View File

@ -3,7 +3,8 @@ prettyprint words hints ;
IN: benchmark.partial-sums
: summing ( n quot -- y )
[ + ] compose 0.0 -rot 1 -rot (each-integer) ; inline
[ >float ] swap [ + ] 3compose
0.0 -rot 1 -rot (each-integer) ; inline
: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing ;

2
extra/benchmark/sockets/sockets.factor
View File

@ -10,7 +10,7 @@ SYMBOL: counter
: server-addr "127.0.0.1" 7777 <inet4> ;
: server-loop ( server -- )
dup accept [
dup accept drop [
[
read1 CHAR: x = [
"server" get dispose

5
extra/builder/test/test.factor
View File

@ -3,6 +3,7 @@ USING: kernel namespaces assocs
io.files io.encodings.utf8 prettyprint
help.lint
benchmark
tools.time
bootstrap.stage2
tools.test tools.vocabs
builder.util ;
@ -26,8 +27,8 @@ IN: builder.test
: do-all ( -- )
bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer
[ do-load ] runtime "../load-time" utf8 [ . ] with-file-writer
[ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer
[ do-load ] benchmark "../load-time" utf8 [ . ] with-file-writer
[ do-tests ] benchmark "../test-time" utf8 [ . ] with-file-writer
do-help-lint
do-benchmarks ;

2
extra/builder/util/util.factor
View File

@ -12,8 +12,6 @@ IN: builder.util
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: runtime ( quot -- time ) benchmark nip ;
: minutes>ms ( min -- ms ) 60 * 1000 * ;
: file>string ( file -- string ) utf8 file-contents ;

2
extra/cairo/png/png.factor
View File

@ -21,7 +21,7 @@ ERROR: cairo-error string ;
{ CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
{ CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
[ drop ]
} cond ;
} case ;
: <png> ( path -- png )
normalize-path

11
extra/checksums/adler-32/adler-32-docs.factor Executable file
View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax ;
IN: checksums.adler-32
HELP: adler-32
{ $description "Adler-32 checksum algorithm." } ;
ARTICLE: "checksums.adler-32" "Adler-32 checksum"
"The Adler-32 checksum algorithm implements simple and fast checksum. It is used in zlib and rsync."
{ $subsection adler-32 } ;
ABOUT: "checksums.adler-32"

5
extra/checksums/adler-32/adler-32-tests.factor Normal file
View File

@ -0,0 +1,5 @@
USING: checksums.adler-32 checksums strings tools.test ;
IN: checksums.adler-32.tests
[ 300286872 ] [ "Wikipedia" adler-32 checksum-bytes ] unit-test
[ 2679885283 ] [ 10000 CHAR: a <string> adler-32 checksum-bytes ] unit-test

15
extra/checksums/adler-32/adler-32.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: checksums classes.singleton kernel math math.ranges
math.vectors sequences ;
IN: checksums.adler-32
SINGLETON: adler-32
: adler-32-modulus 65521 ; inline
M: adler-32 checksum-bytes ( bytes checksum -- value )
drop
[ sum 1+ ]
[ [ dup length [1,b] <reversed> v. ] [ length ] bi + ] bi
[ adler-32-modulus mod ] bi@ 16 shift bitor ;

1
extra/checksums/adler-32/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

4
extra/checksums/null/null.factor
View File

@ -1,8 +1,8 @@
USING: checksums ;
USING: checksums kernel ;
IN: checksums.null
SINGLETON: null
INSTANCE: null checksum
M: null checksum-bytes ;
M: null checksum-bytes drop ;

4
extra/cocoa/application/application-docs.factor
View File

@ -26,7 +26,7 @@ HELP: with-cocoa
{ $values { "quot" quotation } }
{ $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
HELP: do-events
HELP: do-event
{ $values { "app" "an " { $snippet "NSApplication" } } }
{ $description "Processes any pending events in the queue. Does not block." } ;
@ -49,7 +49,7 @@ ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
{ $subsection NSApp }
{ $subsection with-autorelease-pool }
{ $subsection with-cocoa }
{ $subsection do-events }
{ $subsection do-event }
{ $subsection add-observer }
{ $subsection remove-observer }
{ $subsection install-delegate } ;

3
extra/cocoa/application/application.factor
View File

@ -29,9 +29,6 @@ IN: cocoa.application
: do-event ( app -- ? )
dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
: do-events ( app -- )
dup do-event [ do-events ] [ drop ] if ;
: add-observer ( observer selector name object -- )
>r >r >r >r NSNotificationCenter -> defaultCenter
r> r> sel_registerName

5
extra/combinators/lib/lib.factor
View File

@ -169,3 +169,8 @@ MACRO: multikeep ( word out-indexes -- ... )
: generate ( generator predicate -- obj )
[ dup ] swap [ dup [ nip ] unless not ] 3compose
swap [ ] do-while ;
MACRO: predicates ( seq -- quot/f )
dup [ 1quotation [ drop ] prepend ] map
>r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
[ cond ] curry ;

12
extra/concurrency/combinators/combinators-docs.factor
View File

@ -6,11 +6,21 @@ HELP: parallel-map
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-each
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: 2parallel-each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }
{ $errors "Throws an error if one of the iterations throws an error." } ;
HELP: parallel-filter
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } }
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
@ -19,7 +29,9 @@ HELP: parallel-filter
ARTICLE: "concurrency.combinators" "Concurrent combinators"
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"
{ $subsection parallel-each }
{ $subsection 2parallel-each }
{ $subsection parallel-map }
{ $subsection 2parallel-map }
{ $subsection parallel-filter } ;
ABOUT: "concurrency.combinators"

25
extra/concurrency/combinators/combinators-tests.factor
View File

@ -1,9 +1,11 @@
IN: concurrency.combinators.tests
USING: concurrency.combinators tools.test random kernel math
concurrency.mailboxes threads sequences accessors ;
concurrency.mailboxes threads sequences accessors arrays ;
[ [ drop ] parallel-each ] must-infer
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
[ [ ] parallel-map ] must-infer
{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as
[ [ ] parallel-filter ] must-infer
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
@ -22,3 +24,24 @@ concurrency.mailboxes threads sequences accessors ;
10 over [ push ] curry parallel-each
length
] unit-test
[ { 10 20 30 } ] [
{ 1 4 3 } { 10 5 10 } [ * ] 2parallel-map
] unit-test
[ { -9 -1 -7 } ] [
{ 1 4 3 } { 10 5 10 } [ - ] 2parallel-map
] unit-test
[
{ 1 4 3 } { 1 0 1 } [ / drop ] 2parallel-each
] must-fail
[ 20 ]
[
V{ } clone
10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each
length
] unit-test
[ { f } [ "OOPS" throw ] parallel-each ] must-fail

25
extra/concurrency/combinators/combinators.factor
View File

@ -4,14 +4,27 @@ USING: concurrency.futures concurrency.count-downs sequences
kernel ;
IN: concurrency.combinators
: parallel-map ( seq quot -- newseq )
[ curry future ] curry map dup [ ?future ] change-each ;
inline
: (parallel-each) ( n quot -- )
>r <count-down> r> keep await ; inline
: parallel-each ( seq quot -- )
over length <count-down>
[ [ >r curry r> spawn-stage ] 2curry each ] keep await ;
inline
over length [
[ >r curry r> spawn-stage ] 2curry each
] (parallel-each) ; inline
: 2parallel-each ( seq1 seq2 quot -- )
2over min-length [
[ >r 2curry r> spawn-stage ] 2curry 2each
] (parallel-each) ; inline
: parallel-filter ( seq quot -- newseq )
over >r pusher >r each r> r> like ; inline
: future-values dup [ ?future ] change-each ; inline
: parallel-map ( seq quot -- newseq )
[ curry future ] curry map future-values ;
inline
: 2parallel-map ( seq1 seq2 quot -- newseq )
[ 2curry future ] curry 2map future-values ;

20
extra/concurrency/count-downs/count-downs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel math concurrency.promises
concurrency.mailboxes ;
concurrency.mailboxes debugger accessors ;
IN: concurrency.count-downs
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
@ -9,9 +9,7 @@ IN: concurrency.count-downs
TUPLE: count-down n promise ;
: count-down-check ( count-down -- )
dup count-down-n zero? [
t swap count-down-promise fulfill
] [ drop ] if ;
dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
: <count-down> ( n -- count-down )
dup 0 < [ "Invalid count for count down" throw ] when
@ -19,15 +17,12 @@ TUPLE: count-down n promise ;
dup count-down-check ;
: count-down ( count-down -- )
dup count-down-n dup zero? [
"Count down already done" throw
] [
1- over set-count-down-n
count-down-check
] if ;
dup n>> dup zero?
[ "Count down already done" throw ]
[ 1- >>n count-down-check ] if ;
: await-timeout ( count-down timeout -- )
>r count-down-promise r> ?promise-timeout drop ;
>r promise>> r> ?promise-timeout ?linked t assert= ;
: await ( count-down -- )
f await-timeout ;
@ -35,5 +30,4 @@ TUPLE: count-down n promise ;
: spawn-stage ( quot count-down -- )
[ [ count-down ] curry compose ] keep
"Count down stage"
swap count-down-promise
promise-mailbox spawn-linked-to drop ;
swap promise>> mailbox>> spawn-linked-to drop ;

19
extra/concurrency/flags/flags-tests.factor
View File

@ -1,11 +1,12 @@
IN: concurrency.flags.tests
USING: tools.test concurrency.flags kernel threads locals ;
USING: tools.test concurrency.flags concurrency.combinators
kernel threads locals accessors ;
:: flag-test-1 ( -- )
[let | f [ <flag> ] |
[ f raise-flag ] "Flag test" spawn drop
f lower-flag
f flag-value?
f value>>
] ;
[ f ] [ flag-test-1 ] unit-test
@ -14,7 +15,7 @@ USING: tools.test concurrency.flags kernel threads locals ;
[let | f [ <flag> ] |
[ 1000 sleep f raise-flag ] "Flag test" spawn drop
f lower-flag
f flag-value?
f value>>
] ;
[ f ] [ flag-test-2 ] unit-test
@ -22,7 +23,7 @@ USING: tools.test concurrency.flags kernel threads locals ;
:: flag-test-3 ( -- )
[let | f [ <flag> ] |
f raise-flag
f flag-value?
f value>>
] ;
[ t ] [ flag-test-3 ] unit-test
@ -31,7 +32,7 @@ USING: tools.test concurrency.flags kernel threads locals ;
[let | f [ <flag> ] |
[ f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f flag-value?
f value>>
] ;
[ t ] [ flag-test-4 ] unit-test
@ -40,7 +41,13 @@ USING: tools.test concurrency.flags kernel threads locals ;
[let | f [ <flag> ] |
[ 1000 sleep f raise-flag ] "Flag test" spawn drop
f wait-for-flag
f flag-value?
f value>>
] ;
[ t ] [ flag-test-5 ] unit-test
[ ] [
{ 1 2 } <flag>
[ [ 1000 sleep raise-flag ] curry "Flag test" spawn drop ]
[ [ wait-for-flag drop ] curry parallel-each ] bi
] unit-test

20
extra/concurrency/flags/flags.factor
View File

@ -1,22 +1,20 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: boxes kernel threads ;
USING: dlists kernel threads concurrency.conditions accessors ;
IN: concurrency.flags
TUPLE: flag value? thread ;
TUPLE: flag value threads ;
: <flag> ( -- flag ) f <box> flag boa ;
: <flag> ( -- flag ) f <dlist> flag boa ;
: raise-flag ( flag -- )
dup flag-value? [
t over set-flag-value?
dup flag-thread [ resume ] if-box?
] unless drop ;
dup value>> [ drop ] [ t >>value threads>> notify-all ] if ;
: wait-for-flag-timeout ( flag timeout -- )
over value>> [ 2drop ] [ >r threads>> r> "flag" wait ] if ;
: wait-for-flag ( flag -- )
dup flag-value? [ drop ] [
[ flag-thread >box ] curry "flag" suspend drop
] if ;
f wait-for-flag-timeout ;
: lower-flag ( flag -- )
dup wait-for-flag f swap set-flag-value? ;
[ wait-for-flag ] [ f >>value drop ] bi ;

5
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -3,7 +3,7 @@
IN: concurrency.mailboxes
USING: dlists threads sequences continuations
namespaces random math quotations words kernel arrays assocs
init system concurrency.conditions accessors ;
init system concurrency.conditions accessors debugger ;
TUPLE: mailbox threads data closed ;
@ -83,6 +83,9 @@ M: mailbox dispose
TUPLE: linked-error error thread ;
M: linked-error error.
[ thread>> error-in-thread. ] [ error>> error. ] bi ;
C: <linked-error> linked-error
: ?linked dup linked-error? [ rethrow ] when ;

5
extra/contributors/contributors-tests.factor Normal file
View File

@ -0,0 +1,5 @@
IN: contributors.tests
USING: contributors tools.test ;
\ contributors must-infer
[ ] [ contributors ] unit-test

8
extra/contributors/contributors.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.styles io hashtables kernel
sequences sequences.lib assocs system sorting math.parser
sets ;
USING: io.files io.launcher io.styles io.encodings.ascii io
hashtables kernel sequences sequences.lib assocs system sorting
math.parser sets ;
IN: contributors
: changelog ( -- authors )
image parent-directory [
"git-log --pretty=format:%an" <process-reader> lines
"git-log --pretty=format:%an" ascii <process-reader> lines
] with-directory ;
: patch-counts ( authors -- assoc )

2
extra/help/lint/lint.factor
View File

@ -10,7 +10,7 @@ IN: help.lint
: check-example ( element -- )
rest [
1 head* "\n" join 1vector
but-last "\n" join 1vector
[
use [ clone ] change
[ eval>string ] with-datastack

2
extra/html/parser/analyzer/analyzer.factor
View File

@ -99,7 +99,7 @@ IN: html.parser.analyzer
: find-between ( i/f tag/f vector -- vector )
find-between* dup length 3 >= [
[ rest-slice 1 head-slice* ] keep like
[ rest-slice but-last-slice ] keep like
] when ;
: find-between-first ( string vector -- vector' )

2
extra/html/parser/utils/utils.factor
View File

@ -36,7 +36,7 @@ IN: html.parser.utils
dup quoted? [ quote ] unless ;
: unquote ( str -- newstr )
dup quoted? [ 1 head-slice* rest-slice >string ] when ;
dup quoted? [ but-last-slice rest-slice >string ] when ;
: quote? ( ch -- ? ) "'\"" member? ;

4
extra/http/http-tests.factor
View File

@ -166,7 +166,7 @@ test-db [
<dispatcher>
add-quit-action
<dispatcher>
"extra/http/test" resource-path <static> >>default
"resource:extra/http/test" <static> >>default
"nested" add-responder
<action>
[ "redirect-loop" f <standard-redirect> ] >>display
@ -178,7 +178,7 @@ test-db [
] unit-test
[ t ] [
"extra/http/test/foo.html" resource-path ascii file-contents
"resource:extra/http/test/foo.html" ascii file-contents
"http://localhost:1237/nested/foo.html" http-get =
] unit-test

2
extra/icfp/2006/2006.factor
View File

@ -148,4 +148,4 @@ SYMBOL: open-arrays
init f exec-loop ;
: run-sand ( -- )
"extra/icfp/2006/sandmark.umz" resource-path run-prog ;
"resource:extra/icfp/2006/sandmark.umz" run-prog ;

5
extra/interval-maps/interval-maps-tests.factor
View File

@ -11,3 +11,8 @@ SYMBOL: test
[ 2 ] [ 1 test get interval-at ] unit-test
[ f ] [ 2 test get interval-at ] unit-test
[ f ] [ 0 test get interval-at ] unit-test
[ { { { 1 4 } 3 } { { 4 8 } 6 } } <interval-map> ] must-fail
[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]
[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test

21
extra/interval-maps/interval-maps.factor
View File

@ -1,5 +1,5 @@
USING: kernel sequences arrays math.intervals accessors
math.order sorting math assocs ;
math.order sorting math assocs locals namespaces ;
IN: interval-maps
TUPLE: interval-map array ;
@ -24,6 +24,8 @@ M: interval >interval ;
: ensure-disjoint ( intervals -- intervals )
dup keys [ interval-intersect not ] monotonic?
[ "Intervals are not disjoint" throw ] unless ;
PRIVATE>
: interval-at* ( key map -- value ? )
@ -35,7 +37,20 @@ PRIVATE>
: interval-key? ( key map -- ? ) interval-at* nip ;
: <interval-map> ( specification -- map )
all-intervals ensure-disjoint
[ [ first to>> ] compare ] sort
all-intervals { } assoc-like
[ [ first to>> ] compare ] sort ensure-disjoint
[ interval-node boa ] { } assoc>map
interval-map boa ;
:: coalesce ( alist -- specification )
! Only works with integer keys, because they're discrete
! Makes 2array keys
[
alist sort-keys unclip first2 dupd roll
[| oldkey oldval key val | ! Underneath is start
oldkey 1+ key =
oldval val = and
[ oldkey 2array oldval 2array , key ] unless
key val
] assoc-each [ 2array ] bi@ ,
] { } make ;

2
extra/inverse/inverse.factor
View File

@ -197,7 +197,7 @@ DEFER: _
\ prefix [ unclip ] define-inverse
\ unclip [ prefix ] define-inverse
\ suffix [ dup 1 head* swap peek ] define-inverse
\ suffix [ dup but-last swap peek ] define-inverse
! Constructor inverse
: deconstruct-pred ( class -- quot )

5
extra/io/encodings/8-bit/8-bit.factor
View File

@ -30,9 +30,8 @@ IN: io.encodings.8-bit
} ;
: encoding-file ( file-name -- stream )
"extra/io/encodings/8-bit/" ".TXT"
swapd 3append resource-path
ascii <file-reader> ;
"resource:extra/io/encodings/8-bit/" ".TXT"
swapd 3append ascii <file-reader> ;
: tail-if ( seq n -- newseq )
2dup swap length <= [ tail ] [ drop ] if ;

24
extra/io/launcher/launcher.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.backend io.timeouts io.pipes system kernel
namespaces strings hashtables sequences assocs combinators
vocabs.loader init threads continuations math io.encodings
io.streams.duplex io.nonblocking io.streams.duplex accessors
concurrency.flags destructors ;
USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.streams.duplex io.nonblocking ;
IN: io.launcher
TUPLE: process < identity-tuple
@ -149,15 +149,11 @@ M: process set-timeout set-process-timeout ;
M: process timed-out kill-process ;
M: object pipeline-element-quot
[
>process
swap >>stdout
swap >>stdin
run-detached
] curry ;
M: process wait-for-pipeline-element wait-for-process ;
M: object run-pipeline-element
[ >process swap >>stdout swap >>stdin run-detached ]
[ drop [ [ close-handle ] when* ] bi@ ]
3bi
wait-for-process ;
: <process-reader*> ( process encoding -- process stream )
[

43
extra/io/pipes/pipes.factor
View File

@ -23,34 +23,31 @@ HOOK: (pipe) io-backend ( -- pipe )
r> <encoder-duplex>
] with-destructors ;
: with-fds ( input-fd output-fd quot -- )
>r >r [ <reader> dup add-always-destructor ] [ input-stream get ] if* r> r> [
>r [ <writer> dup add-always-destructor ] [ output-stream get ] if* r>
with-output-stream*
] 2curry with-input-stream* ; inline
<PRIVATE
: <pipes> ( n -- pipes )
[ (pipe) dup add-always-destructor ] replicate
f f pipe boa [ prefix ] [ suffix ] bi
2 <clumps> ;
: ?reader [ <reader> dup add-always-destructor ] [ input-stream get ] if* ;
: ?writer [ <writer> dup add-always-destructor ] [ output-stream get ] if* ;
: with-pipe-fds ( seq -- results )
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
M: callable run-pipeline-element
[
[ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
[ >r [ first in>> ] [ second out>> ] bi r> 2curry ] 2map
[ call ] parallel-map
>r [ ?reader ] [ ?writer ] bi*
r> with-streams*
] with-destructors ;
GENERIC: pipeline-element-quot ( obj -- quot )
: <pipes> ( n -- pipes )
[
[ (pipe) dup add-error-destructor ] replicate
T{ pipe } [ prefix ] [ suffix ] bi
2 <clumps>
] with-destructors ;
M: callable pipeline-element-quot
[ with-fds ] curry ;
GENERIC: wait-for-pipeline-element ( obj -- result )
M: object wait-for-pipeline-element ;
PRIVATE>
: run-pipeline ( seq -- results )
[ pipeline-element-quot ] map
with-pipe-fds
[ wait-for-pipeline-element ] map ;
[ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
[
>r [ first in>> ] [ second out>> ] bi
r> run-pipeline-element
] 2parallel-map ;

2
extra/io/unix/launcher/launcher-tests.factor
View File

@ -99,7 +99,7 @@ accessors kernel sequences io.encodings.utf8 ;
utf8 file-contents
] unit-test
[ ] [ "append-test" temp-file delete-file ] unit-test
[ "append-test" temp-file delete-file ] ignore-errors
[ "hi\nhi\n" ] [
2 [

8
extra/io/unix/macosx/macosx.factor
View File

@ -13,9 +13,11 @@ TUPLE: macosx-monitor < monitor handle ;
] curry each ;
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
path mailbox macosx-monitor new-monitor
dup [ enqueue-notifications ] curry
path 1array 0 0 <event-stream> >>handle ;
[let | path [ path normalize-path ] |
path mailbox macosx-monitor new-monitor
dup [ enqueue-notifications ] curry
path 1array 0 0 <event-stream> >>handle
] ;
M: macosx-monitor dispose
handle>> dispose ;

1
extra/io/unix/pipes/pipes-tests.factor
View File

@ -9,6 +9,7 @@ IN: io.unix.pipes.tests
"ls"
[
input-stream [ utf8 <decoder> ] change
output-stream [ utf8 <encoder> ] change
input-stream get lines reverse [ print ] each f
]
"grep x"

14
extra/io/windows/nt/launcher/launcher-tests.factor
View File

@ -41,7 +41,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test
[ ] [
"extra/io/windows/nt/launcher/test" resource-path [
"resource:extra/io/windows/nt/launcher/test" [
<process>
vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
@ -59,7 +59,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test
[ ] [
"extra/io/windows/nt/launcher/test" resource-path [
"resource:extra/io/windows/nt/launcher/test" [
<process>
vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
@ -73,7 +73,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test
[ "output" ] [
"extra/io/windows/nt/launcher/test" resource-path [
"resource:extra/io/windows/nt/launcher/test" [
<process>
vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr
@ -86,7 +86,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test
[ t ] [
"extra/io/windows/nt/launcher/test" resource-path [
"resource:extra/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
@ -96,7 +96,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test
[ t ] [
"extra/io/windows/nt/launcher/test" resource-path [
"resource:extra/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode
@ -108,7 +108,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test
[ "B" ] [
"extra/io/windows/nt/launcher/test" resource-path [
"resource:extra/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
@ -119,7 +119,7 @@ sequences parser assocs hashtables math continuations ;
] unit-test
[ f ] [
"extra/io/windows/nt/launcher/test" resource-path [
"resource:extra/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
{ { "HOME" "XXX" } } >>environment

12
extra/jamshred/deploy.factor Normal file
View File

@ -0,0 +1,12 @@
USING: tools.deploy.config ;
V{
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
{ deploy-name "Jamshred" }
}

21
extra/jamshred/game/game.factor
View File

@ -1,26 +1,31 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl arrays sequences jamshred.tunnel
jamshred.player math.vectors ;
USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ;
IN: jamshred.game
TUPLE: jamshred tunnel players running ;
TUPLE: jamshred sounds tunnel players running quit ;
: <jamshred> ( -- jamshred )
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
jamshred boa ;
<sounds> <random-tunnel> "Player 1" pick <player>
2dup swap play-in-tunnel 1array f f jamshred boa ;
: jamshred-player ( jamshred -- player )
! TODO: support more than one player
jamshred-players first ;
players>> first ;
: jamshred-update ( jamshred -- )
dup jamshred-running [
dup running>> [
jamshred-player update-player
] [ drop ] if ;
: toggle-running ( jamshred -- )
dup jamshred-running not swap set-jamshred-running ;
dup running>> [
f >>running drop
] [
[ jamshred-player moved ]
[ t >>running drop ] bi
] if ;
: mouse-moved ( x-radians y-radians jamshred -- )
jamshred-player -rot turn-player ;

59
extra/jamshred/jamshred.factor
View File

@ -1,38 +1,48 @@
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: alarms arrays calendar jamshred.game jamshred.gl kernel math
math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
math.vectors ;
USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ;
IN: jamshred
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
: <jamshred-gadget> ( jamshred -- gadget )
jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
jamshred-gadget construct-gadget swap >>jamshred ;
: default-width ( -- x ) 1024 ;
: default-height ( -- y ) 768 ;
: default-width ( -- x ) 800 ;
: default-height ( -- y ) 600 ;
M: jamshred-gadget pref-dim*
drop default-width default-height 2array ;
M: jamshred-gadget draw-gadget* ( gadget -- )
dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ;
[ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
: tick ( gadget -- )
dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
: jamshred-loop ( gadget -- )
dup jamshred>> quit>> [
drop
] [
dup [ jamshred>> jamshred-update ]
[ relayout-1 ] bi
yield jamshred-loop
] if ;
: fullscreen ( gadget -- )
find-world t swap set-fullscreen* ;
: no-fullscreen ( gadget -- )
find-world f swap set-fullscreen* ;
: toggle-fullscreen ( world -- )
[ fullscreen? not ] keep set-fullscreen* ;
M: jamshred-gadget graft* ( gadget -- )
[
[ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
] keep set-jamshred-gadget-alarm ;
[ jamshred-loop ] in-thread drop ;
M: jamshred-gadget ungraft* ( gadget -- )
[ jamshred-gadget-alarm cancel-alarm f ] keep
set-jamshred-gadget-alarm ;
jamshred>> t swap (>>quit) ;
: jamshred-restart ( jamshred-gadget -- )
<jamshred> swap set-jamshred-gadget-jamshred ;
<jamshred> >>jamshred drop ;
: pix>radians ( n m -- theta )
2 / / pi 2 * * ;
@ -46,22 +56,31 @@ M: jamshred-gadget ungraft* ( gadget -- )
rect-dim second pix>radians ;
: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
over jamshred-gadget-jamshred >r
over jamshred>> >r
[ first swap x>radians ] 2keep second swap y>radians
r> mouse-moved ;
: handle-mouse-motion ( jamshred-gadget -- )
hand-loc get [
over jamshred-gadget-last-hand-loc [
over last-hand-loc>> [
v- (handle-mouse-motion)
] [ 2drop ] if*
] 2keep swap set-jamshred-gadget-last-hand-loc ;
] 2keep >>last-hand-loc drop ;
: handle-mouse-scroll ( jamshred-gadget -- )
jamshred>> jamshred-player scroll-direction get
second neg swap change-player-speed ;
: quit ( gadget -- )
[ no-fullscreen ] [ close-window ] bi ;
USE: vocabs.loader
jamshred-gadget H{
{ T{ key-down f f "r" } [ jamshred-restart ] }
{ T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
{ T{ key-down f f " " } [ jamshred>> toggle-running ] }
{ T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
{ T{ key-down f f "q" } [ quit ] }
{ T{ motion } [ handle-mouse-motion ] }
{ T{ mouse-scroll } [ handle-mouse-scroll ] }
} set-gestures
: jamshred-window ( -- )

10
extra/jamshred/log/log.factor Normal file
View File

@ -0,0 +1,10 @@
USING: kernel logging ;
IN: jamshred.log
LOG: (jamshred-log) DEBUG
: with-jamshred-log ( quot -- )
"jamshred" swap with-logging ;
: jamshred-log ( message -- )
[ (jamshred-log) ] with-jamshred-log ; ! ugly...

8
extra/jamshred/oint/oint-tests.factor Normal file
View File

@ -0,0 +1,8 @@
USING: jamshred.oint tools.test ;
IN: jamshred.oint-tests
[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test

59
extra/jamshred/oint/oint.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
IN: jamshred.oint
! An oint is a point with three linearly independent unit vectors
@ -9,47 +9,25 @@ IN: jamshred.oint
! segment's location and orientation are given by an oint.
TUPLE: oint location forward up left ;
: <oint> ( location forward up left -- oint )
oint boa ;
! : x-rotation ( theta -- matrix )
! #! construct this matrix:
! #! { { 1 0 0 }
! #! { 0 cos(theta) sin(theta) }
! #! { 0 -sin(theta) cos(theta) } }
! dup sin neg swap cos 2dup 0 -rot 3float-array >r
! swap neg 0 -rot 3float-array >r
! { 1 0 0 } r> r> 3float-array ;
!
! : y-rotation ( theta -- matrix )
! #! costruct this matrix:
! #! { { cos(theta) 0 -sin(theta) }
! #! { 0 1 0 }
! #! { sin(theta) 0 cos(theta) } }
! dup sin swap cos 2dup
! 0 swap 3float-array >r
! { 0 1 0 } >r
! 0 rot neg 3float-array r> r> 3float-array ;
: apply-to-oint ( oint quot -- )
#! apply quot to each of forward, up, and left, storing the results
over oint-forward over call pick set-oint-forward
over oint-up over call pick set-oint-up
over oint-left swap call swap set-oint-left ;
C: <oint> oint
: rotation-quaternion ( theta axis -- quaternion )
swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
: rotate-vector ( q qrecip v -- v )
v>q swap q* q* q>v ;
: rotate-oint ( oint theta axis -- )
rotation-quaternion dup qrecip
[ rot v>q swap q* q* q>v ] curry curry apply-to-oint ;
rotation-quaternion dup qrecip pick
[ forward>> rotate-vector >>forward ]
[ up>> rotate-vector >>up ]
[ left>> rotate-vector >>left ] 3tri drop ;
: left-pivot ( oint theta -- )
over oint-left rotate-oint ;
over left>> rotate-oint ;
: up-pivot ( oint theta -- )
over oint-up rotate-oint ;
over up>> rotate-oint ;
: random-float+- ( n -- m )
#! find a random float between -n/2 and n/2
@ -59,10 +37,10 @@ TUPLE: oint location forward up left ;
2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
: go-forward ( distance oint -- )
tuck oint-forward n*v over oint-location v+ swap set-oint-location ;
[ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
: distance-vector ( oint oint -- vector )
oint-location swap oint-location v- ;
[ location>> ] bi@ swap v- ;
: distance ( oint oint -- distance )
distance-vector norm ;
@ -71,6 +49,13 @@ TUPLE: oint location forward up left ;
#! the scalar projection of v1 onto v2
tuck v. swap norm / ;
: proj-perp ( u v -- w )
dupd proj v- ;
: perpendicular-distance ( oint oint -- distance )
tuck distance-vector swap 2dup oint-left scalar-projection abs
-rot oint-up scalar-projection abs + ;
tuck distance-vector swap 2dup left>> scalar-projection abs
-rot up>> scalar-projection abs + ;
:: reflect ( v n -- v' )
#! bounce v on a surface with normal n
v v n v. n n v. / 2 * n n*v v- ;

64
extra/jamshred/player/player.factor
View File

@ -1,38 +1,68 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: colors jamshred.oint jamshred.tunnel kernel
math math.constants sequences ;
USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
IN: jamshred.player
TUPLE: player name tunnel nearest-segment ;
TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
: <player> ( name -- player )
f f player boa
F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
! speeds are in GL units / second
: default-speed ( -- speed ) 1.0 ;
: max-speed ( -- speed ) 30.0 ;
: <player> ( name sounds -- player )
[ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
f f f default-speed player boa ;
: turn-player ( player x-radians y-radians -- )
>r over r> left-pivot up-pivot ;
: to-tunnel-start ( player -- )
dup player-tunnel first dup oint-location pick set-oint-location
swap set-player-nearest-segment ;
[ tunnel>> first dup location>> ]
[ tuck (>>location) (>>nearest-segment) ] bi ;
: play-in-tunnel ( player segments -- )
over set-player-tunnel to-tunnel-start ;
>>tunnel to-tunnel-start ;
: update-nearest-segment ( player -- )
dup player-tunnel over dup player-nearest-segment nearest-segment
swap set-player-nearest-segment ;
[ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
[ (>>nearest-segment) ] tri ;
: max-speed ( -- speed )
0.3 ;
: moved ( player -- ) millis swap (>>last-move) ;
: player-speed ( player -- speed )
dup player-nearest-segment fraction-from-wall sq max-speed * ;
: speed-range ( -- range )
max-speed [0,b] ;
: change-player-speed ( inc player -- )
[ + speed-range clamp-to-range ] change-speed drop ;
: distance-to-move ( player -- distance )
[ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
[ (>>last-move) ] tri ;
DEFER: (move-player)
: ?bounce ( distance-remaining player -- )
over 0 > [
[ dup nearest-segment>> bounce ] [ sounds>> bang ]
[ (move-player) ] tri
] [
2drop
] if ;
: move-player-distance ( distance-remaining player distance -- distance-remaining player )
pick min tuck over go-forward [ - ] dip ;
: (move-player) ( distance-remaining player -- )
over 0 <= [
2drop
] [
dup dup nearest-segment>> distance-to-collision
move-player-distance ?bounce
] if ;
: move-player ( player -- )
dup player-speed over go-forward update-nearest-segment ;
[ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
: update-player ( player -- )
dup move-player player-nearest-segment
dup move-player nearest-segment>>
white swap set-segment-color ;

BIN
extra/jamshred/sound/bang.wav Normal file
View File

Binary file not shown.

13
extra/jamshred/sound/sound.factor Normal file
View File

@ -0,0 +1,13 @@
USING: accessors io.files kernel openal sequences ;
IN: jamshred.sound
TUPLE: sounds bang ;
: assign-sound ( source wav-path -- )
resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
: <sounds> ( -- sounds )
init-openal 1 gen-sources first sounds boa
dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
: bang ( sounds -- ) bang>> source-play check-error ;

31
extra/jamshred/tunnel/tunnel-tests.factor
View File

@ -3,8 +3,8 @@
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
IN: jamshred.tunnel.tests
[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 }
T{ segment T{ oint f { 1 1 1 } } 1 }
[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
T{ segment f { 1 1 1 } f f f 1 }
T{ oint f { 0 0 0.25 } }
nearer-segment segment-number ] unit-test
@ -15,3 +15,30 @@ IN: jamshred.tunnel.tests
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
: test-segment-oint ( -- oint )
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
: simplest-straight-ahead ( -- oint segment )
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
initial-segment ;
[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
: simple-collision-up ( -- oint segment )
{ 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
initial-segment ;
[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
[ { 0 1 0 } ] [ simple-collision-up collision-vector ] unit-test

81
extra/jamshred/tunnel/tunnel.factor
View File

@ -1,23 +1,20 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: arrays float-arrays kernel jamshred.oint math math.functions
math.ranges math.vectors math.constants random sequences vectors ;
USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
IN: jamshred.tunnel
: n-segments ( -- n ) 5000 ; inline
TUPLE: segment number color radius ;
: <segment> ( number color radius location forward up left -- segment )
<oint> >r segment boa r> over set-delegate ;
TUPLE: segment < oint number color radius ;
C: <segment> segment
: segment-vertex ( theta segment -- vertex )
tuck 2dup oint-up swap sin v*n
>r oint-left swap cos v*n r> v+
swap oint-location v+ ;
tuck 2dup up>> swap sin v*n
>r left>> swap cos v*n r> v+
swap location>> v+ ;
: segment-vertex-normal ( vertex segment -- normal )
oint-location swap v- normalize ;
location>> swap v- normalize ;
: segment-vertex-and-normal ( segment theta -- vertex normal )
swap [ segment-vertex ] keep dupd segment-vertex-normal ;
@ -27,7 +24,7 @@ TUPLE: segment number color radius ;
dup [ / pi 2 * * ] curry map ;
: segment-number++ ( segment -- )
dup segment-number 1+ swap set-segment-number ;
[ number>> 1+ ] keep (>>number) ;
: random-color ( -- color )
{ 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
@ -50,15 +47,15 @@ TUPLE: segment number color radius ;
: default-segment-radius ( -- r ) 1 ;
: initial-segment ( -- segment )
0 random-color default-segment-radius
F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
0 random-color default-segment-radius <segment> ;
: random-segments ( n -- segments )
initial-segment 1vector swap (random-segments) ;
: simple-segment ( n -- segment )
random-color default-segment-radius pick F{ 0 0 -1 } n*v
F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
[ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
random-color default-segment-radius <segment> ;
: simple-segments ( n -- segments )
[ simple-segment ] map ;
@ -100,14 +97,54 @@ TUPLE: segment number color radius ;
[ nearest-segment-forward ] 3keep
nearest-segment-backward r> nearer-segment ;
: distance-from-centre ( oint segment -- distance )
perpendicular-distance ;
: vector-to-centre ( seg loc -- v )
over location>> swap v- swap forward>> proj-perp ;
: distance-from-wall ( oint segment -- distance )
tuck distance-from-centre swap segment-radius swap - ;
: distance-from-centre ( seg loc -- distance )
vector-to-centre norm ;
: fraction-from-centre ( oint segment -- fraction )
tuck distance-from-centre swap segment-radius / ;
: wall-normal ( seg oint -- n )
location>> vector-to-centre normalize ;
: fraction-from-wall ( oint segment -- fraction )
: from ( seg loc -- radius d-f-c )
dupd location>> distance-from-centre [ radius>> ] dip ;
: distance-from-wall ( seg loc -- distance ) from - ;
: fraction-from-centre ( seg loc -- fraction ) from / ;
: fraction-from-wall ( seg loc -- fraction )
fraction-from-centre 1 swap - ;
:: collision-coefficient ( v w r -- c )
[let* | a [ v dup v. ]
b [ v w v. 2 * ]
c [ w dup v. r sq - ] |
c b a quadratic max ] ;
: sideways-heading ( oint segment -- v )
[ forward>> ] bi@ proj-perp ;
: sideways-relative-location ( oint segment -- loc )
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
: collision-vector ( oint segment -- v )
[ sideways-heading ] [ sideways-relative-location ] [ radius>> ] 2tri
swap [ collision-coefficient ] dip forward>> n*v ;
: distance-to-collision ( oint segment -- distance )
collision-vector norm ;
: bounce-forward ( segment oint -- )
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
: bounce-left ( segment oint -- )
#! must be done after forward
[ forward>> vneg ] dip [ left>> swap reflect ]
[ forward>> proj-perp normalize ] [ (>>left) ] tri ;
: bounce-up ( segment oint -- )
#! must be done after forward and left!
nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
: bounce ( oint segment -- )
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;

2
extra/koszul/koszul.factor
View File

@ -184,7 +184,7 @@ DEFER: (d)
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ;
basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )

1
extra/lcs/authors.txt Executable file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

35
extra/lcs/lcs-docs.factor Executable file
View File

@ -0,0 +1,35 @@
USING: help.syntax help.markup ;
IN: lcs
HELP: levenshtein
{ $values { "old" "a sequence" } { "new" "a sequence" } { "n" "the Levenshtein distance" } }
{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;
HELP: lcs
{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "lcs" "a longest common subsequence" } }
{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ;
HELP: diff
{ $values { "old" "a sequence" } { "new" "a sequence" } { "diff" "an edit script" } }
{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ;
HELP: retain
{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ;
HELP: delete
{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ;
HELP: insert
{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ;
ARTICLE: "lcs" "LCS, Diffing and Distance"
"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences."
{ $subsection lcs }
{ $subsection diff }
{ $subsection levenshtein }
"The " { $link diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot."
{ $subsection insert }
{ $subsection delete }
{ $subsection retain } ;
ABOUT: "lcs"

25
extra/lcs/lcs-tests.factor Executable file
View File

@ -0,0 +1,25 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
[ "hell" ] [ "hello" "hell" lcs ] unit-test
[ "hell" ] [ "hell" "hello" lcs ] unit-test
[ "ell" ] [ "ell" "hell" lcs ] unit-test
[ "ell" ] [ "hell" "ell" lcs ] unit-test
[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
[ {
T{ delete f CHAR: f }
T{ retain f CHAR: a }
T{ delete f CHAR: x }
T{ retain f CHAR: b }
T{ delete f CHAR: c }
T{ retain f CHAR: d }
T{ insert f CHAR: e }
T{ insert f CHAR: f }
} ] [ "faxbcd" "abdef" diff ] unit-test

97
extra/lcs/lcs.factor Executable file
View File

@ -0,0 +1,97 @@
USING: sequences kernel math locals math.order math.ranges
accessors combinators.lib arrays namespaces combinators ;
IN: lcs
<PRIVATE
: levenshtein-step ( insert delete change same? -- next )
0 1 ? + >r [ 1+ ] bi@ r> min min ;
: lcs-step ( insert delete change same? -- next )
1 -9999 ? + max max ; ! Replace -9999 with -inf when added
:: loop-step ( i j matrix old new step -- )
i j 1+ matrix nth nth ! insertion
i 1+ j matrix nth nth ! deletion
i j matrix nth nth ! replace/retain
i old nth j new nth = ! same?
step call
i 1+ j 1+ matrix nth set-nth ; inline
: lcs-initialize ( |str1| |str2| -- matrix )
[ drop 0 <array> ] with map ;
: levenshtein-initialize ( |str1| |str2| -- matrix )
[ [ + ] curry map ] with map ;
:: run-lcs ( old new init step -- matrix )
[let | matrix [ old length 1+ new length 1+ init call ] |
old length [0,b) [| i |
new length [0,b)
[| j | i j matrix old new step loop-step ]
each
] each matrix ] ; inline
PRIVATE>
: levenshtein ( old new -- n )
[ levenshtein-initialize ] [ levenshtein-step ]
run-lcs peek peek ;
TUPLE: retain item ;
TUPLE: delete item ;
TUPLE: insert item ;
<PRIVATE
TUPLE: trace-state old new table i j ;
: old-nth ( state -- elt )
[ i>> 1- ] [ old>> ] bi nth ;
: new-nth ( state -- elt )
[ j>> 1- ] [ new>> ] bi nth ;
: top-beats-side? ( state -- ? )
[ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]
[ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;
: retained? ( state -- ? )
{
[ i>> 0 > ] [ j>> 0 > ]
[ [ old-nth ] [ new-nth ] bi = ]
} <-&& ;
: do-retain ( state -- state )
dup old-nth retain boa ,
[ 1- ] change-i [ 1- ] change-j ;
: inserted? ( state -- ? )
[ j>> 0 > ]
[ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;
: do-insert ( state -- state )
dup new-nth insert boa , [ 1- ] change-j ;
: deleted? ( state -- ? )
[ i>> 0 > ]
[ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;
: do-delete ( state -- state )
dup old-nth delete boa , [ 1- ] change-i ;
: (trace-diff) ( state -- )
{
{ [ dup retained? ] [ do-retain (trace-diff) ] }
{ [ dup inserted? ] [ do-insert (trace-diff) ] }
{ [ dup deleted? ] [ do-delete (trace-diff) ] }
[ drop ] ! i=j=0
} cond ;
: trace-diff ( old new table -- diff )
[ ] [ first length 1- ] [ length 1- ] tri trace-state boa
[ (trace-diff) ] { } make reverse ;
PRIVATE>
: diff ( old new -- diff )
2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
: lcs ( seq1 seq2 -- lcs )
[ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;

1
extra/lcs/summary.txt Executable file
View File

@ -0,0 +1 @@
Levenshtein distance and diff between sequences

1
extra/lcs/tags.txt Executable file
View File

@ -0,0 +1 @@
algorithms

1
extra/levenshtein/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

9
extra/levenshtein/levenshtein-tests.factor
View File

@ -1,9 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: levenshtein.tests
USING: tools.test levenshtein ;
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test

47
extra/levenshtein/levenshtein.factor
View File

@ -1,47 +0,0 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help io kernel math namespaces sequences
math.order ;
IN: levenshtein
: <matrix> ( m n -- matrix )
[ drop 0 <array> ] with map ; inline
: matrix-> nth nth ; inline
: ->matrix nth set-nth ; inline
SYMBOL: d
: ->d ( n i j -- ) d get ->matrix ; inline
: d-> ( i j -- n ) d get matrix-> ; inline
SYMBOL: costs
: init-d ( str1 str2 -- )
[ length 1+ ] bi@ 2dup <matrix> d set
[ 0 over ->d ] each
[ dup 0 ->d ] each ; inline
: compute-costs ( str1 str2 -- )
swap [
[ = 0 1 ? ] with { } map-as
] curry { } map-as costs set ; inline
: levenshtein-step ( i j -- )
[ 1+ d-> 1+ ] 2keep
[ >r 1+ r> d-> 1+ ] 2keep
[ d-> ] 2keep
[ costs get matrix-> + min min ] 2keep
>r 1+ r> 1+ ->d ; inline
: levenshtein-result ( -- n ) d get peek peek ; inline
: levenshtein ( str1 str2 -- n )
[
2dup init-d
2dup compute-costs
[ length ] bi@ [
[ levenshtein-step ] curry each
] with each
levenshtein-result
] with-scope ;

1
extra/levenshtein/summary.txt
View File

@ -1 +0,0 @@
Levenshtein edit distance algorithm

24
extra/locals/locals-docs.factor
View File

@ -2,15 +2,6 @@ USING: help.syntax help.markup kernel macros prettyprint
memoize ;
IN: locals
<PRIVATE
: $with-locals-note
drop {
"This form must appear either in a word defined by " { $link POSTPONE: :: } " or " { $link POSTPONE: MACRO:: } ", or alternatively, " { $link with-locals } " must be called on the top-level form of the word to perform closure conversion."
} $notes ;
PRIVATE>
HELP: [|
{ $syntax "[| bindings... | body... ]" }
{ $description "A lambda abstraction. When called, reads stack values into the bindings from left to right; the body may then refer to these bindings." }
@ -22,8 +13,7 @@ HELP: [|
"3 5 adder call ."
"8"
}
}
$with-locals-note ;
} ;
HELP: [let
{ $syntax "[let | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
@ -38,8 +28,7 @@ HELP: [let
"6 { 36 14 } frobnicate ."
"{ 36 2 }"
}
}
$with-locals-note ;
} ;
HELP: [let*
{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
@ -55,8 +44,7 @@ HELP: [let*
"1 { 32 48 } frobnicate ."
"{ 2 3 }"
}
}
$with-locals-note ;
} ;
{ POSTPONE: [let POSTPONE: [let* } related-words
@ -75,10 +63,6 @@ HELP: [wlet
}
} ;
HELP: with-locals
{ $values { "form" "a quotation, lambda, let or wlet form" } { "quot" "a quotation" } }
{ $description "Performs closure conversion of a lexically-scoped form. All nested sub-forms are converted. This word must be applied to a " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " used in an ordinary definition, however forms in " { $link POSTPONE: :: } " and " { $link POSTPONE: MACRO:: } " definitions are automatically closure-converted and there is no need to use this word." } ;
HELP: ::
{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
@ -136,8 +120,6 @@ $nl
{ $subsection POSTPONE: :: }
{ $subsection POSTPONE: MEMO:: }
{ $subsection POSTPONE: MACRO:: }
"Explicit closure conversion outside of applicative word definitions:"
{ $subsection with-locals }
"Lexical binding forms:"
{ $subsection POSTPONE: [let }
{ $subsection POSTPONE: [let* }

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