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

basis/compiler/tree/debugger/debugger.factor

@@ -151,14 +151,14 @@ SYMBOL: node-count
         H{ } clone intrinsics-called set
 
         0 swap [
-            >r 1+ r>
+            [ 1+ ] dip
             dup #call? [
                 word>> {
                     { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
                     { [ dup generic? ] [ generics-called ] }
                     { [ dup method-body? ] [ methods-called ] }
                     [ words-called ]
-                } cond 1 -rot get at+
+                } cond inc-at
             ] [ drop ] if
         ] each-node
         node-count set

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -152,7 +152,7 @@ DEFER: (flat-length)
 SYMBOL: history
 
 : remember-inlining ( word -- )
-    [ [ 1 ] dip inlining-count get at+ ]
+    [ inlining-count get inc-at ]
     [ history [ swap suffix ] change ]
     bi ;
 

basis/cpu/x86/32/bootstrap.factor

@@ -10,19 +10,19 @@ IN: bootstrap.x86
 : shift-arg ( -- reg ) ECX ;
 : div-arg ( -- reg ) EAX ;
 : mod-arg ( -- reg ) EDX ;
-: arg0 ( -- reg ) EAX ;
+: temp0 ( -- reg ) EAX ;
-: arg1 ( -- reg ) EDX ;
+: temp1 ( -- reg ) EDX ;
-: arg2 ( -- reg ) ECX ;
+: temp2 ( -- reg ) ECX ;
-: temp-reg ( -- reg ) EBX ;
+: temp3 ( -- reg ) EBX ;
 : stack-reg ( -- reg ) ESP ;
 : ds-reg ( -- reg ) ESI ;
 : rs-reg ( -- reg ) EDI ;
-: fixnum>slot@ ( -- ) arg0 1 SAR ;
+: fixnum>slot@ ( -- ) temp0 1 SAR ;
 : rex-length ( -- n ) 0 ;
 
 [
-    arg0 0 [] MOV                              ! load stack_chain
+    temp0 0 [] MOV                              ! load stack_chain
-    arg0 [] stack-reg MOV                      ! save stack pointer
+    temp0 [] stack-reg MOV                      ! save stack pointer
 ] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
 
 [

basis/cpu/x86/64/bootstrap.factor

@@ -9,7 +9,10 @@ IN: bootstrap.x86
 : shift-arg ( -- reg ) RCX ;
 : div-arg ( -- reg ) RAX ;
 : mod-arg ( -- reg ) RDX ;
-: temp-reg ( -- reg ) RBX ;
+: temp0 ( -- reg ) RDI ;
+: temp1 ( -- reg ) RSI ;
+: temp2 ( -- reg ) RDX ;
+: temp3 ( -- reg ) RBX ;
 : stack-reg ( -- reg ) RSP ;
 : ds-reg ( -- reg ) R14 ;
 : rs-reg ( -- reg ) R15 ;
@@ -17,14 +20,14 @@ IN: bootstrap.x86
 : rex-length ( -- n ) 1 ;
 
 [
-    arg0 0 MOV                                 ! load stack_chain
+    temp0 0 MOV                                 ! load stack_chain
-    arg0 arg0 [] MOV
+    temp0 temp0 [] MOV
-    arg0 [] stack-reg MOV                      ! save stack pointer
+    temp0 [] stack-reg MOV                      ! save stack pointer
 ] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
 
 [
-    arg1 0 MOV                                 ! load XT
+    temp1 0 MOV                                 ! load XT
-    arg1 JMP                                   ! go
+    temp1 JMP                                   ! go
 ] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
 
 << "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>

basis/cpu/x86/64/unix/bootstrap.factor

@@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ;
 IN: bootstrap.x86
 
 : stack-frame-size ( -- n ) 4 bootstrap-cells ;
-: arg0 ( -- reg ) RDI ;
-: arg1 ( -- reg ) RSI ;
-: arg2 ( -- reg ) RDX ;
 
 << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
 call

basis/cpu/x86/64/winnt/bootstrap.factor

@@ -5,9 +5,6 @@ cpu.x86.assembler layouts vocabs parser ;
 IN: bootstrap.x86
 
 : stack-frame-size ( -- n ) 8 bootstrap-cells ;
-: arg0 ( -- reg ) RCX ;
-: arg1 ( -- reg ) RDX ;
-: arg2 ( -- reg ) R8 ;
 
 << "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
 call

basis/cpu/x86/bootstrap.factor

@@ -12,28 +12,35 @@ big-endian off
 
 [
     ! Load word
-    temp-reg 0 MOV
+    temp0 0 MOV
     ! Bump profiling counter
-    temp-reg profile-count-offset [+] 1 tag-fixnum ADD
+    temp0 profile-count-offset [+] 1 tag-fixnum ADD
     ! Load word->code
-    temp-reg temp-reg word-code-offset [+] MOV
+    temp0 temp0 word-code-offset [+] MOV
     ! Compute word XT
-    temp-reg compiled-header-size ADD
+    temp0 compiled-header-size ADD
     ! Jump to XT
-    temp-reg JMP
+    temp0 JMP
 ] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
 
 [
-    temp-reg 0 MOV                             ! load XT
+    ! load XT
-    stack-frame-size PUSH                      ! save stack frame size
+    temp0 0 MOV
-    temp-reg PUSH                              ! push XT
+    ! save stack frame size
-    stack-reg stack-frame-size 3 bootstrap-cells - SUB   ! alignment
+    stack-frame-size PUSH
+    ! push XT
+    temp0 PUSH
+    ! alignment
+    stack-reg stack-frame-size 3 bootstrap-cells - SUB
 ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
 
 [
-    arg0 0 MOV                                 ! load literal
+    ! load literal
-    ds-reg bootstrap-cell ADD                  ! increment datastack pointer
+    temp0 0 MOV
-    ds-reg [] arg0 MOV                         ! store literal on datastack
+    ! increment datastack pointer
+    ds-reg bootstrap-cell ADD
+    ! store literal on datastack
+    ds-reg [] temp0 MOV
 ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
 
 [
@@ -45,73 +52,85 @@ big-endian off
 ] rc-relative rt-xt 1 jit-word-call jit-define
 
 [
-    arg0 ds-reg [] MOV                         ! load boolean
+    ! load boolean
-    ds-reg bootstrap-cell SUB                  ! pop boolean
+    temp0 ds-reg [] MOV
-    arg0 \ f tag-number CMP                    ! compare boolean with f
+    ! pop boolean
-    f JNE                                      ! jump to true branch if not equal
+    ds-reg bootstrap-cell SUB
+    ! compare boolean with f
+    temp0 \ f tag-number CMP
+    ! jump to true branch if not equal
+    f JNE
 ] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
 
 [
-    f JMP                                      ! jump to false branch if equal
+    ! jump to false branch if equal
+    f JMP
 ] rc-relative rt-xt 1 jit-if-2 jit-define
 
 [
-    arg1 0 MOV                                 ! load dispatch table
+    ! load dispatch table
-    arg0 ds-reg [] MOV                         ! load index
+    temp1 0 MOV
-    fixnum>slot@                               ! turn it into an array offset
+    ! load index
-    ds-reg bootstrap-cell SUB                  ! pop index
+    temp0 ds-reg [] MOV
-    arg0 arg1 ADD                              ! compute quotation location
+    ! turn it into an array offset
-    arg0 arg0 array-start-offset [+] MOV       ! load quotation
+    fixnum>slot@
-    arg0 quot-xt-offset [+] JMP                ! execute branch
+    ! pop index
+    ds-reg bootstrap-cell SUB
+    ! compute quotation location
+    temp0 temp1 ADD
+    ! load quotation
+    temp0 temp0 array-start-offset [+] MOV
+    ! execute branch
+    temp0 quot-xt-offset [+] JMP
 ] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
 
 : jit->r ( -- )
     rs-reg bootstrap-cell ADD
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
     ds-reg bootstrap-cell SUB
-    rs-reg [] arg0 MOV ;
+    rs-reg [] temp0 MOV ;
 
 : jit-2>r ( -- )
     rs-reg 2 bootstrap-cells ADD
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
     ds-reg 2 bootstrap-cells SUB
-    rs-reg [] arg0 MOV
+    rs-reg [] temp0 MOV
-    rs-reg -1 bootstrap-cells [+] arg1 MOV ;
+    rs-reg -1 bootstrap-cells [+] temp1 MOV ;
 
 : jit-3>r ( -- )
     rs-reg 3 bootstrap-cells ADD
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    arg2 ds-reg -2 bootstrap-cells [+] MOV
+    temp2 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg 3 bootstrap-cells SUB
-    rs-reg [] arg0 MOV
+    rs-reg [] temp0 MOV
-    rs-reg -1 bootstrap-cells [+] arg1 MOV
+    rs-reg -1 bootstrap-cells [+] temp1 MOV
-    rs-reg -2 bootstrap-cells [+] arg2 MOV ;
+    rs-reg -2 bootstrap-cells [+] temp2 MOV ;
 
 : jit-r> ( -- )
     ds-reg bootstrap-cell ADD
-    arg0 rs-reg [] MOV
+    temp0 rs-reg [] MOV
     rs-reg bootstrap-cell SUB
-    ds-reg [] arg0 MOV ;
+    ds-reg [] temp0 MOV ;
 
 : jit-2r> ( -- )
     ds-reg 2 bootstrap-cells ADD
-    arg0 rs-reg [] MOV
+    temp0 rs-reg [] MOV
-    arg1 rs-reg -1 bootstrap-cells [+] MOV
+    temp1 rs-reg -1 bootstrap-cells [+] MOV
     rs-reg 2 bootstrap-cells SUB
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV ;
+    ds-reg -1 bootstrap-cells [+] temp1 MOV ;
 
 : jit-3r> ( -- )
     ds-reg 3 bootstrap-cells ADD
-    arg0 rs-reg [] MOV
+    temp0 rs-reg [] MOV
-    arg1 rs-reg -1 bootstrap-cells [+] MOV
+    temp1 rs-reg -1 bootstrap-cells [+] MOV
-    arg2 rs-reg -2 bootstrap-cells [+] MOV
+    temp2 rs-reg -2 bootstrap-cells [+] MOV
     rs-reg 3 bootstrap-cells SUB
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV
+    ds-reg -1 bootstrap-cells [+] temp1 MOV
-    ds-reg -2 bootstrap-cells [+] arg2 MOV ;
+    ds-reg -2 bootstrap-cells [+] temp2 MOV ;
 
 [
     jit->r
@@ -132,7 +151,8 @@ big-endian off
 ] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
 
 [
-    stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
+    ! unwind stack frame
+    stack-reg stack-frame-size bootstrap-cell - ADD
 ] f f f jit-epilog jit-define
 
 [ 0 RET ] f f f jit-return jit-define
@@ -141,34 +161,51 @@ big-endian off
 
 ! Quotations and words
 [
-    arg0 ds-reg [] MOV                         ! load from stack
+    ! load from stack
-    ds-reg bootstrap-cell SUB                  ! pop stack
+    temp0 ds-reg [] MOV
-    arg0 quot-xt-offset [+] JMP                ! call quotation
+    ! pop stack
+    ds-reg bootstrap-cell SUB
+    ! call quotation
+    temp0 quot-xt-offset [+] JMP
 ] f f f \ (call) define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load from stack
+    ! load from stack
-    ds-reg bootstrap-cell SUB                  ! pop stack
+    temp0 ds-reg [] MOV
-    arg0 word-xt-offset [+] JMP                ! execute word
+    ! pop stack
+    ds-reg bootstrap-cell SUB
+    ! execute word
+    temp0 word-xt-offset [+] JMP
 ] f f f \ (execute) define-sub-primitive
 
 ! Objects
 [
-    arg1 ds-reg [] MOV                         ! load from stack
+    ! load from stack
-    arg1 tag-mask get AND                      ! compute tag
+    temp0 ds-reg [] MOV
-    arg1 tag-bits get SHL                      ! tag the tag
+    ! compute tag
-    ds-reg [] arg1 MOV                         ! push to stack
+    temp0 tag-mask get AND
+    ! tag the tag
+    temp0 tag-bits get SHL
+    ! push to stack
+    ds-reg [] temp0 MOV
 ] f f f \ tag define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load slot number
+    ! load slot number
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    temp0 ds-reg [] MOV
-    arg1 ds-reg [] MOV                         ! load object
+    ! adjust stack pointer
-    fixnum>slot@                               ! turn slot number into offset
+    ds-reg bootstrap-cell SUB
-    arg1 tag-bits get SHR                      ! mask off tag
+    ! load object
-    arg1 tag-bits get SHL
+    temp1 ds-reg [] MOV
-    arg0 arg1 arg0 [+] MOV                     ! load slot value
+    ! turn slot number into offset
-    ds-reg [] arg0 MOV                         ! push to stack
+    fixnum>slot@
+    ! mask off tag
+    temp1 tag-bits get SHR
+    temp1 tag-bits get SHL
+    ! load slot value
+    temp0 temp1 temp0 [+] MOV
+    ! push to stack
+    ds-reg [] temp0 MOV
 ] f f f \ slot define-sub-primitive
 
 ! Shufflers
@@ -185,100 +222,100 @@ big-endian off
 ] f f f \ 3drop define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ dup define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg bootstrap-cell neg [+] MOV
+    temp1 ds-reg bootstrap-cell neg [+] MOV
     ds-reg 2 bootstrap-cells ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg bootstrap-cell neg [+] arg1 MOV
+    ds-reg bootstrap-cell neg [+] temp1 MOV
 ] f f f \ 2dup define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    temp-reg ds-reg -2 bootstrap-cells [+] MOV
+    temp3 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg 3 bootstrap-cells ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV
+    ds-reg -1 bootstrap-cells [+] temp1 MOV
-    ds-reg -2 bootstrap-cells [+] temp-reg MOV
+    ds-reg -2 bootstrap-cells [+] temp3 MOV
 ] f f f \ 3dup define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
     ds-reg bootstrap-cell SUB
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ nip define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
     ds-reg 2 bootstrap-cells SUB
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ 2nip define-sub-primitive
 
 [
-    arg0 ds-reg -1 bootstrap-cells [+] MOV
+    temp0 ds-reg -1 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ over define-sub-primitive
 
 [
-    arg0 ds-reg -2 bootstrap-cells [+] MOV
+    temp0 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ pick define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    ds-reg [] arg1 MOV
+    ds-reg [] temp1 MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ dupd define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
     ds-reg bootstrap-cell ADD
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV
+    ds-reg -1 bootstrap-cells [+] temp1 MOV
-    ds-reg -2 bootstrap-cells [+] arg0 MOV
+    ds-reg -2 bootstrap-cells [+] temp0 MOV
 ] f f f \ tuck define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg bootstrap-cell neg [+] MOV
+    temp1 ds-reg bootstrap-cell neg [+] MOV
-    ds-reg bootstrap-cell neg [+] arg0 MOV
+    ds-reg bootstrap-cell neg [+] temp0 MOV
-    ds-reg [] arg1 MOV
+    ds-reg [] temp1 MOV
 ] f f f \ swap define-sub-primitive
 
 [
-    arg0 ds-reg -1 bootstrap-cells [+] MOV
+    temp0 ds-reg -1 bootstrap-cells [+] MOV
-    arg1 ds-reg -2 bootstrap-cells [+] MOV
+    temp1 ds-reg -2 bootstrap-cells [+] MOV
-    ds-reg -2 bootstrap-cells [+] arg0 MOV
+    ds-reg -2 bootstrap-cells [+] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] arg1 MOV
+    ds-reg -1 bootstrap-cells [+] temp1 MOV
 ] f f f \ swapd define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    temp-reg ds-reg -2 bootstrap-cells [+] MOV
+    temp3 ds-reg -2 bootstrap-cells [+] MOV
-    ds-reg -2 bootstrap-cells [+] arg1 MOV
+    ds-reg -2 bootstrap-cells [+] temp1 MOV
-    ds-reg -1 bootstrap-cells [+] arg0 MOV
+    ds-reg -1 bootstrap-cells [+] temp0 MOV
-    ds-reg [] temp-reg MOV
+    ds-reg [] temp3 MOV
 ] f f f \ rot define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
-    arg1 ds-reg -1 bootstrap-cells [+] MOV
+    temp1 ds-reg -1 bootstrap-cells [+] MOV
-    temp-reg ds-reg -2 bootstrap-cells [+] MOV
+    temp3 ds-reg -2 bootstrap-cells [+] MOV
-    ds-reg -2 bootstrap-cells [+] arg0 MOV
+    ds-reg -2 bootstrap-cells [+] temp0 MOV
-    ds-reg -1 bootstrap-cells [+] temp-reg MOV
+    ds-reg -1 bootstrap-cells [+] temp3 MOV
-    ds-reg [] arg1 MOV
+    ds-reg [] temp1 MOV
 ] f f f \ -rot define-sub-primitive
 
 [ jit->r ] f f f \ >r define-sub-primitive
@@ -287,14 +324,20 @@ big-endian off
 
 ! Comparisons
 : jit-compare ( insn -- )
-    temp-reg 0 MOV                             ! load t
+    ! load t
-    arg1 \ f tag-number MOV                    ! load f
+    temp3 0 MOV
-    arg0 ds-reg [] MOV                         ! load first value
+    ! load f
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    temp1 \ f tag-number MOV
-    ds-reg [] arg0 CMP                         ! compare with second value
+    ! load first value
-    [ arg1 temp-reg ] dip execute              ! move t if true
+    temp0 ds-reg [] MOV
-    ds-reg [] arg1 MOV                         ! store
+    ! adjust stack pointer
-    ;
+    ds-reg bootstrap-cell SUB
+    ! compare with second value
+    ds-reg [] temp0 CMP
+    ! move t if true
+    [ temp1 temp3 ] dip execute
+    ! store
+    ds-reg [] temp1 MOV ;
 
 : define-jit-compare ( insn word -- )
     [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
@@ -308,22 +351,30 @@ big-endian off
 
 ! Math
 : jit-math ( insn -- )
-    arg0 ds-reg [] MOV                         ! load second input
+    ! load second input
-    ds-reg bootstrap-cell SUB                  ! pop stack
+    temp0 ds-reg [] MOV
-    [ ds-reg [] arg0 ] dip execute             ! compute result
+    ! pop stack
-    ;
+    ds-reg bootstrap-cell SUB
+    ! compute result
+    [ ds-reg [] temp0 ] dip execute ;
 
 [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
 
 [ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load second input
+    ! load second input
-    ds-reg bootstrap-cell SUB                  ! pop stack
+    temp0 ds-reg [] MOV
-    arg1 ds-reg [] MOV                         ! load first input
+    ! pop stack
-    arg0 tag-bits get SAR                      ! untag second input
+    ds-reg bootstrap-cell SUB
-    arg0 arg1 IMUL2                            ! multiply
+    ! load first input
-    ds-reg [] arg1 MOV                         ! push result
+    temp1 ds-reg [] MOV
+    ! untag second input
+    temp0 tag-bits get SAR
+    ! multiply
+    temp0 temp1 IMUL2
+    ! push result
+    ds-reg [] temp1 MOV
 ] f f f \ fixnum*fast define-sub-primitive
 
 [ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
@@ -333,75 +384,106 @@ big-endian off
 [ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
 
 [
-    ds-reg [] NOT                              ! complement
+    ! complement
-    ds-reg [] tag-mask get XOR                 ! clear tag bits
+    ds-reg [] NOT
+    ! clear tag bits
+    ds-reg [] tag-mask get XOR
 ] f f f \ fixnum-bitnot define-sub-primitive
 
 [
-    shift-arg ds-reg [] MOV                    ! load shift count
+    ! load shift count
-    shift-arg tag-bits get SAR                 ! untag shift count
+    shift-arg ds-reg [] MOV
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    ! untag shift count
-    temp-reg ds-reg [] MOV                     ! load value
+    shift-arg tag-bits get SAR
-    arg1 temp-reg MOV                          ! make a copy
+    ! adjust stack pointer
-    arg1 CL SHL                                ! compute positive shift value in arg1
+    ds-reg bootstrap-cell SUB
-    shift-arg NEG                              ! compute negative shift value in arg0
+    ! load value
-    temp-reg CL SAR
+    temp3 ds-reg [] MOV
-    temp-reg tag-mask get bitnot AND
+    ! make a copy
-    shift-arg 0 CMP                            ! if shift count was negative, move arg0 to arg1
+    temp1 temp3 MOV
-    arg1 temp-reg CMOVGE
+    ! compute positive shift value in temp1
-    ds-reg [] arg1 MOV                         ! push to stack
+    temp1 CL SHL
+    shift-arg NEG
+    ! compute negative shift value in temp3
+    temp3 CL SAR
+    temp3 tag-mask get bitnot AND
+    shift-arg 0 CMP
+    ! if shift count was negative, move temp0 to temp1
+    temp1 temp3 CMOVGE
+    ! push to stack
+    ds-reg [] temp1 MOV
 ] f f f \ fixnum-shift-fast define-sub-primitive
 
 : jit-fixnum-/mod ( -- )
-    temp-reg ds-reg [] MOV                     ! load second parameter
+    ! load second parameter
-    div-arg ds-reg bootstrap-cell neg [+] MOV  ! load first parameter
+    temp3 ds-reg [] MOV
-    mod-arg div-arg MOV                        ! make a copy
+    ! load first parameter
-    mod-arg bootstrap-cell-bits 1- SAR         ! sign-extend
+    div-arg ds-reg bootstrap-cell neg [+] MOV
-    temp-reg IDIV ;                            ! divide
+    ! make a copy
+    mod-arg div-arg MOV
+    ! sign-extend
+    mod-arg bootstrap-cell-bits 1- SAR
+    ! divide
+    temp3 IDIV ;
 
 [
     jit-fixnum-/mod
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    ! adjust stack pointer
-    ds-reg [] mod-arg MOV                      ! push to stack
+    ds-reg bootstrap-cell SUB
+    ! push to stack
+    ds-reg [] mod-arg MOV
 ] f f f \ fixnum-mod define-sub-primitive
 
 [
     jit-fixnum-/mod
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    ! adjust stack pointer
-    div-arg tag-bits get SHL                   ! tag it
+    ds-reg bootstrap-cell SUB
-    ds-reg [] div-arg MOV                      ! push to stack
+    ! tag it
+    div-arg tag-bits get SHL
+    ! push to stack
+    ds-reg [] div-arg MOV
 ] f f f \ fixnum/i-fast define-sub-primitive
 
 [
     jit-fixnum-/mod
-    div-arg tag-bits get SHL                   ! tag it
+    ! tag it
-    ds-reg [] mod-arg MOV                      ! push to stack
+    div-arg tag-bits get SHL
+    ! push to stack
+    ds-reg [] mod-arg MOV
     ds-reg bootstrap-cell neg [+] div-arg MOV
 ] f f f \ fixnum/mod-fast define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV
+    temp0 ds-reg [] MOV
     ds-reg bootstrap-cell SUB
-    arg0 ds-reg [] OR
+    temp0 ds-reg [] OR
-    arg0 tag-mask get AND
+    temp0 tag-mask get AND
-    arg0 \ f tag-number MOV
+    temp0 \ f tag-number MOV
-    arg1 1 tag-fixnum MOV
+    temp1 1 tag-fixnum MOV
-    arg0 arg1 CMOVE
+    temp0 temp1 CMOVE
-    ds-reg [] arg0 MOV
+    ds-reg [] temp0 MOV
 ] f f f \ both-fixnums? define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load local number
+    ! load local number
-    fixnum>slot@                               ! turn local number into offset
+    temp0 ds-reg [] MOV
-    arg0 rs-reg arg0 [+] MOV                   ! load local value
+    ! turn local number into offset
-    ds-reg [] arg0 MOV                         ! push to stack
+    fixnum>slot@
+    ! load local value
+    temp0 rs-reg temp0 [+] MOV
+    ! push to stack
+    ds-reg [] temp0 MOV
 ] f f f \ get-local define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load local count
+    ! load local count
-    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    temp0 ds-reg [] MOV
-    fixnum>slot@                               ! turn local number into offset
+    ! adjust stack pointer
-    rs-reg arg0 SUB                            ! decrement retain stack pointer
+    ds-reg bootstrap-cell SUB
+    ! turn local number into offset
+    fixnum>slot@
+    ! decrement retain stack pointer
+    rs-reg temp0 SUB
 ] f f f \ drop-locals define-sub-primitive
 
 [ "bootstrap.x86" forget-vocab ] with-compilation-unit

basis/db/db-docs.factor

@@ -229,7 +229,7 @@ ARTICLE: "db-protocol" "Low-level database protocol"
 { $subsection db-open }
 "Closing a database:"
 { $subsection db-close }
-"Creating tatements:"
+"Creating statements:"
 { $subsection <simple-statement> }
 { $subsection <prepared-statement> }
 "Using statements with the database:"

basis/io/unix/backend/backend.factor

@@ -64,10 +64,10 @@ M: mx remove-output-callbacks writes>> delete-at* drop ;
 GENERIC: wait-for-events ( ms mx -- )
 
 : input-available ( fd mx -- )
-    remove-input-callbacks [ resume ] each ;
+    reads>> delete-at* drop [ resume ] each ;
 
 : output-available ( fd mx -- )
-    remove-output-callbacks [ resume ] each ;
+    writes>> delete-at* drop [ resume ] each ;
 
 M: fd cancel-operation ( fd -- )
     dup disposed>> [ drop ] [

basis/io/unix/kqueue/kqueue.factor

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types combinators io.unix.backend
 kernel math.bitwise sequences struct-arrays unix unix.kqueue
-unix.time ;
+unix.time assocs ;
 IN: io.unix.kqueue
 
-TUPLE: kqueue-mx < mx events monitors ;
+TUPLE: kqueue-mx < mx events ;
 
 : max-events ( -- n )
     #! We read up to 256 events at a time. This is an arbitrary
@@ -14,7 +14,6 @@ TUPLE: kqueue-mx < mx events monitors ;
 
 : <kqueue-mx> ( -- mx )
     kqueue-mx new-mx
-        H{ } clone >>monitors
         kqueue dup io-error >>fd
         max-events "kevent" <struct-array> >>events ;
 
@@ -35,30 +34,25 @@ M: kqueue-mx add-input-callback ( thread fd mx -- )
 
 M: kqueue-mx add-output-callback ( thread fd mx -- )
     [ call-next-method ] [
-        [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+        [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
         register-kevent
     ] 2bi ;
 
-: cancel-input-callbacks ( fd mx -- seq )
+M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
-    [
+    2dup reads>> key? [
+        [ call-next-method ] [
             [ EVFILT_READ EV_DELETE make-kevent ] dip
             register-kevent
-    ] [ remove-input-callbacks ] 2bi ;
+        ] 2bi
+    ] [ 2drop f ] if ;
 
-: cancel-output-callbacks ( fd mx -- seq )
+M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
+    2dup writes>> key? [
         [
             [ EVFILT_WRITE EV_DELETE make-kevent ] dip
             register-kevent
-    ] [ remove-output-callbacks ] 2bi ;
+        ] [ call-next-method ] 2bi
-
+    ] [ 2drop f ] if ;
-M: fd cancel-operation ( fd -- )
-    dup disposed>> [ drop ] [
-        fd>>
-        mx get-global
-        [ cancel-input-callbacks [ t swap resume-with ] each ]
-        [ cancel-output-callbacks [ t swap resume-with ] each ]
-        2bi
-    ] if ;
 
 : wait-kevent ( mx timespec -- n )
     [

basis/io/unix/macosx/macosx.factor

@@ -1,6 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.unix.macosx
-USING: io.unix.bsd io.backend system ;
+USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend
+namespaces system ;
+
+M: macosx init-io ( -- )
+    <kqueue-mx> mx set-global ;
 
 macosx set-io-backend

basis/locals/locals-docs.factor

@@ -67,6 +67,8 @@ HELP: :>
 { $syntax ":> binding" }
 { $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." }
 { $notes
+    "This word can only be used inside a lambda word, lambda quotation or let binding form."
+    $nl
     "Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "."
     $nl
     "Lambdas desugar as follows:"

basis/logging/analysis/analysis.factor

@@ -13,10 +13,10 @@ SYMBOL: message-histogram
 
 : analyze-entry ( entry -- )
     dup level>> { ERROR CRITICAL } memq? [ dup errors get push ] when
-    1 over word-name>> word-histogram get at+
+    dup word-name>> word-histogram get inc-at
     dup word-name>> word-names get member? [
-        1 over [ level>> ] [ word-name>> ] [ message>> ] tri 3array
+        dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array
-        message-histogram get at+
+        message-histogram get inc-at
     ] when
     drop ;
 

basis/tools/memory/memory.factor

@@ -53,7 +53,7 @@ IN: tools.memory
 
 : heap-stat-step ( obj counts sizes -- )
     [ over ] dip
-    [ [ [ drop 1 ] [ class ] bi ] dip at+ ]
+    [ [ class ] dip inc-at ]
     [ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ;
 
 PRIVATE>

basis/unix/kqueue/kqueue.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system sequences vocabs.loader words ;
+USING: alien.syntax system sequences vocabs.loader words
+accessors ;
 IN: unix.kqueue
 
 << "unix.kqueue." os name>> append require >>

core/assocs/assocs-docs.factor

@@ -90,6 +90,7 @@ ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
 { $subsection rename-at }
 { $subsection change-at }
 { $subsection at+ }
+{ $subsection inc-at }
 { $see-also set-at delete-at clear-assoc push-at } ;
 
 ARTICLE: "assocs-conversions" "Associative mapping conversions"
@@ -214,7 +215,7 @@ HELP: assoc-map
 { $examples
     { $unchecked-example
         ": discount ( prices n -- newprices )"
-        "    [ - ] curry assoc-each ;"
+        "    [ - ] curry assoc-map ;"
         "H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }"
         "2 discount ."
         "H{ { \"bananas\" 3 } { \"apples\" 39 } { \"pears\" 15 } }"
@@ -349,6 +350,11 @@ HELP: at+
 { $description "Adds " { $snippet "n" } " to the value associated with " { $snippet "key" } "; if there is no value, stores " { $snippet "n" } ", thus behaving as if the value was 0." }
 { $side-effects "assoc" } ;
 
+HELP: inc-at
+{ $values { "key" object } { "assoc" assoc } }
+{ $description "Adds 1 to the value associated with " { $snippet "key" } "; if there is no value, stores 1." }
+{ $side-effects "assoc" } ;
+
 HELP: >alist
 { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } }
 { $contract "Converts an associative structure into an association list." }

core/assocs/assocs.factor

@@ -141,8 +141,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : change-at ( key assoc quot -- )
     [ [ at ] dip call ] 3keep drop set-at ; inline
 
-: at+ ( n key assoc -- )
+: at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
-    [ 0 or + ] change-at ;
+
+: inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline
 
 : map>assoc ( seq quot exemplar -- assoc )
     [ [ 2array ] compose { } map-as ] dip assoc-like ; inline

core/classes/tuple/tuple-docs.factor

@@ -197,7 +197,7 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
 
 ARTICLE: "tuple-examples" "Tuple examples"
 "An example:"
-{ $code "TUPLE: employee name salary position ;" }
+{ $code "TUPLE: employee name position salary ;" }
 "This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
 { $table
     { "Reader" "Writer" "Setter" "Changer" }
@@ -237,7 +237,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
     "    checks counter check boa ;"
     ""
     ": biweekly-paycheck ( employee -- check )"
-    "    dup name>> swap salary>> 26 / <check> ;"
+    "    [ name>> ] [ salary>> 26 / ] bi <check> ;"
 }
 "An example of using a changer:"
 { $code

core/memory/memory-tests.factor

@@ -1,8 +1,16 @@
 USING: generic kernel kernel.private math memory prettyprint io
 sequences tools.test words namespaces layouts classes
-classes.builtin arrays quotations ;
+classes.builtin arrays quotations io.launcher system ;
 IN: memory.tests
 
+! LOL
+[ ] [
+    vm
+    "-generations=2"
+    "-e=USING: memory io prettyprint system ; input-stream gc . 0 exit"
+    3array try-process
+] unit-test
+
 [ [ ] instances ] must-infer
 
 ! Code GC wasn't kicking in when needed

extra/crypto/barrett/barrett-tests.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 DoDoug Coleman.
+! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: crypto.barrett kernel math namespaces tools.test ;
 IN: crypto.barrett.tests

extra/fuel/fuel.factor

@@ -1,50 +1,70 @@
 ! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: accessors arrays classes.tuple compiler.units continuations debugger
+USING: accessors arrays classes classes.tuple compiler.units
-definitions eval io io.files io.streams.string kernel listener listener.private
+combinators continuations debugger definitions eval help
-make math namespaces parser prettyprint quotations sequences strings
+io io.files io.streams.string kernel lexer listener listener.private
-vectors vocabs.loader ;
+make math namespaces parser prettyprint prettyprint.config
+quotations sequences strings source-files vectors vocabs.loader ;
 
 IN: fuel
 
-! <PRIVATE
+! Evaluation status:
 
-TUPLE: fuel-status in use ds? ;
+TUPLE: fuel-status in use ds? restarts ;
 
 SYMBOL: fuel-status-stack
 V{ } clone fuel-status-stack set-global
 
-: push-fuel-status ( -- )
-    in get use get clone display-stacks? get
-    fuel-status boa
-    fuel-status-stack get push ;
-
-: pop-fuel-status ( -- )
-    fuel-status-stack get empty? [
-        fuel-status-stack get pop
-        [ in>> in set ]
-        [ use>> clone use set ]
-        [ ds?>> display-stacks? swap [ on ] [ off ] if ] tri
-    ] unless ;
-
 SYMBOL: fuel-eval-result
 f clone fuel-eval-result set-global
 
 SYMBOL: fuel-eval-output
 f clone fuel-eval-result set-global
 
-! PRIVATE>
+SYMBOL: fuel-eval-res-flag
+t clone fuel-eval-res-flag set-global
+
+: fuel-eval-restartable? ( -- ? )
+    fuel-eval-res-flag get-global ; inline
+
+: fuel-eval-restartable ( -- )
+    t fuel-eval-res-flag set-global ; inline
+
+: fuel-eval-non-restartable ( -- )
+    f fuel-eval-res-flag set-global ; inline
+
+: push-fuel-status ( -- )
+    in get use get clone display-stacks? get restarts get-global clone
+    fuel-status boa
+    fuel-status-stack get push ;
+
+: pop-fuel-status ( -- )
+    fuel-status-stack get empty? [
+        fuel-status-stack get pop {
+            [ in>> in set ]
+            [ use>> clone use set ]
+            [ ds?>> display-stacks? swap [ on ] [ off ] if ]
+            [
+                restarts>> fuel-eval-restartable? [ drop ] [
+                    clone restarts set-global
+                ] if
+            ]
+        } cleave
+    ] unless ;
+
+
+! Lispy pretty printing
 
 GENERIC: fuel-pprint ( obj -- )
 
-M: object fuel-pprint pprint ;
+M: object fuel-pprint pprint ; inline
 
-M: f fuel-pprint drop "nil" write ;
+M: f fuel-pprint drop "nil" write ; inline
 
-M: integer fuel-pprint pprint ;
+M: integer fuel-pprint pprint ; inline
 
-M: string fuel-pprint pprint ;
+M: string fuel-pprint pprint ; inline
 
 M: sequence fuel-pprint
     dup empty? [ drop f fuel-pprint ] [
@@ -53,12 +73,30 @@ M: sequence fuel-pprint
         ")" write
     ] if ;
 
-M: tuple fuel-pprint tuple>array fuel-pprint ;
+M: tuple fuel-pprint tuple>array fuel-pprint ; inline
 
-M: continuation fuel-pprint drop "~continuation~" write ;
+M: continuation fuel-pprint drop ":continuation" write ; inline
+
+M: restart fuel-pprint name>> fuel-pprint ; inline
+
+SYMBOL: :restarts
+
+: fuel-restarts ( obj -- seq )
+    compute-restarts :restarts prefix ; inline
+
+M: condition fuel-pprint
+    [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
+
+M: source-file-error fuel-pprint
+    [ file>> ] [ error>> ] bi 2array source-file-error prefix
+    fuel-pprint ;
+
+M: source-file fuel-pprint path>> fuel-pprint ;
+
+! Evaluation vocabulary
 
 : fuel-eval-set-result ( obj -- )
-    clone fuel-eval-result set-global ;
+    clone fuel-eval-result set-global ; inline
 
 : fuel-retort ( -- )
     error get
@@ -66,33 +104,34 @@ M: continuation fuel-pprint drop "~continuation~" write ;
     fuel-eval-output get-global
     3array fuel-pprint ;
 
-: fuel-forget-error ( -- )
+: fuel-forget-error ( -- ) f error set-global ; inline
-    f error set-global ;
+: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
+: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
 
 : (fuel-begin-eval) ( -- )
     push-fuel-status
     display-stacks? off
     fuel-forget-error
-    f fuel-eval-result set-global
+    fuel-forget-result
-    f fuel-eval-output set-global ;
+    fuel-forget-output ;
 
 : (fuel-end-eval) ( quot -- )
     with-string-writer fuel-eval-output set-global
-    fuel-retort
+    fuel-retort pop-fuel-status ; inline
-    pop-fuel-status ;
 
 : (fuel-eval) ( lines -- )
-    [ [ parse-lines ] with-compilation-unit call ] curry [ drop ] recover ;
+    [ [ parse-lines ] with-compilation-unit call ] curry
+    [ print-error ] recover ; inline
 
 : (fuel-eval-each) ( lines -- )
-    [ 1vector (fuel-eval) ] each ;
+    [ 1vector (fuel-eval) ] each ; inline
 
 : (fuel-eval-usings) ( usings -- )
     [ "USING: " prepend " ;" append ] map
-    (fuel-eval-each) fuel-forget-error ;
+    (fuel-eval-each) fuel-forget-error fuel-forget-output ;
 
 : (fuel-eval-in) ( in -- )
-    [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ;
+    [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
 
 : fuel-eval-in-context ( lines in usings -- )
     (fuel-begin-eval) [
@@ -107,15 +146,15 @@ M: continuation fuel-pprint drop "~continuation~" write ;
     fuel-retort ;
 
 : fuel-eval ( lines -- )
-    (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ;
+    (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline
 
-: fuel-end-eval ( -- )
+: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
-    [ ] (fuel-end-eval) ;
 
 : fuel-get-edit-location ( defspec -- )
     where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ;
 
-: fuel-startup ( -- )
+: fuel-run-file ( path -- ) run-file ; inline
-    "listener" run ;
+
+: fuel-startup ( -- ) "listener" run ; inline
 
 MAIN: fuel-startup

extra/math/binpack/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

extra/math/binpack/binpack-docs.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.syntax help.markup kernel assocs sequences quotations ;
+
+IN: math.binpack 
+
+HELP: binpack
+{ $values { "assoc" assoc } { "n" "number of bins" } { "bins" "packed bins" } }
+{ $description "Packs the (key, value) pairs into the specified number of bins, using the value as a weight." } ;
+
+HELP: binpack*
+{ $values { "items" sequence } { "n" "number of bins" } { "bins" "packed bins" } } 
+{ $description "Packs a sequence of numbers into the specified number of bins." } ;
+
+HELP: binpack!
+{ $values { "items" sequence } { "quot" quotation } { "n" "number of bins" } { "bins" "packed bins" } } 
+{ $description "Packs a sequence of items into the specified number of bins, using the quotatino to determine the weight." } ;
+

extra/math/binpack/binpack-tests.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel tools.test math.binpack ;
+
+[ t ] [ { V{ } } { } 1 binpack = ] unit-test
+
+[ t ] [ { { 3 } { 2 1 } } { 1 2 3 } 2 binpack* = ] unit-test
+
+[ t ] [ { { 1000 } { 100 60 30 7 } { 70 60 40 23 3 } } 
+        { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack* = ] unit-test
+
+

extra/math/binpack/binpack.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: sequences kernel arrays vectors accessors assocs sorting math math.functions ;
+
+IN: math.binpack 
+
+: (binpack) ( bins item -- )
+    [ [ values sum ] map ] keep
+    zip sort-keys values first push ;
+
+: binpack ( assoc n -- bins )
+    [ sort-values <reversed> dup length ] dip
+    tuck / ceiling <array> [ <vector> ] map
+    tuck [ (binpack) ] curry each ;
+
+: binpack* ( items n -- bins )
+    [ dup zip ] dip binpack [ keys ] map ;
+
+: binpack! ( items quot n -- bins ) 
+    [ dupd map zip ] dip binpack [ keys ] map ;
+

extra/math/binpack/summary.txt

@@ -0,0 +1 @@
+Bin-packing algorithms.

extra/time/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

extra/time/time-docs.factor

@@ -0,0 +1,43 @@
+
+USING: help.syntax help.markup kernel prettyprint sequences strings ;
+
+IN: time
+
+HELP: strftime
+{ $values { "format-string" string } }
+{ $description "Writes the timestamp (specified on the stack) formatted according to the format string." } 
+;
+
+ARTICLE: "strftime" "Formatted timestamps"
+"The " { $vocab-link "time" } " vocabulary is used for formatted timestamps.\n"
+{ $subsection strftime }
+"\n"
+"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n"
+{ $table
+    { "%a"     "Abbreviated weekday name." }
+    { "%A"     "Full weekday name." }
+    { "%b"     "Abbreviated month name." }
+    { "%B"     "Full month name." }
+    { "%c"     "Date and time representation." }
+    { "%d"     "Day of the month as a decimal number [01,31]." }
+    { "%H"     "Hour (24-hour clock) as a decimal number [00,23]." }
+    { "%I"     "Hour (12-hour clock) as a decimal number [01,12]." }
+    { "%j"     "Day of the year as a decimal number [001,366]." }
+    { "%m"     "Month as a decimal number [01,12]." }
+    { "%M"     "Minute as a decimal number [00,59]." }
+    { "%p"     "Either AM or PM." }
+    { "%S"     "Second as a decimal number [00,59]." }
+    { "%U"     "Week number of the year (Sunday as the first day of the week) as a decimal number [00,53]." }
+    { "%w"     "Weekday as a decimal number [0(Sunday),6]." }
+    { "%W"     "Week number of the year (Monday as the first day of the week) as a decimal number [00,53]." }
+    { "%x"     "Date representation." }
+    { "%X"     "Time representation." }
+    { "%y"     "Year without century as a decimal number [00,99]." }
+    { "%Y"     "Year with century as a decimal number." }
+    { "%Z"     "Time zone name (no characters if no time zone exists)." }
+    { "%%"     "A literal '%' character." }
+} ;
+
+ABOUT: "strftime"
+
+

extra/time/time-tests.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel time tools.test calendar ;
+
+IN: time.tests
+
+[ "%H:%M:%S" strftime ] must-infer 
+
+: testtime ( -- timestamp )
+    2008 10 9 12 3 15 instant <timestamp> ;
+
+[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
+[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
+
+[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
+[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
+
+[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
+[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
+
+[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
+[ t ] [ "October" testtime "%B" strftime = ] unit-test
+

extra/time/time.factor

@@ -0,0 +1,72 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays calendar io kernel fry macros math
+math.functions math.parser peg.ebnf sequences strings vectors ;
+
+IN: time
+
+: >timestring ( timestamp -- string ) 
+    [ hour>> ] keep [ minute>> ] keep second>> 3array
+    [ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline
+
+: >datestring ( timestamp -- string )
+    [ month>> ] keep [ day>> ] keep year>> 3array
+    [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline
+
+: (week-of-year) ( timestamp day -- n )
+    [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
+    [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
+
+: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
+
+: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline
+
+
+<PRIVATE
+
+EBNF: parse-format-string
+
+fmt-%     = "%"                  => [[ [ "%" ] ]]
+fmt-a     = "a"                  => [[ [ dup day-of-week day-abbreviation3 ] ]]
+fmt-A     = "A"                  => [[ [ dup day-of-week day-name ] ]] 
+fmt-b     = "b"                  => [[ [ dup month>> month-abbreviation ] ]]
+fmt-B     = "B"                  => [[ [ dup month>> month-name ] ]] 
+fmt-c     = "c"                  => [[ [ "Not yet implemented" throw ] ]]
+fmt-d     = "d"                  => [[ [ dup day>> number>string 2 CHAR: 0 pad-left ] ]] 
+fmt-H     = "H"                  => [[ [ dup hour>> number>string 2 CHAR: 0 pad-left ] ]]
+fmt-I     = "I"                  => [[ [ dup hour>> 12 > [ 12 - ] when number>string 2 CHAR: 0 pad-left ] ]] 
+fmt-j     = "j"                  => [[ [ dup day-of-year number>string ] ]] 
+fmt-m     = "m"                  => [[ [ dup month>> number>string 2 CHAR: 0 pad-left ] ]] 
+fmt-M     = "M"                  => [[ [ dup minute>> number>string 2 CHAR: 0 pad-left ] ]] 
+fmt-p     = "p"                  => [[ [ dup hour>> 12 < [ "AM" ] [ "PM" ] ? ] ]] 
+fmt-S     = "S"                  => [[ [ dup second>> round number>string 2 CHAR: 0 pad-left ] ]] 
+fmt-U     = "U"                  => [[ [ dup week-of-year-sunday ] ]] 
+fmt-w     = "w"                  => [[ [ dup day-of-week number>string ] ]] 
+fmt-W     = "W"                  => [[ [ dup week-of-year-monday ] ]] 
+fmt-x     = "x"                  => [[ [ dup >datestring ] ]] 
+fmt-X     = "X"                  => [[ [ dup >timestring ] ]] 
+fmt-y     = "y"                  => [[ [ dup year>> 100 mod number>string ] ]] 
+fmt-Y     = "Y"                  => [[ [ dup year>> number>string ] ]] 
+fmt-Z     = "Z"                  => [[ [ "Not yet implemented" throw ] ]] 
+unknown   = (.)*                 => [[ "Unknown directive" throw ]]
+
+formats_  = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
+            fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|
+            fmt-X|fmt-y|fmt-Y|fmt-Z|unknown
+
+formats   = "%" (formats_)       => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+          => [[ >string '[ _ swap ] ]]
+
+text      = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: strftime ( format-string -- )
+    parse-format-string [ length ] keep [ ] join 
+    '[ _ <vector> @ reverse concat nip ] ;
+
+

misc/fuel/README

@@ -47,18 +47,29 @@ M-x customize-group fuel will show you how many.
 Quick key reference
 -------------------
 
+(Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
+the same as C-cz)).
+
+* In factor files:
+
  - C-cz : switch to listener
  - C-co : cycle between code, tests and docs factor files
 
- - M-. : edit word at point in Emacs
+ - M-. : edit word at point in Emacs (also in listener)
 
  - C-cr, C-cC-er : eval region
  - C-M-r, C-cC-ee : eval region, extending it to definition boundaries
  - C-M-x, C-cC-ex : eval definition around point
+ - C-ck, C-cC-ek : compile file
 
  - C-cC-da : toggle autodoc mode
  - C-cC-dd : help for word at point
  - C-cC-ds : short help word at point
 
-Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
+* In the debugger (it pops up upon eval/compilation errors):
-the same as C-cz).
+
+ - g : go to error
+ - <digit> : invoke nth restart
+ - q : bury buffer
+
+

misc/fuel/factor-mode.el

@@ -59,6 +59,23 @@ code in the buffer."
   :type 'hook
   :group 'factor-mode)
 
+
+;;; Faces:
+
+(fuel-font-lock--define-faces
+ factor-font-lock font-lock factor-mode
+ ((comment comment "comments")
+  (constructor type  "constructors (<foo>)")
+  (declaration keyword "declaration words")
+  (parsing-word keyword  "parsing words")
+  (setter-word function-name "setter words (>>foo)")
+  (stack-effect comment "stack effect specifications")
+  (string string "strings")
+  (symbol variable-name "name of symbol being defined")
+  (type-name type "type names")
+  (vocabulary-name constant "vocabulary names")
+  (word function-name "word, generic or method being defined")))
+
 
 ;;; Syntax table:
 

misc/fuel/fuel-debug.el

@@ -0,0 +1,266 @@
+;;; fuel-debug.el -- debugging factor code
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sun Dec 07, 2008 04:16
+
+;;; Comentary:
+
+;; A mode for displaying the results of run-file and evaluation, with
+;; support for restarts.
+
+;;; Code:
+
+(require 'fuel-base)
+(require 'fuel-eval)
+(require 'fuel-font-lock)
+
+
+;;; Customization:
+
+(defgroup fuel-debug nil
+  "Major mode for interaction with the Factor debugger"
+  :group 'fuel)
+
+(defcustom fuel-debug-mode-hook nil
+  "Hook run after `fuel-debug-mode' activates"
+  :group 'fuel-debug
+  :type 'hook)
+
+(defcustom fuel-debug-show-short-help t
+  "Whether to show short help on available keys in debugger"
+  :group 'fuel-debug
+  :type 'boolean)
+
+(fuel-font-lock--define-faces
+ fuel-debug-font-lock font-lock fuel-debug
+ ((error warning "highlighting errors")
+  (line variable-name "line numbers in errors/warnings")
+  (column variable-name "column numbers in errors/warnings")
+  (info comment "information headers")
+  (restart-number warning "restart numbers")
+  (restart-name function-name "restart names")))
+
+
+;;; Font lock and other pattern matching:
+
+(defconst fuel-debug--compiler-info-alist
+  '((":warnings" . ?w) (":errors" . ?e) (":linkage" . ?l)))
+
+(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"")
+(defconst fuel-debug--error-line-regex "\\([0-9]+\\):")
+(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$")
+
+(defconst fuel-debug--error-regex
+  (format "%s\n%s"
+          fuel-debug--error-file-regex
+          fuel-debug--error-line-regex))
+
+(defconst fuel-debug--compiler-info-regex
+  (format "^\\(%s\\) "
+          (regexp-opt (mapcar 'car fuel-debug--compiler-info-alist))))
+
+(defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)")
+
+(defconst fuel-debug--font-lock-keywords
+  `((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error)
+    (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line)
+    (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column)
+    (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number)
+                                (2 'fuel-debug-font-lock-restart-name))
+    (,fuel-debug--compiler-info-regex 1 'fuel-debug-font-lock-restart-number)
+    ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info)
+    ("^Error: " . 'fuel-debug-font-lock-error)))
+
+(defun fuel-debug--font-lock-setup ()
+  (set (make-local-variable 'font-lock-defaults)
+       '(fuel-debug--font-lock-keywords t nil nil nil)))
+
+
+;;; Debug buffer:
+
+(defvar fuel-debug--buffer nil)
+
+(make-variable-buffer-local
+ (defvar fuel-debug--last-ret nil))
+
+(make-variable-buffer-local
+ (defvar fuel-debug--file nil))
+
+(defun fuel-debug--buffer ()
+  (or (and (buffer-live-p fuel-debug--buffer) fuel-debug--buffer)
+      (with-current-buffer
+          (setq fuel-debug--buffer (get-buffer-create "*fuel dbg*"))
+        (fuel-debug-mode)
+        (current-buffer))))
+
+(defun fuel-debug--display-retort (ret &optional success-msg no-pop file)
+  (let ((err (fuel-eval--retort-error ret))
+        (inhibit-read-only t))
+    (with-current-buffer (fuel-debug--buffer)
+      (erase-buffer)
+      (fuel-debug--display-output ret)
+      (delete-blank-lines)
+      (newline)
+      (when (and (not err) success-msg)
+        (message "%s" success-msg)
+        (insert "\n" success-msg "\n"))
+      (when err
+        (fuel-debug--display-restarts err)
+        (delete-blank-lines)
+        (newline)
+        (let ((hstr (fuel-debug--help-string err file)))
+          (if fuel-debug-show-short-help
+              (insert "-----------\n" hstr "\n")
+            (message "%s" hstr))))
+      (setq fuel-debug--last-ret ret)
+      (setq fuel-debug--file file)
+      (goto-char (point-max))
+      (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))
+      (not err))))
+
+(defun fuel-debug--display-output (ret)
+  (let* ((last (fuel-eval--retort-output fuel-debug--last-ret))
+         (current (fuel-eval--retort-output ret))
+         (llen (length last))
+         (clen (length current))
+         (trail (and last (substring-no-properties last (/ llen 2))))
+         (err (fuel-eval--retort-error ret))
+         (p (point)))
+    (save-excursion (insert current))
+    (when (and (> clen llen) (> llen 0) (search-forward trail nil t))
+      (delete-region p (point)))
+    (goto-char (point-max))
+    (when err
+      (insert (format "\nError: %S\n\n" (fuel-eval--error-name err))))))
+
+(defun fuel-debug--display-restarts (err)
+  (let* ((rs (fuel-eval--error-restarts err))
+         (rsn (length rs)))
+    (when rs
+      (insert "Restarts:\n\n")
+      (dotimes (n rsn)
+        (insert (format ":%s %s\n" (1+ n) (nth n rs))))
+      (newline))))
+
+(defun fuel-debug--help-string (err &optional file)
+  (format "Press %s%s%sq bury buffer"
+          (if (or file (fuel-eval--error-file err)) "g go to file, " "")
+          (let ((rsn (length (fuel-eval--error-restarts err))))
+            (cond ((zerop rsn) "")
+                  ((= 1 rsn) "1 invoke restart, ")
+                  (t (format "1-%s invoke restarts, " rsn))))
+          (let ((str ""))
+            (dolist (ci fuel-debug--compiler-info-alist str)
+              (save-excursion
+                (goto-char (point-min))
+                (when (search-forward (car ci) nil t)
+                  (setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))))
+
+(defun fuel-debug--buffer-file ()
+  (with-current-buffer (fuel-debug--buffer)
+    (or fuel-debug--file
+        (and fuel-debug--last-ret
+             (fuel-eval--error-file
+              (fuel-eval--retort-error fuel-debug--last-ret))))))
+
+(defsubst fuel-debug--buffer-error ()
+  (fuel-eval--retort-error fuel-debug--last-ret))
+
+(defsubst fuel-debug--buffer-restarts ()
+  (fuel-eval--error-restarts (fuel-debug--buffer-error)))
+
+
+;;; Buffer navigation:
+
+(defun fuel-debug-goto-error ()
+  (interactive)
+  (let* ((err (or (fuel-debug--buffer-error)
+                  (error "No errors reported")))
+         (file (or (fuel-debug--buffer-file)
+                   (error "No file associated with error")))
+         (l/c (fuel-eval--error-line/column err))
+         (line (or (car l/c) 1))
+         (col (or (cdr l/c) 0)))
+    (find-file-other-window file)
+    (goto-line line)
+    (forward-char col)))
+
+(defun fuel-debug--read-restart-no ()
+  (let ((rs (fuel-debug--buffer-restarts)))
+    (unless rs (error "No restarts available"))
+    (let* ((rsn (length rs))
+           (prompt (format "Restart number? (1-%s): " rsn))
+           (no 0))
+      (while (or (> (setq no (read-number prompt)) rsn)
+                 (< no 1)))
+      no)))
+
+(defun fuel-debug-exec-restart (&optional n confirm)
+  (interactive (list (fuel-debug--read-restart-no)))
+  (let ((n (or n 1))
+        (rs (fuel-debug--buffer-restarts)))
+    (when (zerop (length rs))
+      (error "No restarts available"))
+    (when (or (< n 1) (> n (length rs)))
+      (error "Restart %s not available" n))
+    (when (or (not confirm)
+              (y-or-n-p (format "Invoke restart %s? " n)))
+      (message "Invoking restart %s" n)
+      (let* ((file (fuel-debug--buffer-file))
+             (buffer (if file (find-file-noselect file) (current-buffer))))
+        (with-current-buffer buffer
+          (fuel-debug--display-retort
+           (fuel-eval--eval-string/context (format ":%s" n))
+           (format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
+
+(defun fuel-debug-show--compiler-info (info)
+  (save-excursion
+    (goto-char (point-min))
+    (unless (re-search-forward (format "^%s" info) nil t)
+      (error "%s information not available" info))
+    (message "Retrieving %s info ..." info)
+    (unless (fuel-debug--display-retort
+             (fuel-eval--eval-string info) "" (fuel-debug--buffer-file))
+      (error "Sorry, no %s info available" info))))
+
+
+;;; Fuel Debug mode:
+
+(defvar fuel-debug-mode-map
+  (let ((map (make-keymap)))
+    (suppress-keymap map)
+    (define-key map "g" 'fuel-debug-goto-error)
+    (define-key map "\C-c\C-c" 'fuel-debug-goto-error)
+    (define-key map "n" 'next-line)
+    (define-key map "p" 'previous-line)
+    (define-key map "q" 'bury-buffer)
+    (dotimes (n 9)
+      (define-key map (vector (+ ?1 n))
+        `(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t))))
+    (dolist (ci fuel-debug--compiler-info-alist)
+      (define-key map (vector (cdr ci))
+        `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci)))))
+    map))
+
+(defun fuel-debug-mode ()
+  "A major mode for displaying Factor's compilation results and
+invoking restarts as needed.
+\\{fuel-debug-mode-map}"
+  (interactive)
+  (kill-all-local-variables)
+  (setq major-mode 'factor-mode)
+  (setq mode-name "Fuel Debug")
+  (use-local-map fuel-debug-mode-map)
+  (fuel-debug--font-lock-setup)
+  (setq fuel-debug--file nil)
+  (setq fuel-debug--last-ret nil)
+  (toggle-read-only 1)
+  (run-hooks 'fuel-debug-mode-hook))
+
+
+(provide 'fuel-debug)
+;;; fuel-debug.el ends here

misc/fuel/fuel-eval.el

@@ -38,7 +38,8 @@
         (when (and (> fuel-eval-log-max-length 0)
                    (> (point) fuel-eval-log-max-length))
           (erase-buffer))
-        (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256) "\n"))
+        (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256)))
+        (newline)
         (let ((beg (point)))
           (comint-redirect-send-command-to-process str (current-buffer) proc nil t)
           (with-current-buffer (process-buffer proc)
@@ -58,8 +59,6 @@
 
 (defsubst fuel-eval--retort-p (ret) (listp ret))
 
-(defsubst fuel-eval--error-name (err) (car err))
-
 (defsubst fuel-eval--make-parse-error-retort (str)
   (fuel-eval--retort-make 'parse-retort-error nil str))
 
@@ -83,29 +82,60 @@
 (defsubst fuel-eval--factor-array (strs)
   (format "V{ %S }" (mapconcat 'identity strs " ")))
 
-(defsubst fuel-eval--eval-strings (strs)
+(defsubst fuel-eval--eval-strings (strs &optional no-restart)
-  (let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs))))
+  (let ((str (format "fuel-eval-%s %s fuel-eval"
+                     (if no-restart "non-restartable" "restartable")
+                     (fuel-eval--factor-array strs))))
     (fuel-eval--send/retort str)))
 
-(defsubst fuel-eval--eval-string (str)
+(defsubst fuel-eval--eval-string (str &optional no-restart)
-  (fuel-eval--eval-strings (list str)))
+  (fuel-eval--eval-strings (list str) no-restart))
 
-(defun fuel-eval--eval-strings/context (strs)
+(defun fuel-eval--eval-strings/context (strs &optional no-restart)
   (let ((usings (fuel-syntax--usings-update)))
     (fuel-eval--send/retort
-     (format "%s %S %s fuel-eval-in-context"
+     (format "fuel-eval-%s %s %S %s fuel-eval-in-context"
+             (if no-restart "non-restartable" "restartable")
              (fuel-eval--factor-array strs)
              (or fuel-syntax--current-vocab "f")
              (if usings (fuel-eval--factor-array usings) "f")))))
 
-(defsubst fuel-eval--eval-string/context (str)
+(defsubst fuel-eval--eval-string/context (str &optional no-restart)
-  (fuel-eval--eval-strings/context (list str)))
+  (fuel-eval--eval-strings/context (list str) no-restart))
 
-(defun fuel-eval--eval-region/context (begin end)
+(defun fuel-eval--eval-region/context (begin end &optional no-restart)
   (let ((lines (split-string (buffer-substring-no-properties begin end)
                              "[\f\n\r\v]+" t)))
     (when (> (length lines) 0)
-      (fuel-eval--eval-strings/context lines))))
+      (fuel-eval--eval-strings/context lines no-restart))))
+
+
+;;; Error parsing
+
+(defsubst fuel-eval--error-name (err) (car err))
+
+(defsubst fuel-eval--error-restarts (err)
+  (cdr (assoc :restarts (fuel-eval--error-name-p err 'condition))))
+
+(defun fuel-eval--error-name-p (err name)
+  (unless (null err)
+    (or (and (eq (fuel-eval--error-name err) name) err)
+        (assoc name err))))
+
+(defsubst fuel-eval--error-file (err)
+  (nth 1 (fuel-eval--error-name-p err 'source-file-error)))
+
+(defsubst fuel-eval--error-lexer-p (err)
+  (or (fuel-eval--error-name-p err 'lexer-error)
+      (fuel-eval--error-name-p (fuel-eval--error-name-p err 'source-file-error)
+                               'lexer-error)))
+
+(defsubst fuel-eval--error-line/column (err)
+  (let ((err (fuel-eval--error-lexer-p err)))
+    (cons (nth 1 err) (nth 2 err))))
+
+(defsubst fuel-eval--error-line-text (err)
+  (nth 3 (fuel-eval--error-lexer-p err)))
 
 
 (provide 'fuel-eval)

misc/fuel/fuel-font-lock.el

@@ -21,30 +21,23 @@
 
 ;;; Faces:
 
-(defmacro fuel-font-lock--face (face def doc)
+(defmacro fuel-font-lock--make-face (prefix def-prefix group face def doc)
-  (let ((face (intern (format "factor-font-lock-%s" (symbol-name face))))
+  (let ((face (intern (format "%s-%s" prefix face)))
-        (def (intern (format "font-lock-%s-face" (symbol-name def)))))
+        (def (intern (format "%s-%s-face" def-prefix def))))
     `(defface ,face (face-default-spec ,def)
        ,(format "Face for %s." doc)
-       :group 'factor-mode
+       :group ',group
        :group 'faces)))
 
-(defmacro fuel-font-lock--faces-setup ()
+(defmacro fuel-font-lock--define-faces (prefix def-prefix group faces)
+  (let ((setup (make-symbol (format "%s--faces-setup" prefix))))
+  `(progn
+     (defmacro ,setup ()
        (cons 'progn
-        (mapcar (lambda (f) (cons 'fuel-font-lock--face f))
+             (mapcar (lambda (f) (append '(fuel-font-lock--make-face
-                '((comment comment "comments")
+                                      ,prefix ,def-prefix ,group) f))
-                  (constructor type  "constructors (<foo>)")
+                     ',faces)))
-                  (declaration keyword "declaration words")
+     (,setup))))
-                  (parsing-word keyword  "parsing words")
-                  (setter-word function-name "setter words (>>foo)")
-                  (stack-effect comment "stack effect specifications")
-                  (string string "strings")
-                  (symbol variable-name "name of symbol being defined")
-                  (type-name type "type names")
-                  (vocabulary-name constant "vocabulary names")
-                  (word function-name "word, generic or method being defined")))))
-
-(fuel-font-lock--faces-setup)
 
 
 ;;; Font lock:

misc/fuel/fuel-help.el

@@ -68,10 +68,11 @@
 
 (defun fuel-help--word-synopsis (&optional word)
   (let ((word (or word (fuel-syntax-symbol-at-point)))
-        (fuel-eval--log nil))
+        (fuel-eval--log t))
     (when word
       (let ((ret (fuel-eval--eval-string/context
-                  (format "\\ %s synopsis fuel-eval-set-result" word))))
+                  (format "\\ %s synopsis fuel-eval-set-result" word)
+                  t)))
         (when (not (fuel-eval--retort-error ret))
           (if fuel-help-minibuffer-font-lock
               (fuel-help--font-lock-str (fuel-eval--retort-result ret))
@@ -170,7 +171,7 @@ displayed in the minibuffer."
          (def (if ask (read-string prompt nil 'fuel-help--history def) def))
          (cmd (format "\\ %s %s" def (if see "see" "help")))
          (fuel-eval--log nil)
-         (ret (fuel-eval--eval-string/context cmd))
+         (ret (fuel-eval--eval-string/context cmd t))
          (out (fuel-eval--retort-output ret)))
     (if (or (fuel-eval--retort-error ret) (empty-string-p out))
         (message "No help for '%s'" def)

misc/fuel/fuel-listener.el

@@ -59,10 +59,15 @@ buffer."
       (error "Could not run factor: %s is not executable" factor))
     (unless (file-readable-p image)
       (error "Could not run factor: image file %s not readable" image))
-    (setq fuel-listener-buffer
+    (setq fuel-listener-buffer (get-buffer-create "*fuel listener*"))
-          (make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image)))
     (with-current-buffer fuel-listener-buffer
-      (fuel-listener-mode))))
+      (fuel-listener-mode)
+      (message "Starting FUEL listener ...")
+      (comint-exec fuel-listener-buffer "factor"
+                   factor nil `("-run=fuel" ,(format "-i=%s" image)))
+      (fuel-listener--wait-for-prompt 20)
+      (fuel-eval--send-string "USE: fuel")
+      (message "FUEL listener up and running!"))))
 
 (defun fuel-listener--process (&optional start)
   (or (and (buffer-live-p fuel-listener-buffer)
@@ -74,6 +79,23 @@ buffer."
 
 (setq fuel-eval--default-proc-function 'fuel-listener--process)
 
+
+;;; Prompt chasing
+
+(defun fuel-listener--wait-for-prompt (&optional timeout)
+    (let ((proc (get-buffer-process fuel-listener-buffer))
+          (seen))
+      (with-current-buffer fuel-listener-buffer
+        (while (progn (goto-char comint-last-input-end)
+                      (not (or seen
+                               (setq seen
+                                     (re-search-forward comint-prompt-regexp nil t))
+                               (not (accept-process-output proc timeout))))))
+        (goto-char (point-max)))
+      (unless seen
+        (pop-to-buffer fuel-listener-buffer)
+        (error "No prompt found!"))))
+
 
 ;;; Interface: starting fuel listener
 
@@ -94,30 +116,17 @@ buffer."
 
 (defconst fuel-listener--prompt-regex "( [^)]* ) ")
 
-(defun fuel-listener--wait-for-prompt (&optional timeout)
-  (let ((proc (fuel-listener--process)))
-    (with-current-buffer fuel-listener-buffer
-      (goto-char comint-last-input-end)
-      (while (not (or (re-search-forward comint-prompt-regexp nil t)
-                      (not (accept-process-output proc timeout))))
-        (goto-char comint-last-input-end))
-      (goto-char (point-max)))))
-
-(defun fuel-listener--startup ()
-  (fuel-listener--wait-for-prompt)
-  (fuel-eval--send-string "USE: fuel")
-  (message "FUEL listener up and running!"))
-
 (define-derived-mode fuel-listener-mode comint-mode "Fuel Listener"
   "Major mode for interacting with an inferior Factor listener process.
 \\{fuel-listener-mode-map}"
   (set (make-local-variable 'comint-prompt-regexp)
        fuel-listener--prompt-regex)
   (set (make-local-variable 'comint-prompt-read-only) t)
-  (fuel-listener--startup))
+  (setq fuel-listener--compilation-begin nil))
 
-;; (define-key fuel-listener-mode-map "\C-w" 'comint-kill-region)
+(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
-;; (define-key fuel-listener-mode-map "\C-k" 'comint-kill-whole-line)
+(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
+(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file)
 
 
 (provide 'fuel-listener)

misc/fuel/fuel-mode.el

@@ -18,6 +18,7 @@
 (require 'fuel-base)
 (require 'fuel-syntax)
 (require 'fuel-font-lock)
+(require 'fuel-debug)
 (require 'fuel-help)
 (require 'fuel-eval)
 (require 'fuel-listener)
@@ -37,33 +38,60 @@
 
 ;;; User commands
 
+(defun fuel-run-file (&optional arg)
+  "Sends the current file to Factor for compilation.
+With prefix argument, ask for the file to run."
+  (interactive "P")
+  (let* ((file (or (and arg (read-file-name "File: " nil (buffer-file-name) t))
+                   (buffer-file-name)))
+         (file (expand-file-name file))
+         (buffer (find-file-noselect file))
+         (cmd (format "%S fuel-run-file" file)))
+    (when buffer
+      (with-current-buffer buffer
+        (message "Compiling %s ..." file)
+        (let ((r (fuel-debug--display-retort (fuel-eval--eval-string/context cmd)
+                                             (format "%s successfully compiled" file)
+                                             nil
+                                             file)))
+          (if r (message "Compiling %s ... OK!" file) (message "")))))))
+
 (defun fuel-eval-region (begin end &optional arg)
   "Sends region to Fuel's listener for evaluation.
-With prefix, switchs to the listener's buffer afterwards."
+Unless called with a prefix, switchs to the compilation results
+buffer in case of errors."
   (interactive "r\nP")
-  (let* ((ret (fuel-eval--eval-region/context begin end))
+  (fuel-debug--display-retort
-         (err (fuel-eval--retort-error ret)))
+   (fuel-eval--eval-region/context begin end)
-    (message "%s" (or err (fuel--shorten-region begin end 70))))
+   (format "%s%s"
-  (when arg (pop-to-buffer fuel-listener-buffer)))
+           (if fuel-syntax--current-vocab
+               (format "IN: %s " fuel-syntax--current-vocab)
+             "")
+           (fuel--shorten-region begin end 70))
+   arg
+   (buffer-file-name)))
 
 (defun fuel-eval-extended-region (begin end &optional arg)
   "Sends region extended outwards to nearest definitions,
-to Fuel's listener for evaluation. With prefix, switchs to the
+to Fuel's listener for evaluation.
-listener's buffer afterwards."
+Unless called with a prefix, switchs to the compilation results
+buffer in case of errors."
   (interactive "r\nP")
   (fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point))
-                    (save-excursion (goto-char end) (mark-defun) (mark))))
+                    (save-excursion (goto-char end) (mark-defun) (mark))
+                    arg))
 
 (defun fuel-eval-definition (&optional arg)
   "Sends definition around point to Fuel's listener for evaluation.
-With prefix, switchs to the listener's buffer afterwards."
+Unless called with a prefix, switchs to the compilation results
+buffer in case of errors."
   (interactive "P")
   (save-excursion
     (mark-defun)
     (let* ((begin (point))
            (end (mark)))
       (unless (< begin end) (error "No evaluable definition around point"))
-      (fuel-eval-region begin end))))
+      (fuel-eval-region begin end arg))))
 
 (defun fuel-edit-word-at-point (&optional arg)
   "Opens a new window visiting the definition of the word at point.
@@ -128,6 +156,9 @@ interacting with a factor listener is at your disposal.
 
 (fuel-mode--key-1 ?z 'run-factor)
 
+(fuel-mode--key-1 ?k 'fuel-run-file)
+(fuel-mode--key ?e ?k 'fuel-run-file)
+
 (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
 (fuel-mode--key ?e ?x 'fuel-eval-definition)
 

vm/code_heap.c

@@ -147,6 +147,8 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
 /* Perform all fixups on a code block */
 void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
 {
+	compiled->last_scan = NURSERY;
+
 	if(compiled->relocation != F)
 	{
 		F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);

vm/data_gc.c

@@ -32,9 +32,7 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
 	data_heap->gen_count = gens;
 
 	CELL total_size;
-	if(data_heap->gen_count == 1)
+	if(data_heap->gen_count == 2)
-		total_size = 2 * tenured_size;
-	else if(data_heap->gen_count == 2)
 		total_size = young_size + 2 * tenured_size;
 	else if(data_heap->gen_count == 3)
 		total_size = young_size + 2 * aging_size + 2 * tenured_size;

vm/data_gc.h

@@ -137,6 +137,7 @@ void collect_cards(void);
 /* the oldest generation */
 #define TENURED (data_heap->gen_count-1)
 
+#define MIN_GEN_COUNT 1
 #define MAX_GEN_COUNT 3
 
 /* used during garbage collection only */