diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6149e83893..3ce783d620 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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 diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor index c352f02af4..9196008ba6 100644 --- a/core/checksums/checksums-docs.factor +++ b/core/checksums/checksums-docs.factor @@ -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" } ; diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor new file mode 100644 index 0000000000..1ec675b0cf --- /dev/null +++ b/core/checksums/checksums-tests.factor @@ -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 diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 0cde687f16..fb9530b1c5 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ee7ff8c608..5ebcc7a286 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 ) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 806ea914bb..ef00e94dd5 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -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 ] [ diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 11f64c9373..9594cf7b23 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -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 diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 996d17077c..28581820fd 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -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 diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 3e675b1f0f..78effb043a 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -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 ) 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 ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 5f396e7751..9c44a6a656 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -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 ( -- ) diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index f0ca47a1ba..88881b19a8 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -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 diff --git a/core/cpu/x86/assembler/assembler-tests.factor b/core/cpu/x86/assembler/assembler-tests.factor index caa00bd618..4c0f04fcc2 100644 --- a/core/cpu/x86/assembler/assembler-tests.factor +++ b/core/cpu/x86/assembler/assembler-tests.factor @@ -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 OR ] { } make ] unit-test +[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 MOV ] { } make ] unit-test diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index cabd81dad6..bc6a12d167 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -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 + ; ! 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 ; : ( 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 diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index c48f33b765..667f08c053 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -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 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 MOV ] unless ; \ set-slot { diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor index cb79597a73..9dd23c6011 100755 --- a/core/debugger/debugger-docs.factor +++ b/core/debugger/debugger-docs.factor @@ -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 diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index e5dd02c25e..df7d33f41c 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -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 ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index b68c98d25d..ff5fc478ca 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -362,7 +362,7 @@ M: object infer-call \ gc { } { } set-primitive-effect -\ gc-time { } { integer } set-primitive-effect +\ gc-stats { } { array } set-primitive-effect \ save-image { string } { } set-primitive-effect @@ -372,7 +372,7 @@ M: object infer-call t over set-effect-terminated? set-primitive-effect -\ data-room { } { integer array } set-primitive-effect +\ data-room { } { integer integer array } set-primitive-effect \ data-room make-flushable \ code-room { } { integer integer integer integer } set-primitive-effect diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor index 84d72bdd9b..c63786dc9e 100644 --- a/core/inference/state/state-tests.factor +++ b/core/inference/state/state-tests.factor @@ -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 diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor index a426f410e2..6f0eecf2d9 100755 --- a/core/inference/state/state.factor +++ b/core/inference/state/state.factor @@ -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? diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 624dcbbf98..0040629edd 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -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 diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor index 79922b019c..e6b180fde2 100755 --- a/core/io/encodings/encodings-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -2,11 +2,8 @@ USING: io.files io.streams.string io tools.test kernel io.encodings.ascii ; IN: io.streams.encodings.tests -: ( resource -- stream ) - resource-path ascii ; - [ { } ] -[ "core/io/test/empty-file.txt" lines ] +[ "resource:core/io/test/empty-file.txt" ascii 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" lines-test + "resource:core/io/test/windows-eol.txt" + ascii lines-test ] unit-test [ "This is a line." "This is another line." ] [ - "core/io/test/mac-os-eol.txt" lines-test + "resource:core/io/test/mac-os-eol.txt" + ascii lines-test ] unit-test [ "This is a line." "This is another line." ] [ - "core/io/test/unix-eol.txt" lines-test + "resource:core/io/test/unix-eol.txt" + ascii lines-test ] unit-test [ diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index d18babf31b..ec74bb001e 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -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 diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index ddea4da556..2d74dfabd5 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -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 diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 7204bde6fb..50a798d290 100755 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -8,20 +8,17 @@ IN: io.tests "foo" "io.tests" lookup ] unit-test -: ( resource -- stream ) - resource-path latin1 ; - [ "This is a line.\rThis is another line.\r" ] [ - "core/io/test/mac-os-eol.txt" + "resource:core/io/test/mac-os-eol.txt" latin1 [ 500 read ] with-input-stream ] unit-test [ 255 ] [ - "core/io/test/binary.txt" + "resource:core/io/test/binary.txt" latin1 [ read1 ] with-input-stream >fixnum ] unit-test @@ -36,7 +33,8 @@ IN: io.tests } ] [ [ - "core/io/test/separator-test.txt" [ + "resource:core/io/test/separator-test.txt" + latin1 [ "J" read-until 2array , "i" read-until 2array , "X" read-until 2array , diff --git a/core/io/io.factor b/core/io/io.factor index e28fd28fb3..6bad8331db 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -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 ) diff --git a/core/listener/listener.factor b/core/listener/listener.factor index cc4580c2cf..e00e64f4bc 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -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* ] diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index 75876a3c8f..38f39ec588 100755 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -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." } ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index e94670992c..0faae398e9 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -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 ; diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 5f32539115..11fa4da28e 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -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 ) 0 1 f 0 pprinter boa ; +: ( -- 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 diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 2a2fcf29cd..8b15f5b980 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -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 } { $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." } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index f39bf08e58..8d0e3eec18 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 ; : ( seq -- slice ) dup slice? [ { } like ] when 0 over length rot ; diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 62c5121e50..9f6ae75d32 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -104,7 +104,7 @@ M: sliced-clumps nth group@ ; 1array ] [ "\n" split [ - 1 head-slice* [ + but-last-slice [ "\r" ?tail drop "\r" split ] map ] keep peek "\r" split suffix concat diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 0ac607f0ed..0e33ccd94c 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -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 [ ] g [ gensym ] | + [ + g "x" set + [ "x" get p fulfill ] "B" spawn drop + ] with-scope + p ?promise g eq? + ] ; + +[ t ] [ spawn-namespace-test ] unit-test diff --git a/core/threads/threads.factor b/core/threads/threads.factor index cbca7ac029..a1c7e208dc 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -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 + [ ] 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 ) [ (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" ] cache >>continuation + t >>runnable f >>state dup register-thread set-self ; diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index a75251331f..c00087fc9f 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -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 ) diff --git a/extra/benchmark/binary-trees/binary-trees.factor b/extra/benchmark/binary-trees/binary-trees.factor index 6e63877989..bd3d460961 100644 --- a/extra/benchmark/binary-trees/binary-trees.factor +++ b/extra/benchmark/binary-trees/binary-trees.factor @@ -53,3 +53,5 @@ M: f item-check drop 0 ; : binary-trees-main ( -- ) 16 binary-trees ; + +MAIN: binary-trees-main diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 215b677e16..d449c0fc5b 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -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 ; diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index e06b81f6de..6bd2d69cfa 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -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 ; diff --git a/extra/benchmark/partial-sums/partial-sums.factor b/extra/benchmark/partial-sums/partial-sums.factor index b4bb1fa8d2..8eb883241b 100644 --- a/extra/benchmark/partial-sums/partial-sums.factor +++ b/extra/benchmark/partial-sums/partial-sums.factor @@ -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 ; diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 1c33bfc4dc..6defd94290 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -10,7 +10,7 @@ SYMBOL: counter : server-addr "127.0.0.1" 7777 ; : server-loop ( server -- ) - dup accept [ + dup accept drop [ [ read1 CHAR: x = [ "server" get dispose diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 957af28dc1..2a0769f278 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -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 ; diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index c40efaaa04..f9ab6c1d1d 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -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 ; diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor index 1bbad29835..a3b13c9691 100755 --- a/extra/cairo/png/png.factor +++ b/extra/cairo/png/png.factor @@ -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 ; : ( path -- png ) normalize-path diff --git a/extra/checksums/adler-32/adler-32-docs.factor b/extra/checksums/adler-32/adler-32-docs.factor new file mode 100755 index 0000000000..b7400cbaa0 --- /dev/null +++ b/extra/checksums/adler-32/adler-32-docs.factor @@ -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" diff --git a/extra/checksums/adler-32/adler-32-tests.factor b/extra/checksums/adler-32/adler-32-tests.factor new file mode 100644 index 0000000000..ccee74baae --- /dev/null +++ b/extra/checksums/adler-32/adler-32-tests.factor @@ -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 adler-32 checksum-bytes ] unit-test diff --git a/extra/checksums/adler-32/adler-32.factor b/extra/checksums/adler-32/adler-32.factor new file mode 100644 index 0000000000..1be4bfb584 --- /dev/null +++ b/extra/checksums/adler-32/adler-32.factor @@ -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] v. ] [ length ] bi + ] bi + [ adler-32-modulus mod ] bi@ 16 shift bitor ; diff --git a/extra/checksums/adler-32/authors.txt b/extra/checksums/adler-32/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/checksums/adler-32/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/checksums/null/null.factor b/extra/checksums/null/null.factor index d2dc305ac2..d3ab878a12 100644 --- a/extra/checksums/null/null.factor +++ b/extra/checksums/null/null.factor @@ -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 ; diff --git a/extra/cocoa/application/application-docs.factor b/extra/cocoa/application/application-docs.factor index ad2f8ffbd9..01a79cf35a 100644 --- a/extra/cocoa/application/application-docs.factor +++ b/extra/cocoa/application/application-docs.factor @@ -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 } ; diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor index 2ae17a1604..90159c1656 100755 --- a/extra/cocoa/application/application.factor +++ b/extra/cocoa/application/application.factor @@ -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 diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 84b41a91ff..5dfe8527c1 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -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 ; diff --git a/extra/concurrency/combinators/combinators-docs.factor b/extra/concurrency/combinators/combinators-docs.factor index bbf8fb0f5f..a23301c1e2 100755 --- a/extra/concurrency/combinators/combinators-docs.factor +++ b/extra/concurrency/combinators/combinators-docs.factor @@ -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" diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index 3381cba5e8..562111242d 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -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 diff --git a/extra/concurrency/combinators/combinators.factor b/extra/concurrency/combinators/combinators.factor index 3c4101e381..eab0ed4cb4 100755 --- a/extra/concurrency/combinators/combinators.factor +++ b/extra/concurrency/combinators/combinators.factor @@ -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 r> keep await ; inline : parallel-each ( seq quot -- ) - over length - [ [ >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 ; diff --git a/extra/concurrency/count-downs/count-downs.factor b/extra/concurrency/count-downs/count-downs.factor index 6a75f7206c..93cef250a1 100755 --- a/extra/concurrency/count-downs/count-downs.factor +++ b/extra/concurrency/count-downs/count-downs.factor @@ -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 ; : ( 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 ; diff --git a/extra/concurrency/flags/flags-tests.factor b/extra/concurrency/flags/flags-tests.factor index f23ea95167..9d3f6de98c 100755 --- a/extra/concurrency/flags/flags-tests.factor +++ b/extra/concurrency/flags/flags-tests.factor @@ -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 [ ] | [ 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 [ ] | [ 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 [ ] | 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 [ ] | [ 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 [ ] | [ 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 } + [ [ 1000 sleep raise-flag ] curry "Flag test" spawn drop ] + [ [ wait-for-flag drop ] curry parallel-each ] bi +] unit-test diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor index b3c76a7a01..ec260961d0 100755 --- a/extra/concurrency/flags/flags.factor +++ b/extra/concurrency/flags/flags.factor @@ -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 ) f flag boa ; +: ( -- flag ) f 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 ; diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index ac03197708..aa4dc2df3d 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -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 dup linked-error? [ rethrow ] when ; diff --git a/extra/contributors/contributors-tests.factor b/extra/contributors/contributors-tests.factor new file mode 100644 index 0000000000..1476715588 --- /dev/null +++ b/extra/contributors/contributors-tests.factor @@ -0,0 +1,5 @@ +IN: contributors.tests +USING: contributors tools.test ; + +\ contributors must-infer +[ ] [ contributors ] unit-test diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 4b7acb468c..9f2d5a55fa 100755 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -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" lines + "git-log --pretty=format:%an" ascii lines ] with-directory ; : patch-counts ( authors -- assoc ) diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index fc4b7f6f25..a9ec7f9267 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -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 diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 160b95ab1d..e9906f3f2a 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -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' ) diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 0ae75e41fd..5083b1cec2 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -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? ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 07b34f17c3..21eb241b84 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -166,7 +166,7 @@ test-db [ add-quit-action - "extra/http/test" resource-path >>default + "resource:extra/http/test" >>default "nested" add-responder [ "redirect-loop" f ] >>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 diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index e88301c7f8..ca6f9d5905 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -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 ; diff --git a/extra/interval-maps/interval-maps-tests.factor b/extra/interval-maps/interval-maps-tests.factor index 54d2e9d26b..5a4b508939 100755 --- a/extra/interval-maps/interval-maps-tests.factor +++ b/extra/interval-maps/interval-maps-tests.factor @@ -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 } } ] 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 diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor index bc23d0d346..7dcb9466cc 100755 --- a/extra/interval-maps/interval-maps.factor +++ b/extra/interval-maps/interval-maps.factor @@ -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 ; : ( 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 ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 265675f8df..705c2d070b 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -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 ) diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 3fbb3908e2..88414efd16 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -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 ; + "resource:extra/io/encodings/8-bit/" ".TXT" + swapd 3append ascii ; : tail-if ( seq n -- newseq ) 2dup swap length <= [ tail ] [ drop ] if ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index a47e2d3367..e8eb973e34 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -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 encoding -- process stream ) [ diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index 3e91c5e48e..72d27372f3 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -23,34 +23,31 @@ HOOK: (pipe) io-backend ( -- pipe ) r> ] with-destructors ; -: with-fds ( input-fd output-fd quot -- ) - >r >r [ dup add-always-destructor ] [ input-stream get ] if* r> r> [ - >r [ dup add-always-destructor ] [ output-stream get ] if* r> - with-output-stream* - ] 2curry with-input-stream* ; inline + ( n -- pipes ) - [ (pipe) dup add-always-destructor ] replicate - f f pipe boa [ prefix ] [ suffix ] bi - 2 ; +: ?reader [ dup add-always-destructor ] [ input-stream get ] if* ; +: ?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- ] 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 ) +: ( n -- pipes ) + [ + [ (pipe) dup add-error-destructor ] replicate + T{ pipe } [ prefix ] [ suffix ] bi + 2 + ] 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- ] if ] keep + [ + >r [ first in>> ] [ second out>> ] bi + r> run-pipeline-element + ] 2parallel-map ; diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 97ffc5287f..177c5775dc 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -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 [ diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 0a0aec6ab6..8a5d0c490f 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -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 >>handle ; + [let | path [ path normalize-path ] | + path mailbox macosx-monitor new-monitor + dup [ enqueue-notifications ] curry + path 1array 0 0 >>handle + ] ; M: macosx-monitor dispose handle>> dispose ; diff --git a/extra/io/unix/pipes/pipes-tests.factor b/extra/io/unix/pipes/pipes-tests.factor index 8ff9ba61c8..27a490d801 100644 --- a/extra/io/unix/pipes/pipes-tests.factor +++ b/extra/io/unix/pipes/pipes-tests.factor @@ -9,6 +9,7 @@ IN: io.unix.pipes.tests "ls" [ input-stream [ utf8 ] change + output-stream [ utf8 ] change input-stream get lines reverse [ print ] each f ] "grep x" diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor index c5c0e6dec2..254f845c48 100755 --- a/extra/io/windows/nt/launcher/launcher-tests.factor +++ b/extra/io/windows/nt/launcher/launcher-tests.factor @@ -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" [ 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" [ 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" [ 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" [ vm "-script" "env.factor" 3array >>command ascii 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" [ 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" [ 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" [ vm "-script" "env.factor" 3array >>command { { "HOME" "XXX" } } >>environment diff --git a/extra/jamshred/deploy.factor b/extra/jamshred/deploy.factor new file mode 100644 index 0000000000..9a18cf1f9b --- /dev/null +++ b/extra/jamshred/deploy.factor @@ -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" } +} diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index 3842816f0e..dcb82d1de0 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -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 ) - "Player 1" 2dup swap play-in-tunnel 1array f - jamshred boa ; + "Player 1" pick + 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 ; + diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 42414b9893..3fb7113fde 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -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 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 -- ) - swap set-jamshred-gadget-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 ( -- ) diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor new file mode 100644 index 0000000000..33498d8a2e --- /dev/null +++ b/extra/jamshred/log/log.factor @@ -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... diff --git a/extra/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor new file mode 100644 index 0000000000..401935fd01 --- /dev/null +++ b/extra/jamshred/oint/oint-tests.factor @@ -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 diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 11a89b314f..e2104b6f41 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -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 ; - -: ( 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 : 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- ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 17843ef9c2..bea4ab4836 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -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 ; -: ( name -- player ) - f f player boa - F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } over set-delegate ; +! speeds are in GL units / second +: default-speed ( -- speed ) 1.0 ; +: max-speed ( -- speed ) 30.0 ; + +: ( 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 ; diff --git a/extra/jamshred/sound/bang.wav b/extra/jamshred/sound/bang.wav new file mode 100644 index 0000000000..b15af141ec Binary files /dev/null and b/extra/jamshred/sound/bang.wav differ diff --git a/extra/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor new file mode 100644 index 0000000000..fd1b1127bd --- /dev/null +++ b/extra/jamshred/sound/sound.factor @@ -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 ) + init-openal 1 gen-sources first sounds boa + dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ; + +: bang ( sounds -- ) bang>> source-play check-error ; diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 8031678896..c6755318e6 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -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 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test [ F{ 0 0 0 } ] [ 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 } ; + +[ { -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 } + 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 } + 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 diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index c3f6b37fb8..139cdbfb53 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -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 ; - -: ( number color radius location forward up left -- segment ) - >r segment boa r> over set-delegate ; +TUPLE: segment < oint number color radius ; +C: 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 } ; + F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } + 0 random-color default-segment-radius ; : 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 } ; + [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep + random-color default-segment-radius ; : 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 ; + diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index e9de82ebb6..aecae1cf88 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -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 ) diff --git a/extra/lcs/authors.txt b/extra/lcs/authors.txt new file mode 100755 index 0000000000..504363d316 --- /dev/null +++ b/extra/lcs/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/lcs/lcs-docs.factor b/extra/lcs/lcs-docs.factor new file mode 100755 index 0000000000..49e46c7641 --- /dev/null +++ b/extra/lcs/lcs-docs.factor @@ -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" diff --git a/extra/lcs/lcs-tests.factor b/extra/lcs/lcs-tests.factor new file mode 100755 index 0000000000..3aa10a0687 --- /dev/null +++ b/extra/lcs/lcs-tests.factor @@ -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 diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor new file mode 100755 index 0000000000..cdebfc4325 --- /dev/null +++ b/extra/lcs/lcs.factor @@ -0,0 +1,97 @@ +USING: sequences kernel math locals math.order math.ranges +accessors combinators.lib arrays namespaces combinators ; +IN: lcs + +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 ] 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 ; + +> 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 ; diff --git a/extra/lcs/summary.txt b/extra/lcs/summary.txt new file mode 100755 index 0000000000..9e70fd7e63 --- /dev/null +++ b/extra/lcs/summary.txt @@ -0,0 +1 @@ +Levenshtein distance and diff between sequences diff --git a/extra/lcs/tags.txt b/extra/lcs/tags.txt new file mode 100755 index 0000000000..4d914f4c46 --- /dev/null +++ b/extra/lcs/tags.txt @@ -0,0 +1 @@ +algorithms diff --git a/extra/levenshtein/authors.txt b/extra/levenshtein/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/extra/levenshtein/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/levenshtein/levenshtein-tests.factor b/extra/levenshtein/levenshtein-tests.factor deleted file mode 100644 index 722ccb86ca..0000000000 --- a/extra/levenshtein/levenshtein-tests.factor +++ /dev/null @@ -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 diff --git a/extra/levenshtein/levenshtein.factor b/extra/levenshtein/levenshtein.factor deleted file mode 100644 index 07731bfb84..0000000000 --- a/extra/levenshtein/levenshtein.factor +++ /dev/null @@ -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 - -: ( m n -- matrix ) - [ drop 0 ] 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 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 ; diff --git a/extra/levenshtein/summary.txt b/extra/levenshtein/summary.txt deleted file mode 100644 index 583669a8b0..0000000000 --- a/extra/levenshtein/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Levenshtein edit distance algorithm diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor index 96485825ff..961017f39e 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -2,15 +2,6 @@ USING: help.syntax help.markup kernel macros prettyprint memoize ; IN: locals - - 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* } diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index bb2fd9893c..5c3d2005a8 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -1,6 +1,6 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint io.streams.string parser -; +accessors ; IN: locals.tests :: foo ( a b -- a a ) a a ; @@ -55,7 +55,6 @@ IN: locals.tests [ 5 ] [ [let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ] - with-locals ] unit-test :: wlet-test-2 ( a b -- seq ) @@ -108,7 +107,7 @@ write-test-2 "q" set [ 10 20 ] [ - 20 10 [| a! | [| b! | a b ] ] with-locals call call + 20 10 [| a! | [| b! | a b ] ] call call ] unit-test :: write-test-3 ( a! -- q ) [| b | b a! ] ; @@ -170,16 +169,22 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; [ ] [ \ lambda-generic see ] unit-test +:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ; + [ "[let | a! [ ] | ]" ] [ - [let | a! [ ] | ] unparse + \ unparse-test-1 "lambda" word-prop body>> first unparse ] unit-test +:: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ; + [ "[wlet | a! [ ] | ]" ] [ - [wlet | a! [ ] | ] unparse + \ unparse-test-2 "lambda" word-prop body>> first unparse ] unit-test +:: unparse-test-3 ( -- b ) [| a! | ] ; + [ "[| a! | ]" ] [ - [| a! | ] unparse + \ unparse-test-3 "lambda" word-prop body>> first unparse ] unit-test DEFER: xyzzy @@ -237,3 +242,7 @@ M: integer next-method-test 3 + ; M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; [ 5 ] [ 1 next-method-test ] unit-test + +: no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ; + +[ { 4 5 6 } ] [ no-with-locals-test ] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index d18017f69b..4b7ab8cdad 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -101,7 +101,7 @@ UNION: special local quote local-word local-reader local-writer ; ] if ; : point-free-body ( quot args -- newquot ) - >r 1 head-slice* r> [ localize ] curry map concat ; + >r but-last-slice r> [ localize ] curry map concat ; : point-free-end ( quot args -- newquot ) over peek special? @@ -201,8 +201,11 @@ M: object local-rewrite* , ; : pop-locals ( assoc -- ) use get delete ; +SYMBOL: in-lambda? + : (parse-lambda) ( assoc end -- quot ) - parse-until >quotation swap pop-locals ; + t in-lambda? [ parse-until ] with-variable + >quotation swap pop-locals ; : parse-lambda ( -- lambda ) "|" parse-tokens make-locals dup push-locals @@ -283,24 +286,24 @@ M: wlet local-rewrite* CREATE-METHOD [ parse-locals-definition ] with-method-definition ; +: parsed-lambda ( form -- ) + in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ; + PRIVATE> -: [| parse-lambda parsed ; parsing +: [| parse-lambda parsed-lambda ; parsing : [let scan "|" assert= parse-bindings -\ ] (parse-lambda) parsed ; parsing + \ ] (parse-lambda) parsed-lambda ; parsing : [let* scan "|" assert= parse-bindings* - >r \ ] parse-until >quotation parsed r> pop-locals ; - parsing + \ ] (parse-lambda) parsed-lambda ; parsing : [wlet scan "|" assert= parse-wbindings - \ ] (parse-lambda) parsed ; parsing - -MACRO: with-locals ( form -- quot ) lambda-rewrite ; + \ ] (parse-lambda) parsed-lambda ; parsing : :: (::) define ; parsing diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor index b7862af7ac..6173669ad0 100644 --- a/extra/mortar/mortar.factor +++ b/extra/mortar/mortar.factor @@ -122,7 +122,7 @@ over class-class-methods assoc-stack call ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : send-message-next ( object message -- ) -over object-class class-methods 1 head* assoc-stack call ; +over object-class class-methods but-last assoc-stack call ; : <-~ scan parsed \ send-message-next parsed ; parsing diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor index e140c5227c..ce79bdaf5f 100755 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -14,7 +14,7 @@ IN: multiline ] [ ";" unexpected-eof ] if* ; : parse-here ( -- str ) - [ (parse-here) ] "" make 1 head* + [ (parse-here) ] "" make but-last lexer get next-line ; : STRING: @@ -34,7 +34,7 @@ IN: multiline [ lexer get lexer-column swap (parse-multiline-string) lexer get set-lexer-column - ] "" make rest 1 head* ; + ] "" make rest but-last ; : <" "\">" parse-multiline-string parsed ; parsing diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor index 70756e81c2..60b83819d5 100755 --- a/extra/optimizer/report/report.factor +++ b/extra/optimizer/report/report.factor @@ -20,7 +20,7 @@ IN: optimizer.report [ dup [ word-dataflow nip 1 count-optimization-passes - ] benchmark nip 2array + ] benchmark 2array ] { } map>assoc [ first ] "Worst number of optimizer passes:" results [ second ] "Worst compile times:" results ; diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 0ee7bf515f..c3252de500 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -324,7 +324,7 @@ M: ebnf-sequence build-locals ( code ast -- code ) ] 2each " | " % % - " ] with-locals" % + " ]" % ] "" make ] if ; @@ -334,7 +334,7 @@ M: ebnf-var build-locals ( code ast -- ) name>> % " [ dup ] " % " | " % % - " ] with-locals" % + " ]" % ] "" make ; M: object build-locals ( code ast -- ) diff --git a/extra/porter-stemmer/porter-stemmer-tests.factor b/extra/porter-stemmer/porter-stemmer-tests.factor index 32386fed2b..42c358646b 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -56,11 +56,9 @@ io.files io.encodings.utf8 ; [ "hell" ] [ "hell" step5 "" like ] unit-test [ "mate" ] [ "mate" step5 "" like ] unit-test -: resource-lines resource-path utf8 file-lines ; - [ { } ] [ - "extra/porter-stemmer/test/voc.txt" resource-lines + "resource:extra/porter-stemmer/test/voc.txt" utf8 file-lines [ stem ] map - "extra/porter-stemmer/test/output.txt" resource-lines + "resource:extra/porter-stemmer/test/output.txt" utf8 file-lines [ 2array ] 2map [ first2 = not ] filter ] unit-test diff --git a/extra/porter-stemmer/porter-stemmer.factor b/extra/porter-stemmer/porter-stemmer.factor index 81820e0152..9a2a08bcbe 100644 --- a/extra/porter-stemmer/porter-stemmer.factor +++ b/extra/porter-stemmer/porter-stemmer.factor @@ -66,8 +66,6 @@ USING: kernel math parser sequences combinators splitting ; : r ( str oldsuffix newsuffix -- str ) pick consonant-seq 0 > [ nip ] [ drop ] if append ; -: butlast ( seq -- seq ) 1 head-slice* ; - : step1a ( str -- newstr ) dup peek CHAR: s = [ { @@ -95,7 +93,7 @@ USING: kernel math parser sequences combinators splitting ; { [ "iz" ?tail ] [ "ize" append ] } { [ dup length 1- over double-consonant? ] - [ dup "lsz" last-is? [ butlast ] unless ] + [ dup "lsz" last-is? [ but-last-slice ] unless ] } { [ t ] @@ -122,7 +120,7 @@ USING: kernel math parser sequences combinators splitting ; } cond ; : step1c ( str -- newstr ) - dup butlast stem-vowel? [ + dup but-last-slice stem-vowel? [ "y" ?tail [ "i" append ] when ] when ; @@ -198,18 +196,18 @@ USING: kernel math parser sequences combinators splitting ; : remove-e? ( str -- ? ) dup consonant-seq dup 1 > [ 2drop t ] - [ 1 = [ butlast cvc? not ] [ drop f ] if ] if ; + [ 1 = [ but-last-slice cvc? not ] [ drop f ] if ] if ; : remove-e ( str -- newstr ) dup peek CHAR: e = [ - dup remove-e? [ butlast ] when + dup remove-e? [ but-last-slice ] when ] when ; : ll->l ( str -- newstr ) { { [ dup peek CHAR: l = not ] [ ] } { [ dup length 1- over double-consonant? not ] [ ] } - { [ dup consonant-seq 1 > ] [ butlast ] } + { [ dup consonant-seq 1 > ] [ but-last-slice ] } [ ] } cond ; diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index c2def03ace..108f5c1e94 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -41,7 +41,7 @@ PRIVATE> : fib-upto* ( n -- seq ) 0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip - 1 head-slice* { 0 1 } prepend ; + but-last-slice { 0 1 } prepend ; : euler002a ( -- answer ) 1000000 fib-upto* [ even? ] filter sum ; diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 452d2ec637..82054ce014 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -28,7 +28,7 @@ IN: project-euler.022 number ] map ; @@ -78,7 +78,7 @@ INSTANCE: rollover immutable-sequence frequency-analysis sort-values keys peek ; : crack-key ( seq key-length -- key ) - [ " " decrypt ] dip group 1 head-slice* + [ " " decrypt ] dip group but-last-slice flip [ most-frequent ] map ; PRIVATE> diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index 436ccde776..3e16996e04 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -38,7 +38,7 @@ IN: project-euler.067 number ] map ] map ; PRIVATE> diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index 3674804b0c..cde4dc079b 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -27,7 +27,7 @@ IN: project-euler.079 edges ( seq -- seq ) [ diff --git a/extra/project-euler/ave-time/ave-time-docs.factor b/extra/project-euler/ave-time/ave-time-docs.factor index cc40ae4bf1..d8ee0846b0 100644 --- a/extra/project-euler/ave-time/ave-time-docs.factor +++ b/extra/project-euler/ave-time/ave-time-docs.factor @@ -16,9 +16,7 @@ HELP: ave-time "This word can be used to compare performance of the non-optimizing and optimizing compilers." $nl "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:" - { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run / 6 ms GC ave time - 10 trials" } + { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run time - 10 trials" } "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:" - { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run / 13 ms GC ave time - 10 trials" } + { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run time - 10 trials" } } ; - -{ benchmark collect-benchmarks gc-time millis time ave-time } related-words diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index b908dbd7b0..c8212b4009 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -4,20 +4,13 @@ USING: arrays combinators io kernel math math.functions math.parser math.statistics namespaces sequences tools.time ; IN: project-euler.ave-time - - : collect-benchmarks ( quot n -- seq ) [ - >r >r datastack r> [ benchmark 2array , ] curry tuck + >r >r datastack r> [ benchmark , ] curry tuck [ with-datastack drop ] 2curry r> swap times call ] { } make ; : ave-time ( quot n -- ) - [ collect-benchmarks ] keep swap ave-benchmarks [ - dup second # " ms run / " % first # " ms GC ave time - " % # " trials" % + [ collect-benchmarks ] keep swap mean round [ + # " ms run time - " % # " trials" % ] "" make print flush ; inline diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor index 06e76d0a99..51eae24333 100755 --- a/extra/reports/optimizer/optimizer.factor +++ b/extra/reports/optimizer/optimizer.factor @@ -20,7 +20,7 @@ IN: report.optimizer [ dup [ word-dataflow nip 1 count-optimization-passes - ] benchmark nip 2array + ] benchmark 2array ] { } map>assoc ; : optimizer-measurements. ( alist -- ) diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 252defe99b..0e6bb0b9c1 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -22,7 +22,7 @@ IN: rss.tests f } } -} ] [ "extra/rss/rss1.xml" resource-path load-news-file ] unit-test +} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test [ T{ feed f @@ -39,4 +39,4 @@ IN: rss.tests T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } } } -} ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test +} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 200257b31c..f773d331b1 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -45,21 +45,21 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s : init-sound ( index cpu filename -- ) swapd >r space-invaders-sounds nth AL_BUFFER r> - resource-path create-buffer-from-wav set-source-param ; + create-buffer-from-wav set-source-param ; : init-sounds ( cpu -- ) init-openal [ 9 gen-sources swap set-space-invaders-sounds ] keep - [ SOUND-SHOT "extra/space-invaders/resources/Shot.wav" init-sound ] keep - [ SOUND-UFO "extra/space-invaders/resources/Ufo.wav" init-sound ] keep + [ SOUND-SHOT "resource:extra/space-invaders/resources/Shot.wav" init-sound ] keep + [ SOUND-UFO "resource:extra/space-invaders/resources/Ufo.wav" init-sound ] keep [ space-invaders-sounds SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep - [ SOUND-BASE-HIT "extra/space-invaders/resources/BaseHit.wav" init-sound ] keep - [ SOUND-INVADER-HIT "extra/space-invaders/resources/InvHit.wav" init-sound ] keep - [ SOUND-WALK1 "extra/space-invaders/resources/Walk1.wav" init-sound ] keep - [ SOUND-WALK2 "extra/space-invaders/resources/Walk2.wav" init-sound ] keep - [ SOUND-WALK3 "extra/space-invaders/resources/Walk3.wav" init-sound ] keep - [ SOUND-WALK4 "extra/space-invaders/resources/Walk4.wav" init-sound ] keep - [ SOUND-UFO-HIT "extra/space-invaders/resources/UfoHit.wav" init-sound ] keep + [ SOUND-BASE-HIT "resource:extra/space-invaders/resources/BaseHit.wav" init-sound ] keep + [ SOUND-INVADER-HIT "resource:extra/space-invaders/resources/InvHit.wav" init-sound ] keep + [ SOUND-WALK1 "resource:extra/space-invaders/resources/Walk1.wav" init-sound ] keep + [ SOUND-WALK2 "resource:extra/space-invaders/resources/Walk2.wav" init-sound ] keep + [ SOUND-WALK3 "resource:extra/space-invaders/resources/Walk3.wav" init-sound ] keep + [ SOUND-WALK4 "resource:extra/space-invaders/resources/Walk4.wav" init-sound ] keep + [ SOUND-UFO-HIT "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep f swap set-space-invaders-looping? ; : ( -- cpu ) diff --git a/extra/state-parser/state-parser-docs.factor b/extra/state-parser/state-parser-docs.factor index cac0e30175..3027c01c19 100644 --- a/extra/state-parser/state-parser-docs.factor +++ b/extra/state-parser/state-parser-docs.factor @@ -69,4 +69,4 @@ HELP: next { $description "originally written as " { $code "spot inc" } ", code that would no longer run, this word moves the state of the XML parser to the next place in the source file, keeping track of appropriate debugging information." } ; HELP: parsing-error -{ $class-description "class to which parsing errors delegate, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ; +{ $class-description "class from which parsing errors inherit, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ; diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index 6fdc6d9d32..b41d7f5023 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.string kernel math namespaces sequences -strings circular prettyprint debugger ascii ; +strings circular prettyprint debugger ascii sbufs fry inspector +accessors sequences.lib ; IN: state-parser ! * Basic underlying words @@ -11,50 +12,56 @@ TUPLE: spot char line column next ; C: spot -: get-char ( -- char ) spot get spot-char ; -: set-char ( char -- ) spot get set-spot-char ; -: get-line ( -- line ) spot get spot-line ; -: set-line ( line -- ) spot get set-spot-line ; -: get-column ( -- column ) spot get spot-column ; -: set-column ( column -- ) spot get set-spot-column ; -: get-next ( -- char ) spot get spot-next ; -: set-next ( char -- ) spot get set-spot-next ; +: get-char ( -- char ) spot get char>> ; +: set-char ( char -- ) spot get swap >>char drop ; +: get-line ( -- line ) spot get line>> ; +: set-line ( line -- ) spot get swap >>line drop ; +: get-column ( -- column ) spot get column>> ; +: set-column ( column -- ) spot get swap >>column drop ; +: get-next ( -- char ) spot get next>> ; +: set-next ( char -- ) spot get swap >>next drop ; ! * Errors TUPLE: parsing-error line column ; -: ( -- parsing-error ) - get-line get-column parsing-error boa ; -: construct-parsing-error ( ... slots class -- error ) - construct over set-delegate ; inline +: parsing-error ( class -- obj ) + new + get-line >>line + get-column >>column ; +M: parsing-error summary ( obj -- str ) + [ + "Parsing error" print + "Line: " write dup line>> . + "Column: " write column>> . + ] with-string-writer ; -: parsing-error. ( parsing-error -- ) - "Parsing error" print - "Line: " write dup parsing-error-line . - "Column: " write parsing-error-column . ; +TUPLE: expected < parsing-error should-be was ; +: expected ( should-be was -- * ) + \ expected parsing-error + swap >>was + swap >>should-be throw ; +M: expected summary ( obj -- str ) + [ + dup call-next-method write + "Token expected: " write dup should-be>> print + "Token present: " write was>> print + ] with-string-writer ; -TUPLE: expected should-be was ; -: ( should-be was -- error ) - { set-expected-should-be set-expected-was } - expected construct-parsing-error ; -M: expected error. - dup parsing-error. - "Token expected: " write dup expected-should-be print - "Token present: " write expected-was print ; +TUPLE: unexpected-end < parsing-error ; +: unexpected-end \ unexpected-end parsing-error throw ; +M: unexpected-end summary ( obj -- str ) + [ + call-next-method write + "File unexpectedly ended." print + ] with-string-writer ; -TUPLE: unexpected-end ; -: ( -- unexpected-end ) - { } unexpected-end construct-parsing-error ; -M: unexpected-end error. - parsing-error. - "File unexpectedly ended." print ; - -TUPLE: missing-close ; -: ( -- missing-close ) - { } missing-close construct-parsing-error ; -M: missing-close error. - parsing-error. - "Missing closing token." print ; +TUPLE: missing-close < parsing-error ; +: missing-close \ missing-close parsing-error throw ; +M: missing-close summary ( obj -- str ) + [ + call-next-method write + "Missing closing token." print + ] with-string-writer ; SYMBOL: prolog-data @@ -65,7 +72,8 @@ SYMBOL: prolog-data [ 0 get-line 1+ set-line ] [ get-column 1+ ] if set-column ; -: (next) ( -- char ) ! this normalizes \r\n and \r +! (next) normalizes \r\n and \r +: (next) ( -- char ) get-next read1 2dup swap CHAR: \r = [ CHAR: \n = @@ -75,10 +83,7 @@ SYMBOL: prolog-data : next ( -- ) #! Increment spot. - get-char [ - throw - ] unless - (next) record ; + get-char [ unexpected-end ] unless (next) record ; : next* ( -- ) get-char [ (next) record ] when ; @@ -95,9 +100,9 @@ SYMBOL: prolog-data #! Take the substring of a string starting at spot #! from code until the quotation given is true and #! advance spot to after the substring. - [ [ - dup slip swap dup [ get-char , ] unless - ] skip-until ] "" make nip ; inline + 10 [ + '[ @ [ t ] [ get-char , push f ] if ] skip-until + ] keep >string ; inline : take-rest ( -- string ) [ f ] take-until ; @@ -105,6 +110,20 @@ SYMBOL: prolog-data : take-char ( ch -- string ) [ dup get-char = ] take-until nip ; +TUPLE: not-enough-characters < parsing-error ; +: not-enough-characters + \ not-enough-characters parsing-error throw ; +M: not-enough-characters summary ( obj -- str ) + [ + call-next-method write + "Not enough characters" print + ] with-string-writer ; + +: take ( n -- string ) + [ 1- ] [ ] bi [ + '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop + ] keep get-char [ over push ] when* >string ; + : pass-blank ( -- ) #! Advance code past any whitespace, including newlines [ get-char blank? not ] skip-until ; @@ -117,16 +136,16 @@ SYMBOL: prolog-data dup length [ 2dup string-matches? ] take-until nip dup length rot length 1- - head - get-char [ throw ] unless next ; + get-char [ missing-close ] unless next ; : expect ( ch -- ) get-char 2dup = [ 2drop ] [ - >r 1string r> 1string throw + >r 1string r> 1string expected ] if next ; : expect-string ( string -- ) dup [ drop get-char next ] map 2dup = - [ 2drop ] [ throw ] if ; + [ 2drop ] [ expected ] if ; : init-parser ( -- ) 0 1 0 f spot set diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor index afaf3da3cd..52c454f97f 100644 --- a/extra/tangle/tangle.factor +++ b/extra/tangle/tangle.factor @@ -65,7 +65,7 @@ TUPLE: tangle-dispatcher < dispatcher tangle ; : ( tangle -- dispatcher ) tangle-dispatcher new-dispatcher swap >>tangle >>default - "extra/tangle/resources" resource-path "resources" add-responder + "resource:extra/tangle/resources" "resources" add-responder "node" add-responder [ all-node-ids ] >>display "all" add-responder ; diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor index 6aeb5aa098..17d1998f67 100644 --- a/extra/taxes/taxes-tests.factor +++ b/extra/taxes/taxes-tests.factor @@ -96,3 +96,21 @@ IN: taxes.tests 1000000 2008 3 t net dollars/cents ] unit-test + + +[ 30 97 ] [ + 24000 2008 2 f withholding biweekly dollars/cents +] unit-test + +[ 173 66 ] [ + 78250 2008 2 f withholding biweekly dollars/cents +] unit-test + + +[ 138 69 ] [ + 24000 2008 2 f withholding biweekly dollars/cents +] unit-test + +[ 754 72 ] [ + 78250 2008 2 f withholding biweekly dollars/cents +] unit-test diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index ed466b6965..6dff511238 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -63,11 +63,11 @@ DEFER: ?make-staging-image dup empty? [ "-i=" my-boot-image-name append , ] [ - dup 1 head* ?make-staging-image + dup but-last ?make-staging-image "-resource-path=" "" resource-path append , - "-i=" over 1 head* staging-image-name append , + "-i=" over but-last staging-image-name append , "-run=tools.deploy.restage" , ] if diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor index 4af1219daf..2960cf452d 100755 --- a/extra/tools/deploy/config/config-docs.factor +++ b/extra/tools/deploy/config/config-docs.factor @@ -96,7 +96,7 @@ HELP: deploy-io { "2" "Basic ANSI C streams" } { "3" "Non-blocking streams and networking" } } -"The default value is 1, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such are not available." } ; +"The default value is 2, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such as networking are not available." } ; HELP: deploy-reflection { $description "The level of reflection support required by the deployed image." diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 86c50387b5..1374254612 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -114,7 +114,7 @@ IN: tools.deploy.shaker continuations:error-continuation continuations:error-thread continuations:restarts - error-hook + listener:error-hook init:init-hooks inspector:inspector-hook io.thread:io-thread diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor index b8fdcab280..9628b218e9 100644 --- a/extra/tools/memory/memory.factor +++ b/extra/tools/memory/memory.factor @@ -36,6 +36,7 @@ IN: tools.memory [ first2 ] [ number>string "Generation " prepend ] bi* write-total/used/free ] 2each + "Decks" write-total "Cards" write-total ; : write-labelled-size ( n string -- ) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 854ef7af0e..8ef80c6add 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators -continuations debugger io io.files vocabs tools.time +continuations debugger io io.files vocabs vocabs.loader source-files compiler.units inspector inference effects tools.vocabs ; IN: tools.test @@ -19,7 +19,7 @@ SYMBOL: this-test : (unit-test) ( what quot -- ) swap dup . flush this-test set - [ time ] curry failures get [ + failures get [ [ this-test get failure ] recover ] [ call diff --git a/extra/tools/time/time-docs.factor b/extra/tools/time/time-docs.factor index 36ab3c01d4..5fedba1700 100644 --- a/extra/tools/time/time-docs.factor +++ b/extra/tools/time/time-docs.factor @@ -6,28 +6,21 @@ ARTICLE: "timing" "Timing code" { $subsection time } "A lower-level word puts timings on the stack, intead of printing:" { $subsection benchmark } -"You can also read the system clock and total garbage collection time directly:" +"You can also read the system clock and garbage collection statistics directly:" { $subsection millis } -{ $subsection gc-time } +{ $subsection gc-stats } { $see-also "profiling" } ; ABOUT: "timing" HELP: benchmark -{ $values { "quot" "a quotation" } { "gctime" "an integer denoting milliseconds" } { "runtime" "an integer denoting milliseconds" } } +{ $values { "quot" "a quotation" } + { "runtime" "an integer denoting milliseconds" } } { $description "Runs a quotation, measuring the total wall clock time and the total time spent in the garbage collector." } { $notes "A nicer word for interactive use is " { $link time } "." } ; HELP: time { $values { "quot" "a quotation" } } -{ $description "Runs a quotation and then prints the total run time and time spent in the garbage collector." } -{ $examples - "This word can be used to compare performance of the non-optimizing and optimizing compilers." - $nl - "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:" - { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] time" "1116 ms run / 6 ms GC time" } - "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:" - { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] time" "202 ms run / 13 ms GC time" } -} ; +{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ; -{ gc-time benchmark millis time } related-words +{ benchmark millis time } related-words diff --git a/extra/tools/time/time.factor b/extra/tools/time/time.factor index 4862cc2b27..82d3491743 100644 --- a/extra/tools/time/time.factor +++ b/extra/tools/time/time.factor @@ -1,14 +1,54 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math memory io namespaces system -math.parser ; +USING: kernel math math.vectors memory io io.styles prettyprint +namespaces system sequences splitting assocs strings ; IN: tools.time -: benchmark ( quot -- gctime runtime ) - millis >r gc-time >r call gc-time r> - millis r> - ; - inline +: benchmark ( quot -- runtime ) + millis >r call millis r> - ; inline + +: simple-table. ( values -- ) + standard-table-style [ + [ + [ + [ + dup string? + [ [ write ] with-cell ] + [ pprint-cell ] + if + ] each + ] with-row + ] each + ] tabular-output ; + +: time. ( data -- ) + unclip + "==== RUNNING TIME" print nl pprint " ms" print nl + 4 cut* + "==== GARBAGE COLLECTION" print nl + [ + 6 group + { + "GC count:" + "Cumulative GC time (ms):" + "Longest GC pause (ms):" + "Average GC pause (ms):" + "Objects copied:" + "Bytes copied:" + } prefix + flip + { "" "Nursery" "Aging" "Tenured" } prefix + simple-table. + ] + [ + nl + { + "Total GC time (ms):" + "Cards scanned:" + "Decks scanned:" + "Code heap literal scans:" + } swap zip simple-table. + ] bi* ; : time ( quot -- ) - benchmark - [ # " ms run / " % # " ms GC time" % ] "" make print flush ; - inline + gc-reset millis >r call gc-stats millis r> - prefix time. ; inline diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor index 219df5197c..cf439f6407 100755 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -7,7 +7,7 @@ IN: tuple-syntax : parse-slot-writer ( tuple -- slot# ) scan dup "}" = [ 2drop f ] [ - 1 head* swap object-slots slot-named slot-spec-offset + but-last swap object-slots slot-named slot-spec-offset ] if ; : parse-slots ( accum tuple -- accum tuple ) diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index d95cbd69ed..7ca09b89b4 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -5,6 +5,8 @@ IN: ui.backend SYMBOL: ui-backend +HOOK: do-events ui-backend ( -- ) + HOOK: set-title ui-backend ( string world -- ) HOOK: set-fullscreen* ui-backend ( ? world -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 59adcf9af1..d1b7f22b41 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -14,18 +14,13 @@ C: handle SINGLETON: cocoa-ui-backend -SYMBOL: stop-after-last-window? - -: event-loop? ( -- ? ) - stop-after-last-window? get-global - [ windows get-global empty? not ] [ t ] if ; - -: event-loop ( -- ) - event-loop? [ +M: cocoa-ui-backend do-events ( -- ) + [ [ - [ NSApp do-events ui-wait ] ui-try - ] with-autorelease-pool event-loop - ] when ; + NSApp [ dup do-event ] [ ] [ ] while drop + ui-wait + ] ui-try + ] with-autorelease-pool ; TUPLE: pasteboard handle ; @@ -112,6 +107,7 @@ M: cocoa-ui-backend ui "UI" assert.app [ [ init-clipboard + stop-after-last-window? off cocoa-init-hook get [ call ] when* start-ui finish-launching diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 0970bd6027..5bba095253 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -54,7 +54,7 @@ TUPLE: zoom-in-action ; C: zoom-in-action TUPLE: zoom-out-action ; C: zoom-out-action : generalize-gesture ( gesture -- newgesture ) - tuple>array 1 head* >tuple ; + tuple>array but-last >tuple ; ! Modifiers SYMBOLS: C+ A+ M+ S+ ; @@ -111,7 +111,8 @@ SYMBOL: double-click-timeout ] if ; : drag-gesture ( -- ) - hand-buttons get-global first button-gesture ; + hand-buttons get-global + dup empty? [ drop ] [ first button-gesture ] if ; SYMBOL: drag-timer diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index 99c005451d..f8d5e33df9 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,18 +1,21 @@ IN: ui.tools.interactor.tests USING: ui.tools.interactor ui.gadgets.panes namespaces ui.gadgets.editors concurrency.promises threads listener -tools.test kernel calendar parser ; +tools.test kernel calendar parser accessors ; + +\ must-infer [ - \ must-infer - [ ] [ "interactor" set ] unit-test + [ ] [ "interactor" get register-self ] unit-test + [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test [ ] [ "promise" set ] unit-test [ + self "interactor" get (>>thread) "interactor" get stream-read-quot "promise" get fulfill ] "Interactor test" spawn drop @@ -27,3 +30,14 @@ tools.test kernel calendar parser ; [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test ] with-interactive-vocabs + +! Hang +[ ] [ "interactor" set ] unit-test + +[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test + +[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test + +[ ] [ 1000 sleep ] unit-test + +[ ] [ "interactor" get interactor-eof ] unit-test diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 4f5090fda2..2e59363531 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -1,53 +1,55 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs combinators continuations documents - hashtables io io.styles kernel math -math.vectors models namespaces parser prettyprint quotations -sequences strings threads listener -classes.tuple ui.commands ui.gadgets ui.gadgets.editors -ui.gadgets.presentations ui.gadgets.worlds ui.gestures -definitions boxes calendar concurrency.flags ui.tools.workspace -accessors math.order ; +hashtables io io.styles kernel math math.order math.vectors +models namespaces parser prettyprint quotations sequences +strings threads listener classes.tuple ui.commands ui.gadgets +ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds +ui.gestures definitions calendar concurrency.flags +concurrency.mailboxes ui.tools.workspace accessors ; IN: ui.tools.interactor -TUPLE: interactor history output flag thread help ; +! If waiting is t, we're waiting for user input, and invoking +! evaluate-input resumes the thread. +TUPLE: interactor output history flag mailbox thread waiting help ; + +: register-self ( interactor -- ) + >>mailbox + self >>thread + drop ; : interactor-continuation ( interactor -- continuation ) - interactor-thread box-value - thread-continuation box-value ; + thread>> continuation>> value>> ; : interactor-busy? ( interactor -- ? ) - interactor-thread box-full? not ; + #! We're busy if there's no thread to resume. + [ waiting>> ] + [ thread>> dup [ thread-registered? ] when ] + bi and not ; : interactor-use ( interactor -- seq ) dup interactor-busy? [ drop f ] [ use swap - interactor-continuation continuation-name + interactor-continuation name>> assoc-stack ] if ; -: init-caret-help ( interactor -- ) - dup editor-caret 1/3 seconds - swap set-interactor-help ; - -: init-interactor-history ( interactor -- ) - V{ } clone swap set-interactor-history ; - -: init-interactor-state ( interactor -- ) - over set-interactor-flag - swap set-interactor-thread ; +: ( interactor -- model ) + editor-caret 1/3 seconds ; : ( output -- gadget ) interactor construct-editor - tuck set-interactor-output - dup init-interactor-history - dup init-interactor-state - dup init-caret-help ; + V{ } clone >>history + >>flag + dup >>help + swap >>output ; M: interactor graft* - dup delegate graft* - dup interactor-help add-connection ; + [ delegate graft* ] [ dup help>> add-connection ] bi ; + +M: interactor ungraft* + [ dup help>> remove-connection ] [ delegate ungraft ] bi ; : word-at-loc ( loc interactor -- word ) over [ @@ -58,7 +60,7 @@ M: interactor graft* ] if ; M: interactor model-changed - 2dup interactor-help eq? [ + 2dup help>> eq? [ swap model-value over word-at-loc swap show-summary ] [ delegate model-changed @@ -69,7 +71,7 @@ M: interactor model-changed [ H{ { font-style bold } } format ] with-nesting ; : interactor-input. ( string interactor -- ) - interactor-output [ + output>> [ dup string? [ dup write-input nl ] [ short. ] if ] with-output-stream* ; @@ -77,7 +79,7 @@ M: interactor model-changed over empty? [ 2drop ] [ interactor-history push-new ] if ; : interactor-continue ( obj interactor -- ) - interactor-thread box> resume-with ; + mailbox>> mailbox-put ; : clear-input ( interactor -- ) gadget-model clear-doc ; @@ -99,13 +101,17 @@ M: interactor model-changed ] unless drop ; : interactor-yield ( interactor -- obj ) - [ - [ interactor-thread >box ] keep - interactor-flag raise-flag - ] curry "input" suspend ; + dup thread>> self eq? [ + { + [ t >>waiting drop ] + [ flag>> raise-flag ] + [ mailbox>> mailbox-get ] + [ f >>waiting drop ] + } cleave + ] [ drop f ] if ; M: interactor stream-readln - [ interactor-yield ] keep interactor-finish + [ interactor-yield ] [ interactor-finish ] bi dup [ first ] when ; : interactor-call ( quot interactor -- ) @@ -161,7 +167,8 @@ M: interactor stream-read-quot } cond ; M: interactor pref-dim* - 0 over line-height 4 * 2array swap delegate pref-dim* vmax ; + [ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi + vmax ; interactor "interactor" f { { T{ key-down f f "RET" } evaluate-input } diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index cc218533d8..2fae62a8fc 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor ui.tools.listener hashtables kernel namespaces parser sequences tools.test ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.panes vocabs words tools.test.ui slots.private -threads arrays generic ; +threads arrays generic threads accessors listener ; IN: ui.tools.listener.tests [ f ] [ "word" source-editor command-map empty? ] unit-test @@ -15,7 +15,7 @@ IN: ui.tools.listener.tests [ "dup" ] [ \ dup word-completion-string ] unit-test - + [ "equal?" ] [ \ array \ equal? method word-completion-string ] unit-test @@ -28,9 +28,26 @@ IN: ui.tools.listener.tests [ ] [ "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover ] unit-test - + [ t ] [ "i" get gadget-model doc-end "i" get editor-caret* = ] unit-test + + ! Race condition discovered by SimonRC + [ ] [ + [ + "listener" get input>> + [ stream-read-quot drop ] + [ stream-read-quot drop ] bi + ] "OH, HAI" spawn drop + ] unit-test + + [ ] [ "listener" get clear-output ] unit-test + + [ ] [ "listener" get restart-listener ] unit-test + + [ ] [ 1000 sleep ] unit-test + + [ ] [ "listener" get com-end ] unit-test ] with-grafted-gadget diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 484b000861..48800c0918 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words prettyprint listener debugger threads boxes concurrency.flags -math arrays generic accessors combinators ; +math arrays generic accessors combinators assocs ; IN: ui.tools.listener TUPLE: listener-gadget input output stack ; @@ -20,7 +20,7 @@ TUPLE: listener-gadget input output stack ; [ input>> ] [ output>> ] bi ; : ( listener -- gadget ) - listener-gadget-output ; + output>> ; : listener-input, ( -- ) g g-> set-listener-gadget-input @@ -32,31 +32,29 @@ TUPLE: listener-gadget input output stack ; "cookbook" ($link) "." print nl ; M: listener-gadget focusable-child* - listener-gadget-input ; + input>> ; M: listener-gadget call-tool* ( input listener -- ) - >r input-string r> listener-gadget-input set-editor-string ; + >r string>> r> input>> set-editor-string ; M: listener-gadget tool-scroller - listener-gadget-output find-scroller ; + output>> find-scroller ; : wait-for-listener ( listener -- ) #! Wait for the listener to start. - listener-gadget-input interactor-flag wait-for-flag ; + input>> flag>> wait-for-flag ; : workspace-busy? ( workspace -- ? ) - workspace-listener listener-gadget-input interactor-busy? ; + listener>> input>> interactor-busy? ; : listener-input ( string -- ) - get-workspace - workspace-listener - listener-gadget-input set-editor-string ; + get-workspace listener>> input>> set-editor-string ; : (call-listener) ( quot listener -- ) - listener-gadget-input interactor-call ; + input>> interactor-call ; : call-listener ( quot -- ) - [ workspace-busy? not ] get-workspace* workspace-listener + [ workspace-busy? not ] get-workspace* listener>> [ dup wait-for-listener (call-listener) ] 2curry "Listener call" spawn drop ; @@ -68,8 +66,7 @@ M: listener-operation invoke-command ( target command -- ) : eval-listener ( string -- ) get-workspace - workspace-listener - listener-gadget-input [ set-editor-string ] keep + listener>> input>> [ set-editor-string ] keep evaluate-input ; : listener-run-files ( seq -- ) @@ -80,10 +77,10 @@ M: listener-operation invoke-command ( target command -- ) ] if ; : com-end ( listener -- ) - listener-gadget-input interactor-eof ; + input>> interactor-eof ; : clear-output ( listener -- ) - listener-gadget-output pane-clear ; + output>> pane-clear ; \ clear-output H{ { +listener+ t } } define-command @@ -104,12 +101,11 @@ M: engine-word word-completion-string "engine-generic" word-prop word-completion-string ; : use-if-necessary ( word seq -- ) - >r word-vocabulary vocab-words r> - { - { [ dup not ] [ 2drop ] } - { [ 2dup memq? ] [ 2drop ] } - [ push ] - } cond ; + over word-vocabulary [ + 2dup assoc-stack pick = [ 2drop ] [ + >r word-vocabulary vocab-words r> push + ] if + ] [ 2drop ] if ; : insert-word ( word -- ) get-workspace workspace-listener input>> @@ -147,23 +143,26 @@ M: stack-display tool-scroller : listener-thread ( listener -- ) dup listener-streams [ - [ - [ [ ui-listener-hook ] curry listener-hook set ] - [ [ ui-error-hook ] curry error-hook set ] - [ [ ui-inspector-hook ] curry inspector-hook set ] tri - welcome. - listener - ] with-input-stream* - ] with-output-stream* ; + [ [ ui-listener-hook ] curry listener-hook set ] + [ [ ui-error-hook ] curry error-hook set ] + [ [ ui-inspector-hook ] curry inspector-hook set ] tri + welcome. + listener + ] with-streams* ; : start-listener-thread ( listener -- ) - [ listener-thread ] curry "Listener" spawn drop ; + [ + [ input>> register-self ] [ listener-thread ] bi + ] curry "Listener" spawn drop ; : restart-listener ( listener -- ) #! Returns when listener is ready to receive input. - dup com-end dup clear-output - dup start-listener-thread - wait-for-listener ; + { + [ com-end ] + [ clear-output ] + [ start-listener-thread ] + [ wait-for-listener ] + } cleave ; : init-listener ( listener -- ) f swap set-listener-gadget-stack ; @@ -189,10 +188,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? ) [ default-gesture-handler ] [ 3drop f ] if ; M: listener-gadget graft* - dup delegate graft* - dup listener-gadget-input interactor-thread ?box 2drop - restart-listener ; + [ delegate graft* ] [ restart-listener ] bi ; M: listener-gadget ungraft* - dup com-end - delegate ungraft* ; + [ com-end ] [ delegate ungraft* ] bi ; diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index e7f412630c..7aca45a210 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -10,6 +10,18 @@ IN: ui ! Assoc mapping aliens to gadgets SYMBOL: windows +SYMBOL: stop-after-last-window? + +: event-loop? ( -- ? ) + { + { [ stop-after-last-window? get not ] [ t ] } + { [ graft-queue dlist-empty? not ] [ t ] } + { [ windows get-global empty? not ] [ t ] } + [ f ] + } cond ; + +: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ; + : window ( handle -- world ) windows get-global at ; : window-focus ( handle -- gadget ) window world-focus ; @@ -202,5 +214,9 @@ MAIN: ui call ] [ f windows set-global - ui-hook [ ui ] with-variable + [ + ui-hook set + stop-after-last-window? on + ui + ] with-scope ] if ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index e3e1fc5124..5e17d02542 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -387,17 +387,12 @@ SYMBOL: trace-messages? : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ; -: event-loop ( msg -- ) - { - { [ windows get empty? ] [ drop ] } - { [ dup peek-message? ] [ ui-wait event-loop ] } - { [ dup MSG-message WM_QUIT = ] [ drop ] } - [ - dup TranslateMessage drop - dup DispatchMessage drop - event-loop - ] - } cond ; +M: windows-ui-backend do-events + msg-obj get-global + dup peek-message? [ drop ui-wait ] [ + [ TranslateMessage drop ] + [ DispatchMessage drop ] bi + ] if ; : register-wndclassex ( -- class ) "WNDCLASSEX" @@ -500,10 +495,11 @@ M: windows-ui-backend set-title ( string world -- ) M: windows-ui-backend ui [ [ + stop-after-last-window? on init-clipboard init-win32-ui start-ui - msg-obj get event-loop + event-loop ] [ cleanup-win32-ui ] [ ] cleanup ] ui-running ; diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 606a45eba5..50d383e6b8 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -183,15 +183,10 @@ M: world client-event ui-wait wait-event ] if ; -: do-events ( -- ) +M: x11-ui-backend do-events wait-event dup XAnyEvent-window window dup [ [ 2dup handle-event ] assert-depth ] when 2drop ; -: event-loop ( -- ) - windows get empty? [ - [ do-events ] ui-try event-loop - ] unless ; - : x-clipboard@ ( gadget clipboard -- prop win ) x-clipboard-atom swap find-world world-handle x11-handle-window ; @@ -254,6 +249,7 @@ M: x11-ui-backend ui ( -- ) [ f [ [ + stop-after-last-window? on init-clipboard start-ui event-loop diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 9ee65c0018..9635a62e49 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -30,7 +30,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; concat [ dup ] H{ } map>assoc ; : other-extend-lines ( -- lines ) - "extra/unicode/PropList.txt" resource-path ascii file-lines ; + "resource:extra/unicode/PropList.txt" ascii file-lines ; VALUE: other-extend diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 85ce50acb9..f33338137a 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -14,7 +14,7 @@ IN: unicode.data ascii file-lines [ ";" split ] map ; : load-data ( -- data ) - "extra/unicode/UnicodeData.txt" resource-path data ; + "resource:extra/unicode/UnicodeData.txt" data ; : (process-data) ( index data -- newdata ) [ [ nth ] keep first swap 2array ] with map @@ -120,7 +120,7 @@ VALUE: special-casing ! Special casing data : load-special-casing ( -- special-casing ) - "extra/unicode/SpecialCasing.txt" resource-path data + "resource:extra/unicode/SpecialCasing.txt" data [ length 5 = ] filter [ [ set-code-point ] each ] H{ } make-assoc ; diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor index 14fba46c4d..d0bb4ac30d 100755 --- a/extra/unicode/script/script.factor +++ b/extra/unicode/script/script.factor @@ -1,12 +1,12 @@ USING: unicode.syntax.backend kernel sequences assocs io.files io.encodings ascii math.ranges io splitting math.parser namespaces byte-arrays locals math sets io.encodings.ascii -words compiler.units ; +words compiler.units arrays interval-maps ; IN: unicode.script num-table -VALUE: num>name-table +VALUE: script-table +SYMBOL: interned : parse-script ( stream -- assoc ) ! assoc is code point/range => name @@ -14,26 +14,18 @@ VALUE: num>name-table ";" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ; -: set-if ( value var -- ) - dup 500000 < [ set ] [ 2drop ] if ; +: range, ( value key -- ) + swap interned get + [ word-name = ] with find nip 2array , ; -: expand-ranges ( assoc -- char-assoc ) - ! char-assoc is code point => name - [ [ - CHAR: . pick member? [ - swap ".." split1 [ hex> ] bi@ [a,b] - [ set-if ] with each - ] [ swap hex> set-if ] if - ] assoc-each ] H{ } make-assoc ; - -: hash>byte-array ( hash -- byte-array ) - [ keys supremum 1+ dup ] keep - [ -rot set-nth ] with assoc-each ; - -: make-char>num ( assoc -- char>num-table ) - expand-ranges - [ num>name-table index ] assoc-map - hash>byte-array ; +: expand-ranges ( assoc -- interval-map ) + [ + [ + CHAR: . pick member? [ + swap ".." split1 [ hex> ] bi@ 2array + ] [ swap hex> ] if range, + ] assoc-each + ] { } make ; : >symbols ( strings -- symbols ) [ @@ -41,9 +33,9 @@ VALUE: num>name-table ] with-compilation-unit ; : process-script ( ranges -- ) - [ values prune \ num>name-table set-value ] - [ make-char>num \ char>num-table set-value ] bi - num>name-table >symbols \ num>name-table set-value ; + dup values prune >symbols interned [ + expand-ranges \ script-table set-value + ] with-variable ; : load-script ( -- ) "resource:extra/unicode/script/Scripts.txt" @@ -52,5 +44,7 @@ VALUE: num>name-table load-script PRIVATE> +SYMBOL: Unknown + : script-of ( char -- script ) - char>num-table nth num>name-table nth ; + script-table interval-at [ Unknown ] unless* ; diff --git a/extra/unix/ffi/ffi.factor b/extra/unix/ffi/ffi.factor new file mode 100644 index 0000000000..11a8405b1d --- /dev/null +++ b/extra/unix/ffi/ffi.factor @@ -0,0 +1,6 @@ + +USING: alien.syntax ; + +IN: unix.ffi + +FUNCTION: int open ( char* path, int flags, int prot ) ; \ No newline at end of file diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor index 11db6cc862..74195fae36 100755 --- a/extra/unix/linux/linux.factor +++ b/extra/unix/linux/linux.factor @@ -24,6 +24,9 @@ USING: alien.syntax ; : SO_SNDTIMEO HEX: 15 ; inline : SO_RCVTIMEO HEX: 14 ; inline +: F_SETFD 2 ; inline +: FD_CLOEXEC 1 ; inline + : F_SETFL 4 ; inline : O_NONBLOCK HEX: 800 ; inline diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 9005cd2b2a..bc3e3ca162 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -2,7 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel libc structs -math namespaces system combinators vocabs.loader unix.types ; + math namespaces system combinators vocabs.loader unix.ffi unix.types + qualified ; + +QUALIFIED: unix.ffi IN: unix @@ -75,7 +78,14 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_ FUNCTION: int munmap ( void* addr, size_t len ) ; FUNCTION: uint ntohl ( uint n ) ; FUNCTION: ushort ntohs ( ushort n ) ; -FUNCTION: int open ( char* path, int flags, int prot ) ; +FUNCTION: char* strerror ( int errno ) ; + +ERROR: open-error path flags prot message ; + +: open ( path flags prot -- int ) + 3dup unix.ffi:open + dup 0 >= [ >r 3drop r> ] [ drop err_no strerror open-error ] if ; + FUNCTION: int pclose ( void* file ) ; FUNCTION: int pipe ( int* filedes ) ; FUNCTION: void* popen ( char* command, char* type ) ; @@ -96,7 +106,6 @@ FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ; FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ; FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; -FUNCTION: char* strerror ( int errno ) ; FUNCTION: int symlink ( char* path1, char* path2 ) ; FUNCTION: int system ( char* command ) ; FUNCTION: int unlink ( char* path ) ; @@ -159,8 +168,6 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ; FUNCTION: pid_t wait ( int* status ) ; FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { diff --git a/extra/xml/backend/backend.factor b/extra/xml/backend/backend.factor new file mode 100644 index 0000000000..5dee38695d --- /dev/null +++ b/extra/xml/backend/backend.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +IN: xml.backend + +! A stack of { tag children } pairs +SYMBOL: xml-stack diff --git a/extra/xml/errors/errors-tests.factor b/extra/xml/errors/errors-tests.factor new file mode 100755 index 0000000000..402c76dc01 --- /dev/null +++ b/extra/xml/errors/errors-tests.factor @@ -0,0 +1,28 @@ +USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ; +IN: xml.errors.tests + +: xml-error-test ( expected-error xml-string -- ) + [ string>xml ] curry swap [ = ] curry must-fail-with ; + +T{ no-entity f 1 10 "nbsp" } " " xml-error-test +T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" } +} "" xml-error-test +T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "" xml-error-test +T{ nonexist-ns f 1 5 "x" } "" xml-error-test +T{ unopened f 1 5 } "" xml-error-test +T{ not-yes/no f 1 41 "maybe" } "" xml-error-test +T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } } +} "" xml-error-test +T{ bad-version f 1 28 "5 million" } "" xml-error-test +T{ notags f 1 0 } "" xml-error-test +T{ multitags } "" xml-error-test +T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f } +} "" xml-error-test +T{ capitalized-prolog f 1 6 "XmL" } "" +xml-error-test +T{ pre/post-content f "x" t } "x" xml-error-test +T{ versionless-prolog f 1 8 } "" xml-error-test +T{ bad-instruction f 1 11 T{ instruction f "xsl" } +} "" xml-error-test +T{ bad-directive f 1 15 T{ directive f "DOCTYPE" } +} "" xml-error-test diff --git a/extra/xml/errors/errors.factor b/extra/xml/errors/errors.factor index 5b41a7ff9f..53f2046a54 100644 --- a/extra/xml/errors/errors.factor +++ b/extra/xml/errors/errors.factor @@ -1,150 +1,178 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: xml.data xml.writer kernel generic io prettyprint math -debugger sequences state-parser ; +debugger sequences state-parser accessors inspector +namespaces io.streams.string xml.backend ; IN: xml.errors -TUPLE: no-entity thing ; -: ( string -- error ) - { set-no-entity-thing } no-entity construct-parsing-error ; -M: no-entity error. - dup parsing-error. - "Entity does not exist: &" write no-entity-thing write ";" print ; - -TUPLE: xml-string-error string ; ! this should not exist -: ( string -- xml-string-error ) - { set-xml-string-error-string } - xml-string-error construct-parsing-error ; -M: xml-string-error error. - dup parsing-error. - xml-string-error-string print ; - -TUPLE: mismatched open close ; -: - { set-mismatched-open set-mismatched-close } - mismatched construct-parsing-error ; -M: mismatched error. - dup parsing-error. - "Mismatched tags" print - "Opening tag: <" write dup mismatched-open print-name ">" print - "Closing tag: " print ; - -TUPLE: unclosed tags ; -! is ( -- unclosed ), see presentation.factor -M: unclosed error. - "Unclosed tags" print - "Tags: " print - unclosed-tags [ " <" write print-name ">" print ] each ; - -TUPLE: bad-uri string ; -: ( string -- bad-uri ) - { set-bad-uri-string } bad-uri construct-parsing-error ; -M: bad-uri error. - dup parsing-error. - "Bad URI:" print bad-uri-string . ; - -TUPLE: nonexist-ns name ; -: ( name-string -- nonexist-ns ) - { set-nonexist-ns-name } - nonexist-ns construct-parsing-error ; -M: nonexist-ns error. - dup parsing-error. - "Namespace " write nonexist-ns-name write " has not been declared" print ; - -TUPLE: unopened ; ! this should give which tag was unopened -: ( -- unopened ) - { } unopened construct-parsing-error ; -M: unopened error. - parsing-error. - "Closed an unopened tag" print ; - -TUPLE: not-yes/no text ; -: ( text -- not-yes/no ) - { set-not-yes/no-text } not-yes/no construct-parsing-error ; -M: not-yes/no error. - dup parsing-error. - "standalone must be either yes or no, not \"" write - not-yes/no-text write "\"." print ; - -TUPLE: extra-attrs attrs ; ! this should actually print the names -: ( attrs -- extra-attrs ) - { set-extra-attrs-attrs } - extra-attrs construct-parsing-error ; -M: extra-attrs error. - dup parsing-error. - "Extra attributes included in xml version declaration:" print - extra-attrs-attrs . ; - -TUPLE: bad-version num ; -: - { set-bad-version-num } - bad-version construct-parsing-error ; -M: bad-version error. - "XML version must be \"1.0\" or \"1.1\". Version here was " write - bad-version-num . ; - -TUPLE: notags ; -C: notags -M: notags error. - drop "XML document lacks a main tag" print ; - TUPLE: multitags ; C: multitags -M: multitags error. - drop "XML document contains multiple main tags" print ; - -TUPLE: bad-prolog prolog ; -: ( prolog -- bad-prolog ) - { set-bad-prolog-prolog } - bad-prolog construct-parsing-error ; -M: bad-prolog error. - dup parsing-error. - "Misplaced XML prolog" print - bad-prolog-prolog write-prolog nl ; - -TUPLE: capitalized-prolog name ; -: ( name -- capitalized-prolog ) - { set-capitalized-prolog-name } - capitalized-prolog construct-parsing-error ; -M: capitalized-prolog error. - dup parsing-error. - "XML prolog name was partially or totally capitalized, using" print - "" write - " instead of " print ; +M: multitags summary ( obj -- str ) + drop "XML document contains multiple main tags" ; TUPLE: pre/post-content string pre? ; C: 
 pre/post-content
-M: pre/post-content error.
-    "The text string:" print
-    dup pre/post-content-string .
-    "was used " write
-    pre/post-content-pre? "before" "after" ? write
-    " the main tag." print ;
+M: pre/post-content summary ( obj -- str )
+    [
+        "The text string:" print
+        dup string>> .
+        "was used " write
+        pre?>> "before" "after" ? write
+        " the main tag." print
+    ] with-string-writer ;
 
-TUPLE: versionless-prolog ;
+TUPLE: no-entity < parsing-error thing ;
+:  ( string -- error )
+    \ no-entity parsing-error swap >>thing ;
+M: no-entity summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Entity does not exist: &" write thing>> write ";" print
+    ] with-string-writer ;
+
+TUPLE: xml-string-error < parsing-error string ; ! this should not exist
+:  ( string -- xml-string-error )
+    \ xml-string-error parsing-error swap >>string ;
+M: xml-string-error summary ( obj -- str )
+    [
+        dup call-next-method write
+        string>> print
+    ] with-string-writer ;
+
+TUPLE: mismatched < parsing-error open close ;
+: 
+    \ mismatched parsing-error swap >>close swap >>open ;
+M: mismatched summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Mismatched tags" print
+        "Opening tag: <" write dup open>> print-name ">" print
+        "Closing tag: > print-name ">" print
+    ] with-string-writer ;
+
+TUPLE: unclosed < parsing-error tags ;
+:  ( -- unclosed )
+    unclosed parsing-error
+        xml-stack get rest-slice [ first opener-name ] map >>tags ;
+M: unclosed summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Unclosed tags" print
+        "Tags: " print
+        tags>> [ "  <" write print-name ">" print ] each
+    ] with-string-writer ;
+
+TUPLE: bad-uri < parsing-error string ;
+:  ( string -- bad-uri )
+    \ bad-uri parsing-error swap >>string ;
+M: bad-uri summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Bad URI:" print string>> .
+    ] with-string-writer ;
+
+TUPLE: nonexist-ns < parsing-error name ;
+:  ( name-string -- nonexist-ns )
+    \ nonexist-ns parsing-error swap >>name ;
+M: nonexist-ns summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Namespace " write name>> write " has not been declared" print
+    ] with-string-writer ;
+
+TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
+:  ( -- unopened )
+    \ unopened parsing-error ;
+M: unopened summary ( obj -- str )
+    [
+        call-next-method write
+        "Closed an unopened tag" print
+    ] with-string-writer ;
+
+TUPLE: not-yes/no < parsing-error text ;
+:  ( text -- not-yes/no )
+    \ not-yes/no parsing-error swap >>text ;
+M: not-yes/no summary ( obj -- str )
+    [
+        dup call-next-method write
+        "standalone must be either yes or no, not \"" write
+        text>> write "\"." print
+    ] with-string-writer ;
+
+! this should actually print the names
+TUPLE: extra-attrs < parsing-error attrs ;
+:  ( attrs -- extra-attrs )
+    \ extra-attrs parsing-error swap >>attrs ;
+M: extra-attrs summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Extra attributes included in xml version declaration:" print
+        attrs>> .
+    ] with-string-writer ;
+
+TUPLE: bad-version < parsing-error num ;
+: 
+    \ bad-version parsing-error swap >>num ;
+M: bad-version summary ( obj -- str )
+    [
+        "XML version must be \"1.0\" or \"1.1\". Version here was " write
+        num>> .
+    ] with-string-writer ;
+
+TUPLE: notags ;
+C:  notags
+M: notags summary ( obj -- str )
+    drop "XML document lacks a main tag" ;
+
+TUPLE: bad-prolog < parsing-error prolog ;
+:  ( prolog -- bad-prolog )
+    \ bad-prolog parsing-error swap >>prolog ;
+M: bad-prolog summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced XML prolog" print
+        prolog>> write-prolog nl
+    ] with-string-writer ;
+
+TUPLE: capitalized-prolog < parsing-error name ;
+:  ( name -- capitalized-prolog )
+    \ capitalized-prolog parsing-error swap >>name ;
+M: capitalized-prolog summary ( obj -- str )
+    [
+        dup call-next-method write
+        "XML prolog name was partially or totally capitalized, using" print
+        "> write "...?>" write
+        " instead of " print
+    ] with-string-writer ;
+
+TUPLE: versionless-prolog < parsing-error ;
 :  ( -- versionless-prolog )
-    { } versionless-prolog construct-parsing-error ;
-M: versionless-prolog error.
-    parsing-error.
-    "XML prolog lacks a version declaration" print ;
+    \ versionless-prolog parsing-error ;
+M: versionless-prolog summary ( obj -- str )
+    [
+        call-next-method write
+        "XML prolog lacks a version declaration" print
+    ] with-string-writer ;
 
-TUPLE: bad-instruction inst ;
+TUPLE: bad-instruction < parsing-error instruction ;
 :  ( instruction -- bad-instruction )
-    { set-bad-instruction-inst }
-    bad-instruction construct-parsing-error ;
-M: bad-instruction error.
-    dup parsing-error.
-    "Misplaced processor instruction:" print
-    bad-instruction-inst write-item nl ;
+    \ bad-instruction parsing-error swap >>instruction ;
+M: bad-instruction summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced processor instruction:" print
+        instruction>> write-item nl
+    ] with-string-writer ;
 
-TUPLE: bad-directive dir ;
+TUPLE: bad-directive < parsing-error dir ;
 :  ( directive -- bad-directive )
-    { set-bad-directive-dir }
-    bad-directive construct-parsing-error ;
-M: bad-directive error.
-    dup parsing-error.
-    "Misplaced directive:" print
-    bad-directive-dir write-item nl ;
+    \ bad-directive parsing-error swap >>dir ;
+M: bad-directive summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced directive:" print
+        bad-directive-dir write-item nl
+    ] with-string-writer ;
 
 UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
        not-yes/no unclosed mismatched xml-string-error expected no-entity
diff --git a/extra/xml/tests/errors.factor b/extra/xml/tests/errors.factor
deleted file mode 100755
index 6ba0b0d560..0000000000
--- a/extra/xml/tests/errors.factor
+++ /dev/null
@@ -1,28 +0,0 @@
-USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
-IN: xml.tests
-
-: xml-error-test ( expected-error xml-string -- )
-    [ string>xml ] curry swap [ = ] curry must-fail-with ;
-
-T{ no-entity T{ parsing-error f 1 10 } "nbsp" } " " xml-error-test
-T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" }
-} "" xml-error-test
-T{ unclosed f V{ T{ name f "" "x" "" } } } "" xml-error-test
-T{ nonexist-ns T{ parsing-error f 1 5 } "x" } "" xml-error-test
-T{ unopened T{ parsing-error f 1 5 } } "" xml-error-test
-T{ not-yes/no T{ parsing-error f 1 41 } "maybe" } "" xml-error-test
-T{ extra-attrs T{ parsing-error f 1 32 } V{ T{ name f "" "foo" f } }
-} "" xml-error-test
-T{ bad-version T{ parsing-error f 1 28 } "5 million" } "" xml-error-test
-T{ notags f } "" xml-error-test
-T{ multitags f } "" xml-error-test
-T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "UTF-8" f }
-} "" xml-error-test
-T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } ""
-xml-error-test
-T{ pre/post-content f "x" t } "x" xml-error-test
-T{ versionless-prolog T{ parsing-error f 1 8 } } "" xml-error-test
-T{ bad-instruction T{ parsing-error f 1 11 } T{ instruction f "xsl" }
-} "" xml-error-test
-T{ bad-directive T{ parsing-error f 1 15 } T{ directive f "DOCTYPE" }
-} "" xml-error-test
diff --git a/extra/xml/tests/soap.factor b/extra/xml/tests/soap.factor
index 775930025f..c7452bb079 100755
--- a/extra/xml/tests/soap.factor
+++ b/extra/xml/tests/soap.factor
@@ -10,6 +10,6 @@ IN: xml.tests
     [ assemble-data ] map ;
 
 [ "http://www.foxnews.com/oreilly/" ] [
-    "extra/xml/tests/soap.xml" resource-path file>xml
+    "resource:extra/xml/tests/soap.xml" file>xml
     parse-result first first
 ] unit-test
diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor
index d85345b3c7..7794930144 100644
--- a/extra/xml/tests/test.factor
+++ b/extra/xml/tests/test.factor
@@ -9,7 +9,7 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
 \ read-xml must-infer
 
 SYMBOL: xml-file
-[ ] [ "extra/xml/tests/test.xml" resource-path
+[ ] [ "resource:extra/xml/tests/test.xml"
     [ file>xml ] with-html-entities xml-file set ] unit-test
 [ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
 [ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor
index 4cac3051c3..4e2ad7a672 100644
--- a/extra/xml/xml.factor
+++ b/extra/xml/xml.factor
@@ -3,18 +3,12 @@
 USING: io io.streams.string io.files kernel math namespaces
 prettyprint sequences arrays generic strings vectors
 xml.char-classes xml.data xml.errors xml.tokenize xml.writer
-xml.utilities state-parser assocs ascii io.encodings.utf8 ;
+xml.utilities state-parser assocs ascii io.encodings.utf8
+accessors xml.backend ;
 IN: xml
 
 !   -- Overall parser with data tree
 
-! A stack of { tag children } pairs
-SYMBOL: xml-stack
-
-:  ( -- unclosed )
-    xml-stack get rest-slice [ first opener-name ] map
-    { set-unclosed-tags } unclosed construct ;
-
 : add-child ( object -- )
     xml-stack get peek second push ;
 
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 22d3217ee6..277439c0cd 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -24,7 +24,7 @@ TAGS>
     ] keep ;
 
 : load-catalog ( -- modes )
-    "extra/xmode/modes/catalog" resource-path
+    "resource:extra/xmode/modes/catalog"
     file>xml parse-modes-tag ;
 
 : modes ( -- assoc )
@@ -38,8 +38,8 @@ TAGS>
 MEMO: (load-mode) ( name -- rule-sets )
     modes at [
         mode-file
-        "extra/xmode/modes/" prepend
-        resource-path utf8  parse-mode
+        "resource:extra/xmode/modes/" prepend
+        utf8  parse-mode
     ] [
         "text" (load-mode)
     ] if* ;
diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor
index f6df23b9b2..3977f4277c 100755
--- a/extra/xmode/code2html/code2html.factor
+++ b/extra/xmode/code2html/code2html.factor
@@ -20,8 +20,8 @@ IN: xmode.code2html
 
 : default-stylesheet ( -- )
      ;
 
 : htmlize-stream ( path stream -- )
diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor
index 99689d8819..a2183edbc9 100755
--- a/extra/xmode/utilities/utilities-tests.factor
+++ b/extra/xmode/utilities/utilities-tests.factor
@@ -48,6 +48,6 @@ TAGS>
         "This is a great company"
     }
 ] [
-    "extra/xmode/utilities/test.xml"
-    resource-path file>xml parse-company-tag
+    "resource:extra/xmode/utilities/test.xml"
+    file>xml parse-company-tag
 ] unit-test
diff --git a/extra/yahoo/yahoo-tests.factor b/extra/yahoo/yahoo-tests.factor
index 197fa4900b..46d05ce720 100644
--- a/extra/yahoo/yahoo-tests.factor
+++ b/extra/yahoo/yahoo-tests.factor
@@ -6,6 +6,6 @@ USING: tools.test yahoo kernel io.files xml sequences ;
     "Official Foo Fighters"
     "http://www.foofighters.com/"
     "Official site with news, tour dates, discography, store, community, and more."
-} ] [ "extra/yahoo/test-results.xml" resource-path file>xml parse-yahoo first ] unit-test
+} ] [ "resource:extra/yahoo/test-results.xml" file>xml parse-yahoo first ] unit-test
 
 [ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=1" ] [ "hi" 1 query ] unit-test
diff --git a/extra/openssl/authors.txt b/unmaintained/openssl/authors.txt
similarity index 100%
rename from extra/openssl/authors.txt
rename to unmaintained/openssl/authors.txt
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/unmaintained/openssl/libcrypto/libcrypto.factor
similarity index 100%
rename from extra/openssl/libcrypto/libcrypto.factor
rename to unmaintained/openssl/libcrypto/libcrypto.factor
diff --git a/extra/openssl/libssl/libssl.factor b/unmaintained/openssl/libssl/libssl.factor
similarity index 100%
rename from extra/openssl/libssl/libssl.factor
rename to unmaintained/openssl/libssl/libssl.factor
diff --git a/extra/openssl/openssl-docs.factor b/unmaintained/openssl/openssl-docs.factor
similarity index 100%
rename from extra/openssl/openssl-docs.factor
rename to unmaintained/openssl/openssl-docs.factor
diff --git a/extra/openssl/openssl-tests.factor b/unmaintained/openssl/openssl-tests.factor
similarity index 91%
rename from extra/openssl/openssl-tests.factor
rename to unmaintained/openssl/openssl-tests.factor
index f42c611fc0..2b840bdb9c 100755
--- a/extra/openssl/openssl-tests.factor
+++ b/unmaintained/openssl/openssl-tests.factor
@@ -27,7 +27,7 @@ math.parser openssl prettyprint sequences tools.test ;
 
 [ ] [ ssl-v23 new-ctx ] unit-test
 
-[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
+[ ] [ get-ctx "resource:extra/openssl/test/server.pem" use-cert-chain ] unit-test
 
 ! TODO: debug 'Memory protection fault at address 6c'
 ! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
@@ -35,10 +35,10 @@ math.parser openssl prettyprint sequences tools.test ;
 [ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
 
 ! Enter PEM pass phrase: password
-[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path
+[ ] [ get-ctx "resource:extra/openssl/test/server.pem"
 SSL_FILETYPE_PEM use-private-key ] unit-test
 
-[ ] [ get-ctx "extra/openssl/test/root.pem" resource-path f
+[ ] [ get-ctx "resource:extra/openssl/test/root.pem" f
 verify-load-locations ] unit-test
 
 [ ] [ get-ctx 1 set-verify-depth ] unit-test
@@ -47,7 +47,7 @@ verify-load-locations ] unit-test
 ! Load Diffie-Hellman parameters
 ! =========================================================
 
-[ ] [ "extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
+[ ] [ "resource:extra/openssl/test/dh1024.pem" "r" bio-new-file ] unit-test
 
 [ ] [ get-bio f f f read-pem-dh-params ] unit-test
 
@@ -131,7 +131,7 @@ verify-load-locations ] unit-test
 ! Dump errors to file
 ! =========================================================
 
-[ ] [ "extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
+[ ] [ "resource:extra/openssl/test/errors.txt" "w" bio-new-file ] unit-test
 
 [ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
 
diff --git a/extra/openssl/openssl.factor b/unmaintained/openssl/openssl.factor
similarity index 100%
rename from extra/openssl/openssl.factor
rename to unmaintained/openssl/openssl.factor
diff --git a/extra/openssl/summary.txt b/unmaintained/openssl/summary.txt
similarity index 100%
rename from extra/openssl/summary.txt
rename to unmaintained/openssl/summary.txt
diff --git a/extra/openssl/tags.txt b/unmaintained/openssl/tags.txt
similarity index 100%
rename from extra/openssl/tags.txt
rename to unmaintained/openssl/tags.txt
diff --git a/extra/openssl/test/dh1024.pem b/unmaintained/openssl/test/dh1024.pem
similarity index 100%
rename from extra/openssl/test/dh1024.pem
rename to unmaintained/openssl/test/dh1024.pem
diff --git a/extra/openssl/test/errors.txt b/unmaintained/openssl/test/errors.txt
similarity index 100%
rename from extra/openssl/test/errors.txt
rename to unmaintained/openssl/test/errors.txt
diff --git a/extra/openssl/test/root.pem b/unmaintained/openssl/test/root.pem
similarity index 100%
rename from extra/openssl/test/root.pem
rename to unmaintained/openssl/test/root.pem
diff --git a/extra/openssl/test/server.pem b/unmaintained/openssl/test/server.pem
similarity index 100%
rename from extra/openssl/test/server.pem
rename to unmaintained/openssl/test/server.pem
diff --git a/vm/Config.unix b/vm/Config.unix
index e7b19e96e1..a25d0df95e 100644
--- a/vm/Config.unix
+++ b/vm/Config.unix
@@ -1,4 +1,6 @@
-CFLAGS += -fomit-frame-pointer
+ifndef DEBUG
+	CFLAGS += -fomit-frame-pointer
+endif
 
 EXE_SUFFIX =
 DLL_PREFIX = lib
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 5aa47c8c6c..f44b8a7a05 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -21,10 +21,12 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start)
 	return z->end;
 }
 
-void init_cards_offset(void)
+void init_card_decks(void)
 {
-	cards_offset = (CELL)data_heap->cards
-		- (data_heap->segment->start >> CARD_BITS);
+	CELL start = data_heap->segment->start & ~(DECK_SIZE - 1);
+	allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
+	cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
+	decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
 }
 
 F_DATA_HEAP *alloc_data_heap(CELL gens,
@@ -62,10 +64,17 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
 	data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
 	data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
 
-	CELL cards_size = total_size / CARD_SIZE;
+	CELL cards_size = (total_size + DECK_SIZE) / CARD_SIZE;
+	data_heap->allot_markers = safe_malloc(cards_size);
+	data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
+
 	data_heap->cards = safe_malloc(cards_size);
 	data_heap->cards_end = data_heap->cards + cards_size;
 
+	CELL decks_size = (total_size + DECK_SIZE) / DECK_SIZE;
+	data_heap->decks = safe_malloc(decks_size);
+	data_heap->decks_end = data_heap->decks + decks_size;
+
 	CELL alloter = data_heap->segment->start;
 
 	alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
@@ -104,7 +113,9 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap)
 	dealloc_segment(data_heap->segment);
 	free(data_heap->generations);
 	free(data_heap->semispaces);
+	free(data_heap->allot_markers);
 	free(data_heap->cards);
+	free(data_heap->decks);
 	free(data_heap);
 }
 
@@ -113,18 +124,45 @@ cleared when a generation has been cleared */
 void clear_cards(CELL from, CELL to)
 {
 	/* NOTE: reverse order due to heap layout. */
+	F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
 	F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
-	F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[to].start);
-	for(; ptr < last_card; ptr++)
-		clear_card(ptr);
+	F_CARD *ptr;
+	for(ptr = first_card; ptr < last_card; ptr++) *ptr = 0;
+}
+
+void clear_decks(CELL from, CELL to)
+{
+	/* NOTE: reverse order due to heap layout. */
+	F_CARD *first_deck = ADDR_TO_CARD(data_heap->generations[to].start);
+	F_CARD *last_deck = ADDR_TO_CARD(data_heap->generations[from].end);
+	F_CARD *ptr;
+	for(ptr = first_deck; ptr < last_deck; ptr++) *ptr = 0;
+}
+
+void clear_allot_markers(CELL from, CELL to)
+{
+	/* NOTE: reverse order due to heap layout. */
+	F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
+	F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
+	F_CARD *ptr;
+	for(ptr = first_card; ptr < last_card; ptr++) *ptr = CARD_BASE_MASK;
 }
 
 void set_data_heap(F_DATA_HEAP *data_heap_)
 {
 	data_heap = data_heap_;
 	nursery = data_heap->generations[NURSERY];
-	init_cards_offset();
+	init_card_decks();
 	clear_cards(NURSERY,TENURED);
+	clear_decks(NURSERY,TENURED);
+	clear_allot_markers(NURSERY,TENURED);
+}
+
+void gc_reset(void)
+{
+	int i;
+	for(i = 0; i < MAX_GEN_COUNT; i++)
+		memset(&gc_stats[i],0,sizeof(F_GC_STATS));
 }
 
 void init_data_heap(CELL gens,
@@ -141,11 +179,13 @@ void init_data_heap(CELL gens,
 	extra_roots_region = alloc_segment(getpagesize());
 	extra_roots = extra_roots_region->start - CELLS;
 
-	gc_time = 0;
-	aging_collections = 0;
-	nursery_collections = 0;
-	cards_scanned = 0;
 	secure_gc = secure_gc_;
+
+	gc_reset();
+
+	cards_scanned = 0;
+	decks_scanned = 0;
+	code_heap_scans = 0;
 }
 
 /* Size of the object pointed to by a tagged pointer */
@@ -228,6 +268,7 @@ DEFINE_PRIMITIVE(data_room)
 	int gen;
 
 	dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
+	dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
 
 	for(gen = 0; gen < data_heap->gen_count; gen++)
 	{
@@ -263,7 +304,7 @@ CELL next_object(void)
 
 	if(heap_scan_ptr >= data_heap->generations[TENURED].here)
 		return F;
-	
+
 	type = untag_header(value);
 	heap_scan_ptr += untagged_object_size(heap_scan_ptr);
 
@@ -283,36 +324,60 @@ DEFINE_PRIMITIVE(end_scan)
 }
 
 /* Scan all the objects in the card */
-INLINE void collect_card(F_CARD *ptr, CELL gen, CELL here)
+void collect_card(F_CARD *ptr, CELL gen, CELL here)
 {
-	F_CARD c = *ptr;
-	CELL offset = (c & CARD_BASE_MASK);
+	CELL offset = CARD_OFFSET(ptr);
 
-	if(offset == CARD_BASE_MASK)
+	if(offset != CARD_BASE_MASK)
 	{
-		if(c == 0xff)
-			critical_error("bad card",(CELL)ptr);
-		else
-			return;
+		CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
+		CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
+
+		while(card_scan < card_end && card_scan < here)
+			card_scan = collect_next(card_scan);
+
+		cards_scanned++;
+	}
+}
+
+void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
+{
+	F_CARD *first_card = DECK_TO_CARD(deck);
+	F_CARD *last_card = DECK_TO_CARD(deck + 1);
+
+	CELL here = data_heap->generations[gen].here;
+
+	u32 *quad_ptr;
+	u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
+
+	for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
+	{
+		if(*quad_ptr & quad_mask)
+		{
+			F_CARD *ptr = (F_CARD *)quad_ptr;
+
+			int card;
+			for(card = 0; card < 4; card++)
+			{
+				if(ptr[card] & mask)
+				{
+					collect_card(&ptr[card],gen,here);
+					ptr[card] &= ~unmask;
+				}
+			}
+		}
 	}
 
-	CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
-	CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-
-	while(card_scan < card_end && card_scan < here)
-		card_scan = collect_next(card_scan);
-
-	cards_scanned++;
+	decks_scanned++;
 }
 
 /* Copy all newspace objects referenced from marked cards to the destination */
-INLINE void collect_gen_cards(CELL gen)
+void collect_gen_cards(CELL gen)
 {
-	F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[gen].start);
-	CELL here = data_heap->generations[gen].here;
-	F_CARD *last_card = ADDR_TO_CARD(here - 1);
+	F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
+	F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
 
-	CELL mask, unmask;
+	F_CARD mask, unmask;
 
 	/* if we are collecting the nursery, we care about old->nursery pointers
 	but not old->aging pointers */
@@ -360,11 +425,13 @@ INLINE void collect_gen_cards(CELL gen)
 		return;
 	}
 
-	for(; ptr <= last_card; ptr++)
+	F_DECK *ptr;
+
+	for(ptr = first_deck; ptr < last_deck; ptr++)
 	{
 		if(*ptr & mask)
 		{
-			collect_card(ptr,gen,here);
+			collect_card_deck(ptr,gen,mask,unmask);
 			*ptr &= ~unmask;
 		}
 	}
@@ -454,6 +521,11 @@ INLINE void *copy_untagged_object(void *pointer, CELL size)
 		longjmp(gc_jmp,1);
 	allot_barrier(newspace->here);
 	newpointer = allot_zone(newspace,size);
+
+	F_GC_STATS *s = &gc_stats[collecting_gen];
+	s->object_count++;
+	s->bytes_copied += size;
+
 	memcpy(newpointer,pointer,size);
 	return newpointer;
 }
@@ -584,6 +656,7 @@ CELL collect_next(CELL scan)
 INLINE void reset_generation(CELL i)
 {
 	F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
+
 	z->here = z->start;
 	if(secure_gc)
 		memset((void*)z->start,69,z->size);
@@ -594,8 +667,12 @@ their allocation pointers and cards reset. */
 void reset_generations(CELL from, CELL to)
 {
 	CELL i;
-	for(i = from; i <= to; i++) reset_generation(i);
+	for(i = from; i <= to; i++)
+		reset_generation(i);
+
 	clear_cards(from,to);
+	clear_decks(from,to);
+	clear_allot_markers(from,to);
 }
 
 /* Prepare to start copying reachable objects into an unused zone */
@@ -620,6 +697,8 @@ void begin_gc(CELL requested_bytes)
 		reset_generation(collecting_gen);
 		newspace = &data_heap->generations[collecting_gen];
 		clear_cards(collecting_gen,collecting_gen);
+		clear_decks(collecting_gen,collecting_gen);
+		clear_allot_markers(collecting_gen,collecting_gen);
 	}
 	else
 	{
@@ -638,8 +717,15 @@ void begin_gc(CELL requested_bytes)
 #endif
 }
 
-void end_gc(void)
+void end_gc(CELL gc_elapsed)
 {
+	F_GC_STATS *s = &gc_stats[collecting_gen];
+
+	s->collections++;
+	s->gc_time += gc_elapsed;
+	if(s->max_gc_time < gc_elapsed)
+		s->max_gc_time = gc_elapsed;
+
 	if(growing_data_heap)
 	{
 		dealloc_data_heap(old_data_heap);
@@ -654,29 +740,12 @@ void end_gc(void)
 		old-school Cheney collector */
 		if(collecting_gen != NURSERY)
 			reset_generations(NURSERY,collecting_gen - 1);
-
-		if(collecting_gen == TENURED)
-		{
-			GC_PRINT(END_AGING_GC,aging_collections,cards_scanned);
-			aging_collections = 0;
-			cards_scanned = 0;
-		}
-		else if(HAVE_AGING_P && collecting_gen == AGING)
-		{
-			aging_collections++;
-
-			GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned);
-			nursery_collections = 0;
-			cards_scanned = 0;
-		}
 	}
 	else
 	{
 		/* all generations up to and including the one
 		collected are now empty */
 		reset_generations(NURSERY,collecting_gen);
-
-		nursery_collections++;
 	}
 
 	if(collecting_gen == TENURED)
@@ -758,7 +827,10 @@ void garbage_collection(CELL gen,
 			literals from any code block which gets marked as live.
 			if we are not doing code GC, just consider all literals
 			as roots. */
+			code_heap_scans++;
+
 			collect_literals();
+
 			if(collecting_accumulation_gen_p())
 				last_code_heap_scan = collecting_gen;
 			else
@@ -772,9 +844,8 @@ void garbage_collection(CELL gen,
 	CELL gc_elapsed = (current_millis() - start);
 
 	GC_PRINT(END_GC,gc_elapsed);
-	end_gc();
+	end_gc(gc_elapsed);
 
-	gc_time += gc_elapsed;
 	performing_gc = false;
 }
 
@@ -793,10 +864,38 @@ DEFINE_PRIMITIVE(gc)
 	gc();
 }
 
-/* Push total time spent on GC */
-DEFINE_PRIMITIVE(gc_time)
+DEFINE_PRIMITIVE(gc_stats)
 {
-	box_unsigned_8(gc_time);
+	GROWABLE_ARRAY(stats);
+
+	CELL i;
+	CELL total_gc_time = 0;
+
+	for(i = 0; i < MAX_GEN_COUNT; i++)
+	{
+		F_GC_STATS *s = &gc_stats[i];
+		GROWABLE_ADD(stats,allot_cell(s->collections));
+		GROWABLE_ADD(stats,allot_cell(s->gc_time));
+		GROWABLE_ADD(stats,allot_cell(s->max_gc_time));
+		GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
+		GROWABLE_ADD(stats,allot_cell(s->object_count));
+		GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
+
+		total_gc_time += s->gc_time;
+	}
+
+	GROWABLE_ADD(stats,allot_cell(total_gc_time));
+	GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
+	GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
+	GROWABLE_ADD(stats,allot_cell(code_heap_scans));
+
+	GROWABLE_TRIM(stats);
+	dpush(stats);
+}
+
+DEFINE_PRIMITIVE(gc_reset)
+{
+	gc_reset();
 }
 
 DEFINE_PRIMITIVE(become)
@@ -809,7 +908,7 @@ DEFINE_PRIMITIVE(become)
 		critical_error("bad parameters to become",0);
 
 	CELL i;
-	
+
 	for(i = 0; i < capacity; i++)
 	{
 		CELL old_obj = array_nth(old_objects,i);
diff --git a/vm/data_gc.h b/vm/data_gc.h
index be9ed159b7..20692c14e6 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -44,8 +44,14 @@ typedef struct {
 	F_ZONE *generations;
 	F_ZONE* semispaces;
 
+	CELL *allot_markers;
+	CELL *allot_markers_end;
+
 	CELL *cards;
 	CELL *cards_end;
+
+	CELL *decks;
+	CELL *decks_end;
 } F_DATA_HEAP;
 
 F_DATA_HEAP *data_heap;
@@ -71,25 +77,39 @@ offset within the card */
 #define CARD_BITS 6
 #define ADDR_CARD_MASK (CARD_SIZE-1)
 
-INLINE void clear_card(F_CARD *c)
-{
-	*c = CARD_BASE_MASK; /* invalid value */
-}
-
 DLLEXPORT CELL cards_offset;
-void init_cards_offset(void);
+DLLEXPORT CELL allot_markers_offset;
 
 #define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
 #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> DECK_BITS) + decks_offset)
+#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
+
+#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
+
+#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
+#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
+
+void init_card_decks(void);
+
 /* this is an inefficient write barrier. compiled definitions use a more
 efficient one hand-coded in assembly. the write barrier must be called
 any time we are potentially storing a pointer from an older generation
 to a younger one */
 INLINE void write_barrier(CELL address)
 {
-	F_CARD *c = ADDR_TO_CARD(address);
-	*c |= (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING);
+	*ADDR_TO_CARD(address) = CARD_MARK_MASK;
+	*ADDR_TO_DECK(address) = CARD_MARK_MASK;
 }
 
 #define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
@@ -103,11 +123,10 @@ INLINE void set_slot(CELL obj, CELL slot, CELL value)
 /* we need to remember the first object allocated in the card */
 INLINE void allot_barrier(CELL address)
 {
-	F_CARD *ptr = ADDR_TO_CARD(address);
-	F_CARD c = *ptr;
-	CELL b = (c & CARD_BASE_MASK);
-	CELL a = (address & ADDR_CARD_MASK);
-	*ptr = ((c & CARD_MARK_MASK) | ((b < a) ? b : a));
+	F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
+	F_CARD b = *ptr;
+	F_CARD a = (address & ADDR_CARD_MASK);
+	*ptr = (b < a ? b : a);
 }
 
 void clear_cards(CELL from, CELL to);
@@ -122,6 +141,8 @@ void collect_cards(void);
 /* the oldest generation */
 #define TENURED (data_heap->gen_count-1)
 
+#define MAX_GEN_COUNT 3
+
 /* used during garbage collection only */
 F_ZONE *newspace;
 
@@ -142,10 +163,18 @@ void init_data_heap(CELL gens,
 	bool secure_gc_);
 
 /* statistics */
-s64 gc_time;
-CELL nursery_collections;
-CELL aging_collections;
-CELL cards_scanned;
+typedef struct {
+	CELL collections;
+	CELL gc_time;
+	CELL max_gc_time;
+	CELL object_count;
+	u64 bytes_copied;
+} F_GC_STATS;
+
+F_GC_STATS gc_stats[MAX_GEN_COUNT];
+u64 cards_scanned;
+u64 decks_scanned;
+CELL code_heap_scans;
 
 /* only meaningful during a GC */
 bool performing_gc;
@@ -364,7 +393,8 @@ INLINE void* allot_object(CELL type, CELL a)
 CELL collect_next(CELL scan);
 
 DECLARE_PRIMITIVE(gc);
-DECLARE_PRIMITIVE(gc_time);
+DECLARE_PRIMITIVE(gc_stats);
+DECLARE_PRIMITIVE(gc_reset);
 DECLARE_PRIMITIVE(become);
 
 CELL find_all_words(void);
diff --git a/vm/os-linux.c b/vm/os-linux.c
index 935add6714..91017fc3f8 100644
--- a/vm/os-linux.c
+++ b/vm/os-linux.c
@@ -18,6 +18,8 @@ const char *vm_executable_path(void)
 	}
 }
 
+#ifdef SYS_inotify_init
+
 int inotify_init(void)
 {
 	return syscall(SYS_inotify_init);
@@ -32,3 +34,25 @@ int inotify_rm_watch(int fd, u32 wd)
 {
 	return syscall(SYS_inotify_rm_watch, fd, wd);
 }
+
+#else
+
+int inotify_init(void)
+{
+	not_implemented_error();
+	return -1;
+}
+
+int inotify_add_watch(int fd, const char *name, u32 mask)
+{
+	not_implemented_error();
+	return -1;
+}
+
+int inotify_rm_watch(int fd, u32 wd)
+{
+	not_implemented_error();
+	return -1;
+}
+
+#endif
diff --git a/vm/primitives.c b/vm/primitives.c
index da04870ecd..133ca38567 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -91,7 +91,7 @@ void *primitives[] = {
 	primitive_existsp,
 	primitive_read_dir,
 	primitive_gc,
-	primitive_gc_time,
+	primitive_gc_stats,
 	primitive_save_image,
 	primitive_save_image_and_exit,
 	primitive_datastack,
@@ -186,4 +186,5 @@ void *primitives[] = {
 	primitive_resize_float_array,
 	primitive_dll_validp,
 	primitive_unimplemented,
+	primitive_gc_reset,
 };