Merge branch 'master' of git://factorcode.org/git/factor
commit
17f395281a
|
@ -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
|
||||
|
||||
|
|
|
@ -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" } ;
|
||||
|
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ] [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" } }
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ( -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 {
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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?
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ,
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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* ]
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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." }
|
||||
|
|
|
@ -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> ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -53,3 +53,5 @@ M: f item-check drop 0 ;
|
|||
|
||||
: binary-trees-main ( -- )
|
||||
16 binary-trees ;
|
||||
|
||||
MAIN: binary-trees-main
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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,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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
|
@ -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
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -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 ;
|
||||
|
|
|
@ -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 } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -0,0 +1,5 @@
|
|||
IN: contributors.tests
|
||||
USING: contributors tools.test ;
|
||||
|
||||
\ contributors must-infer
|
||||
[ ] [ contributors ] unit-test
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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' )
|
||||
|
|
|
@ -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? ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" }
|
||||
}
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ( -- )
|
||||
|
|
|
@ -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...
|
|
@ -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
|
|
@ -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- ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Binary file not shown.
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
|
@ -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"
|
|
@ -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
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Levenshtein distance and diff between sequences
|
|
@ -0,0 +1 @@
|
|||
algorithms
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
|
@ -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
|
|
@ -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 +0,0 @@
|
|||
Levenshtein edit distance algorithm
|
|
@ -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
Loading…
Reference in New Issue