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

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
 

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" } ;

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

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

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 )

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
+        over "compiled-effect" word-prop = [
-    ] computing-dependencies ;
+            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 ]
+        H{ } clone dependencies set
-    [ dupd compile-failed f save-effect ]
+
-    recover ;
+        {
+            [ compile-begins ]
+            [
+                [ word-dataflow ] [ compile-failed return ] recover
+                optimize
+            ]
+            [ dup generate ]
+            [ compile-succeeded ]
+        } cleave
+    ] curry with-return ;
 
 : compile-loop ( assoc -- )
     dup assoc-empty? [ drop ] [

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

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

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 )
 
 <PRIVATE

core/cpu/ppc/intrinsics/intrinsics.factor

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

core/cpu/x86/32/32.factor

@@ -22,8 +22,9 @@ M: x86.32 temp-reg-2 ECX ;
 
 M: temp-reg v>operand drop EBX ;
 
-M: x86.32 %alien-invoke ( symbol dll -- )
+M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
-    (CALL) 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 ;

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 ( -- )

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
+cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
-memory namespaces sequences words generator generator.registers
+kernel kernel.private math memory namespaces sequences words
-generator.fixup system layouts combinators compiler.constants
+generator generator.registers generator.fixup system layouts
-math.order ;
+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 -- )
+HOOK: %alien-global cpu ( symbol dll register -- )
-    [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
 
 M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a

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 <byte> OR ] { } make ] unit-test
+[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test

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> byte
+
 <PRIVATE
 
 #! Extended AMD64 registers (R8-R15) return true.
@@ -75,50 +74,38 @@ M: register extended? "register" word-prop 7 > ;
 ! Addressing modes
 TUPLE: indirect base index scale displacement ;
 
-M: indirect extended? indirect-base extended? ;
+M: indirect extended? base>> extended? ;
 
 : canonicalize-EBP
     #! { EBP } ==> { EBP 0 }
-    dup indirect-base { EBP RBP R13 } memq? [
+    dup base>> { EBP RBP R13 } member? [
-        dup indirect-displacement [
+        dup displacement>> [ 0 >>displacement ] unless
-            drop
+    ] when drop ;
-        ] [
-            0 swap set-indirect-displacement
-        ] if
-    ] [
-        drop
-    ] if ;
 
 : canonicalize-ESP
     #! { ESP } ==> { ESP ESP }
-    dup indirect-base { ESP RSP R12 } memq? [
+    dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ;
-        ESP swap set-indirect-index
-    ] [
-        drop
-    ] if ;
 
 : canonicalize ( indirect -- )
     #! Modify the indirect to work around certain addressing mode
     #! quirks.
-    dup canonicalize-EBP
+    [ canonicalize-EBP ] [ canonicalize-ESP ] bi ;
-    canonicalize-ESP ;
 
 : <indirect> ( base index scale displacement -- indirect )
     indirect boa dup canonicalize ;
 
 : reg-code "register" word-prop 7 bitand ;
 
-: indirect-base* indirect-base EBP or reg-code ;
+: indirect-base* base>> EBP or reg-code ;
 
-: indirect-index* indirect-index ESP or reg-code ;
+: indirect-index* index>> ESP or reg-code ;
 
-: indirect-scale* indirect-scale 0 or ;
+: indirect-scale* scale>> 0 or ;
 
 GENERIC: sib-present? ( op -- ? )
 
 M: indirect sib-present?
-    dup indirect-base { ESP RSP } memq?
+    [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
-    over indirect-index rot indirect-scale 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 [
+    dup base>> [
-        indirect-displacement {
+        displacement>> {
-            { [ dup not ]      [ BIN: 00 ] }
+            { [ dup not ] [ BIN: 00 ] }
-            { [ dup byte? ]    [ BIN: 01 ] }
+            { [ dup fits-in-byte? ] [ BIN: 01 ] }
-            { [ dup integer? ] [ BIN: 10 ] }
+            { [ 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*
+        [ indirect-base* ]
-        over indirect-index* 3 shift bitor
+        [ indirect-index* 3 shift ]
-        swap indirect-scale* 6 shift bitor ,
+        [ 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 [
+    dup displacement>> dup [
-        swap indirect-base
+        swap base>>
-        [ dup byte? [ , ] [ 4, ] if ] [ 4, ] if
+        [ 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 -- ? )
+GENERIC: operand-64? ( operand -- ? )
-    dup indirect? [
+
-        dup indirect-base register-64?
+M: indirect operand-64?
-        swap indirect-index register-64? or
+    [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
-    ] [
+
-        register-64?
+M: register-64 operand-64? drop t ;
-    ] if ;
+
+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?
+        index>> extended? [ BIN: 00000010 bitor ] when
-        [ 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 -- )
+: immediate-operand-size-bit
-    1-operand , ;
+    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? [
+    pick fits-in-byte? [
-        r> r> BIN: 10 opcode-or immediate-1
+        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: immediate PUSH HEX: 68 , 4, ;
-M: operand PUSH BIN: 110 f HEX: ff 1-operand ;
+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 ;
+: NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
-: NEG  ( dst -- ) BIN: 011 t HEX: f7 1-operand ;
+: NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
-: MUL  ( dst -- ) BIN: 100 t HEX: f7 1-operand ;
+: MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
-: IMUL ( src -- ) BIN: 101 t HEX: f7 1-operand ;
+: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
-: DIV  ( dst -- ) BIN: 110 t HEX: f7 1-operand ;
+: DIV  ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
-: IDIV ( src -- ) BIN: 111 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 ;
+: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
-: ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ;
+: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
-: RCL ( dst n -- ) swap BIN: 010 t HEX: c1 immediate-1 ;
+: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
-: RCR ( dst n -- ) swap BIN: 011 t HEX: c1 immediate-1 ;
+: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
-: SHL ( dst n -- ) swap BIN: 100 t HEX: c1 immediate-1 ;
+: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
-: SHR ( dst n -- ) swap BIN: 101 t HEX: c1 immediate-1 ;
+: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
-: SAR ( dst n -- ) swap BIN: 111 t HEX: c1 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 ;
+: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
-: FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ;
+: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
 
-: FLDS ( operand -- ) BIN: 000 f HEX: d9 1-operand ;
+: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
-: FLDL ( operand -- ) BIN: 000 f HEX: dd 1-operand ;
+: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
 
 ! SSE multimedia instructions
 

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 <byte> MOV
+
+        ! Mark the card deck
+        "obj" operand deck-bits card-bits - SHR
+        "decks_offset" f temp-reg v>operand %alien-global
+        temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
     ] unless ;
 
 \ set-slot {

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

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-and-restarts ] recover ;
-        print-error
-        restarts.
-        nl
-        "Type :help for debugging help." print flush
-    ] 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-in-thread. ( thread -- )
-    error-thread get-global
     "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 ;
 

core/inference/known-words/known-words.factor

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

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

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?
 

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

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-reader> ( resource -- stream )
-    resource-path ascii <file-reader> ;
-    
 [ { } ]
-[ "core/io/test/empty-file.txt" <resource-reader> lines ]
+[ "resource:core/io/test/empty-file.txt" ascii <file-reader> lines ]
 unit-test
 
 : lines-test ( stream -- line1 line2 )
@@ -16,21 +13,24 @@ unit-test
     "This is a line."
     "This is another line."
 ] [
-    "core/io/test/windows-eol.txt" <resource-reader> lines-test
+    "resource:core/io/test/windows-eol.txt"
+    ascii <file-reader> lines-test
 ] unit-test
 
 [
     "This is a line."
     "This is another line."
 ] [
-    "core/io/test/mac-os-eol.txt" <resource-reader> lines-test
+    "resource:core/io/test/mac-os-eol.txt"
+    ascii <file-reader> lines-test
 ] unit-test
 
 [
     "This is a line."
     "This is another line."
 ] [
-    "core/io/test/unix-eol.txt" <resource-reader> lines-test
+    "resource:core/io/test/unix-eol.txt"
+    ascii <file-reader> lines-test
 ] unit-test
 
 [

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
 

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

core/io/io-tests.factor

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

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 )

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* ]

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." } ;

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 ;
 

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

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 <slice> }
 { $subsection head-slice }
 { $subsection tail-slice }
+{ $subsection but-last-slice }
 { $subsection rest-slice }
 { $subsection head-slice* }
 { $subsection tail-slice* }
@@ -836,11 +839,16 @@ HELP: tail-slice
 { $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
 { $errors "Throws an error if the index is out of bounds." } ;
 
+HELP: but-last-slice
+{ $values { "seq" sequence } { "slice" "a slice" } }
+{ $description "Outputs a virtual sequence sharing storage with all but the last element of the input sequence." }
+{ $errors "Throws an error on an empty sequence." } ;
+
 HELP: rest-slice
 { $values { "seq" sequence } { "slice" "a slice" } }
 { $description "Outputs a virtual sequence sharing storage with all elements from the 1st index until the end of the input sequence." }
 { $notes "Equivalent to " { $snippet "1 tail" } }
-{ $errors "Throws an error if the index is out of bounds." } ;
+{ $errors "Throws an error on an empty sequence." } ;
 
 HELP: head-slice*
 { $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } }
@@ -862,6 +870,11 @@ HELP: tail
 { $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
 { $errors "Throws an error if the index is out of bounds." } ;
 
+HELP: but-last
+{ $values { "seq" sequence } { "headseq" "a new sequence" } }
+{ $description "Outputs a new sequence consisting of the input sequence with the last item removed." }
+{ $errors "Throws an error on an empty sequence." } ;
+
 HELP: rest
 { $values { "seq" sequence } { "tailseq" "a new sequence" } }
 { $description "Outputs a new sequence consisting of the input sequence with the first item removed." }

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 ;
 
 : <flat-slice> ( seq -- slice )
     dup slice? [ { } like ] when 0 over length rot <slice> ;

core/splitting/splitting.factor

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

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 [ <promise> ] g [ gensym ] |
+        [
+            g "x" set
+            [ "x" get p fulfill ] "B" spawn drop
+        ] with-scope
+        p ?promise g eq?
+    ] ;
+
+[ t ] [ spawn-namespace-test ] unit-test

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

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 )

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

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 ;
 

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 ;
 

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 ;
 

extra/benchmark/sockets/sockets.factor

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

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-load  ] benchmark "../load-time" utf8 [ . ] with-file-writer
-  [ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer
+  [ do-tests ] benchmark "../test-time" utf8 [ . ] with-file-writer
   do-help-lint
   do-benchmarks ;
 

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 ;

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 ;
 
 : <png> ( path -- png )
     normalize-path

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"

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 <string> adler-32 checksum-bytes ] unit-test

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] <reversed> v. ] [ length ] bi + ] bi
+    [ adler-32-modulus mod ] bi@ 16 shift bitor ;

extra/checksums/adler-32/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

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 ;

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 } ;

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

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 ;

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"

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

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 )
+: (parallel-each) ( n quot -- )
-    [ curry future ] curry map dup [ ?future ] change-each ;
+    >r <count-down> r> keep await ; inline
-    inline
 
 : parallel-each ( seq quot -- )
-    over length <count-down>
+    over length [
-    [ [ >r curry r> spawn-stage ] 2curry each ] keep await ;
+        [ >r curry r> spawn-stage ] 2curry each
-    inline
+    ] (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 ;

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? [
+    dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
-        t swap count-down-promise fulfill
-    ] [ drop ] if ;
 
 : <count-down> ( n -- count-down )
     dup 0 < [ "Invalid count for count down" throw ] when
@@ -19,15 +17,12 @@ TUPLE: count-down n promise ;
     dup count-down-check ;
 
 : count-down ( count-down -- )
-    dup count-down-n dup zero? [
+    dup n>> dup zero?
-        "Count down already done" throw
+    [ "Count down already done" throw ]
-    ] [
+    [ 1- >>n count-down-check ] if ;
-        1- over set-count-down-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
+    swap promise>> mailbox>> spawn-linked-to drop ;
-    promise-mailbox spawn-linked-to drop ;

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

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> ( -- flag ) f <box> flag boa ;
+: <flag> ( -- flag ) f <dlist> flag boa ;
 
 : raise-flag ( flag -- )
-    dup flag-value? [
+    dup value>> [ drop ] [ t >>value threads>> notify-all ] if ;
-        t over set-flag-value?
+
-        dup flag-thread [ resume ] if-box?
+: wait-for-flag-timeout ( flag timeout -- )
-    ] unless drop ;
+    over value>> [ 2drop ] [ >r threads>> r> "flag" wait ] if ;
 
 : wait-for-flag ( flag -- )
-    dup flag-value? [ drop ] [
+    f wait-for-flag-timeout ;
-        [ flag-thread >box ] curry "flag" suspend drop
-    ] if ;
 
 : lower-flag ( flag -- )
-    dup wait-for-flag f swap set-flag-value? ;
+    [ wait-for-flag ] [ f >>value drop ] bi ;

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-error
 
 : ?linked dup linked-error? [ rethrow ] when ;

extra/contributors/contributors-tests.factor

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

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
+USING: io.files io.launcher io.styles io.encodings.ascii io
-sequences sequences.lib assocs system sorting math.parser
+hashtables kernel sequences sequences.lib assocs system sorting
-sets ;
+math.parser sets ;
 IN: contributors
 
 : changelog ( -- authors )
     image parent-directory [
-        "git-log --pretty=format:%an" <process-reader> lines
+        "git-log --pretty=format:%an" ascii <process-reader> lines
     ] with-directory ;
 
 : patch-counts ( authors -- assoc )

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

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' )

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? ;
 

extra/http/http-tests.factor

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

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 ;

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 } } <interval-map> ] must-fail
+
+[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]
+[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test

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 ;
 
 : <interval-map> ( specification -- map )
-    all-intervals ensure-disjoint
+    all-intervals { } assoc-like
-    [ [ first to>> ] compare ] sort
+    [ [ 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 ;

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 )

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"
+    "resource:extra/io/encodings/8-bit/" ".TXT"
-    swapd 3append resource-path
+    swapd 3append ascii <file-reader> ;
-    ascii <file-reader> ;
 
 : tail-if ( seq n -- newseq )
     2dup swap length <= [ tail ] [ drop ] if ;

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
+USING: system kernel namespaces strings hashtables sequences 
-namespaces strings hashtables sequences assocs combinators
+assocs combinators vocabs.loader init threads continuations
-vocabs.loader init threads continuations math io.encodings
+math accessors concurrency.flags destructors
-io.streams.duplex io.nonblocking io.streams.duplex accessors
+io io.backend io.timeouts io.pipes io.pipes.private io.encodings
-concurrency.flags destructors ;
+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
+M: object run-pipeline-element
-    [
+    [ >process swap >>stdout swap >>stdin run-detached ]
-        >process
+    [ drop [ [ close-handle ] when* ] bi@ ]
-            swap >>stdout
+    3bi
-            swap >>stdin
+    wait-for-process ;
-        run-detached
-    ] curry ;
-
-M: process wait-for-pipeline-element wait-for-process ;
 
 : <process-reader*> ( process encoding -- process stream )
     [

extra/io/pipes/pipes.factor

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

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 [

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
+    [let | path [ path normalize-path ] |
-    dup [ enqueue-notifications ] curry
+        path mailbox macosx-monitor new-monitor
-    path 1array 0 0 <event-stream> >>handle ;
+        dup [ enqueue-notifications ] curry
+        path 1array 0 0 <event-stream> >>handle
+    ] ;
 
 M: macosx-monitor dispose
     handle>> dispose ;

extra/io/unix/pipes/pipes-tests.factor

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

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

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" }
+}

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
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ;
-jamshred.player math.vectors ;
 IN: jamshred.game
 
-TUPLE: jamshred tunnel players running ;
+TUPLE: jamshred sounds tunnel players running quit ;
 
 : <jamshred> ( -- jamshred )
-    <random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
+    <sounds> <random-tunnel> "Player 1" pick <player>
-    jamshred boa ;
+    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 ;
+

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
+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 ;
-math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
-math.vectors ;
 IN: jamshred
 
 TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
 
 : <jamshred-gadget> ( jamshred -- gadget )
-    jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
+    jamshred-gadget construct-gadget swap >>jamshred ;
 
-: default-width ( -- x ) 1024 ;
+: default-width ( -- x ) 800 ;
-: default-height ( -- y ) 768 ;
+: 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 -- )
+: jamshred-loop ( gadget -- )
-    dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
+    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 -- )
-    [
+    [ jamshred-loop ] in-thread drop ;
-        [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
-    ] keep set-jamshred-gadget-alarm ;
 
 M: jamshred-gadget ungraft* ( gadget -- )
-    [ jamshred-gadget-alarm cancel-alarm f ] keep
+    jamshred>> t swap (>>quit) ;
-    set-jamshred-gadget-alarm ;
 
 : jamshred-restart ( jamshred-gadget -- )
-    <jamshred> swap set-jamshred-gadget-jamshred ;
+    <jamshred> >>jamshred drop ;
 
 : pix>radians ( n m -- theta )
     2 / / pi 2 * * ;
@@ -46,22 +56,31 @@ M: jamshred-gadget ungraft* ( gadget -- )
     rect-dim second pix>radians ;
 
 : (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
-    over jamshred-gadget-jamshred >r
+    over jamshred>> >r
     [ first swap x>radians ] 2keep second swap y>radians
     r> mouse-moved ;
     
 : handle-mouse-motion ( jamshred-gadget -- )
     hand-loc get [
-        over jamshred-gadget-last-hand-loc [
+        over last-hand-loc>> [
             v- (handle-mouse-motion) 
         ] [ 2drop ] if* 
-    ] 2keep swap set-jamshred-gadget-last-hand-loc ;
+    ] 2keep >>last-hand-loc drop ;
+
+: handle-mouse-scroll ( jamshred-gadget -- )
+    jamshred>> jamshred-player scroll-direction get
+    second neg swap change-player-speed ;
+
+: quit ( gadget -- )
+    [ no-fullscreen ] [ close-window ] bi ;
 
-USE: vocabs.loader
 jamshred-gadget H{
     { T{ key-down f f "r" } [ jamshred-restart ] }
-    { T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
+    { T{ key-down f f " " } [ jamshred>> toggle-running ] }
+    { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
+    { T{ key-down f f "q" } [ quit ] }
     { T{ motion } [ handle-mouse-motion ] }
+    { T{ mouse-scroll } [ handle-mouse-scroll ] }
 } set-gestures
 
 : jamshred-window ( -- )

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...

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

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 ;
-
+C: <oint> oint
-: <oint> ( location forward up left -- oint )
-    oint boa ;
-
-! : x-rotation ( theta -- matrix )
-!     #! construct this matrix:
-!     #! { { 1           0          0 }
-!     #!   { 0  cos(theta) sin(theta) }
-!     #!   { 0 -sin(theta) cos(theta) } }
-!     dup sin neg swap cos 2dup 0 -rot 3float-array >r
-!     swap neg 0 -rot 3float-array >r
-!     { 1 0 0 } r> r> 3float-array ;
-! 
-! : y-rotation ( theta -- matrix )
-!     #! costruct this matrix:
-!     #! { { cos(theta) 0 -sin(theta) }
-!     #!   {          0 1           0 }
-!     #!   { sin(theta) 0  cos(theta) } }
-!     dup sin swap cos 2dup
-!     0 swap 3float-array >r
-!     { 0 1 0 } >r
-!     0 rot neg 3float-array r> r> 3float-array ;
-
-: apply-to-oint ( oint quot -- )
-    #! apply quot to each of forward, up, and left, storing the results
-    over oint-forward over call pick set-oint-forward
-    over oint-up over call pick set-oint-up
-    over oint-left swap call swap set-oint-left ;
 
 : 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
+    rotation-quaternion dup qrecip pick
-    [ rot v>q swap q* q* q>v ] curry curry apply-to-oint ;
+    [ 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
+    tuck distance-vector swap 2dup left>> scalar-projection abs
-    -rot oint-up 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- ;

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
+USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
-math math.constants sequences ;
 IN: jamshred.player
 
-TUPLE: player name tunnel nearest-segment ;
+TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
 
-: <player> ( name -- player )
+! speeds are in GL units / second
-    f f player boa
+: default-speed ( -- speed ) 1.0 ;
-    F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
+: max-speed ( -- speed ) 30.0 ;
+
+: <player> ( name sounds -- player )
+    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
+    f f f default-speed player boa ;
 
 : turn-player ( player x-radians y-radians -- )
     >r over r> left-pivot up-pivot ;
 
 : to-tunnel-start ( player -- )
-    dup player-tunnel first dup oint-location pick set-oint-location
+    [ tunnel>> first dup location>> ]
-    swap set-player-nearest-segment ;
+    [ 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
+    [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
-    swap set-player-nearest-segment ;
+    [ (>>nearest-segment) ] tri ;
 
-: max-speed ( -- speed )
+: moved ( player -- ) millis swap (>>last-move) ;
-    0.3 ;
 
-: player-speed ( player -- speed )
+: speed-range ( -- range )
-    dup player-nearest-segment fraction-from-wall sq max-speed * ;
+    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 ;

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> ( -- 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 ;

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

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
+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 ;
-math.ranges math.vectors math.constants random sequences vectors ;
 IN: jamshred.tunnel
 
 : n-segments ( -- n ) 5000 ; inline
 
-TUPLE: segment number color radius ;
+TUPLE: segment < oint number color radius ;
-
+C: <segment> segment
-: <segment> ( number color radius location forward up left -- segment )
-    <oint> >r segment boa r> over set-delegate ;
 
 : segment-vertex ( theta segment -- vertex )
-     tuck 2dup oint-up swap sin v*n
+     tuck 2dup up>> swap sin v*n
-     >r oint-left swap cos v*n r> v+
+     >r left>> swap cos v*n r> v+
-     swap oint-location 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 } <segment> ;
+    0 random-color default-segment-radius <segment> ;
 
 : random-segments ( n -- segments )
     initial-segment 1vector swap (random-segments) ;
 
 : simple-segment ( n -- segment )
-    random-color default-segment-radius pick F{ 0 0 -1 } n*v
+    [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
-    F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
+    random-color default-segment-radius <segment> ;
 
 : simple-segments ( n -- segments )
     [ simple-segment ] map ;
@@ -100,14 +97,54 @@ TUPLE: segment number color radius ;
     [ nearest-segment-forward ] 3keep
     nearest-segment-backward r> nearer-segment ;
 
-: distance-from-centre ( oint segment -- distance )
+: vector-to-centre ( seg loc -- v )
-    perpendicular-distance ;
+    over location>> swap v- swap forward>> proj-perp ;
 
-: distance-from-wall ( oint segment -- distance )
+: distance-from-centre ( seg loc -- distance )
-    tuck distance-from-centre swap segment-radius swap - ;
+    vector-to-centre norm ;
 
-: fraction-from-centre ( oint segment -- fraction )
+: wall-normal ( seg oint -- n )
-    tuck distance-from-centre swap segment-radius / ;
+    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 ;
+

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 )

extra/lcs/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

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"

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

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

extra/lcs/summary.txt

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

extra/lcs/tags.txt

@@ -0,0 +1 @@
+algorithms

extra/levenshtein/authors.txt

@@ -1 +0,0 @@
-Slava Pestov

extra/levenshtein/levenshtein-tests.factor

@@ -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

extra/levenshtein/levenshtein.factor

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

extra/levenshtein/summary.txt

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

extra/locals/locals-docs.factor

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