diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 8a2823010d..e75e7f6046 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/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 diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index e35eb02604..bd6d657442 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/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 ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 04bdcca68b..698c3a1766 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/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 ; -: arg1 ( -- reg ) EDX ; -: arg2 ( -- reg ) ECX ; -: temp-reg ( -- reg ) EBX ; +: temp0 ( -- reg ) EAX ; +: temp1 ( -- reg ) EDX ; +: temp2 ( -- reg ) ECX ; +: 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 - arg0 [] stack-reg MOV ! save stack pointer + temp0 0 [] MOV ! load stack_chain + temp0 [] stack-reg MOV ! save stack pointer ] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define [ diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 83a72d6dd3..efa3de3065 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/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 - arg0 arg0 [] MOV - arg0 [] stack-reg MOV ! save stack pointer + temp0 0 MOV ! load stack_chain + temp0 temp0 [] MOV + 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 - arg1 JMP ! go + temp1 0 MOV ! load XT + temp1 JMP ! go ] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define << "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index f0ca56da14..a21c4534d2 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/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 diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index 459945d82e..709f138463 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/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 diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 597a2c9d31..3451da78e1 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/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 - stack-frame-size PUSH ! save stack frame size - temp-reg PUSH ! push XT - stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment + ! load XT + temp0 0 MOV + ! save stack frame size + 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 - ds-reg bootstrap-cell ADD ! increment datastack pointer - ds-reg [] arg0 MOV ! store literal on datastack + ! load literal + temp0 0 MOV + ! 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 - ds-reg bootstrap-cell SUB ! pop boolean - arg0 \ f tag-number CMP ! compare boolean with f - f JNE ! jump to true branch if not equal + ! load boolean + temp0 ds-reg [] MOV + ! pop boolean + 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 - arg0 ds-reg [] MOV ! load index - fixnum>slot@ ! turn it into an array offset - ds-reg bootstrap-cell SUB ! pop index - arg0 arg1 ADD ! compute quotation location - arg0 arg0 array-start-offset [+] MOV ! load quotation - arg0 quot-xt-offset [+] JMP ! execute branch + ! load dispatch table + temp1 0 MOV + ! load index + temp0 ds-reg [] MOV + ! turn it into an array offset + fixnum>slot@ + ! 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 - arg1 ds-reg -1 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV ds-reg 2 bootstrap-cells SUB - rs-reg [] arg0 MOV - rs-reg -1 bootstrap-cells [+] arg1 MOV ; + rs-reg [] temp0 MOV + rs-reg -1 bootstrap-cells [+] temp1 MOV ; : jit-3>r ( -- ) rs-reg 3 bootstrap-cells ADD - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - arg2 ds-reg -2 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp2 ds-reg -2 bootstrap-cells [+] MOV ds-reg 3 bootstrap-cells SUB - rs-reg [] arg0 MOV - rs-reg -1 bootstrap-cells [+] arg1 MOV - rs-reg -2 bootstrap-cells [+] arg2 MOV ; + rs-reg [] temp0 MOV + rs-reg -1 bootstrap-cells [+] temp1 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 - arg1 rs-reg -1 bootstrap-cells [+] MOV + temp0 rs-reg [] MOV + temp1 rs-reg -1 bootstrap-cells [+] MOV rs-reg 2 bootstrap-cells SUB - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV ; + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV ; : jit-3r> ( -- ) ds-reg 3 bootstrap-cells ADD - arg0 rs-reg [] MOV - arg1 rs-reg -1 bootstrap-cells [+] MOV - arg2 rs-reg -2 bootstrap-cells [+] MOV + temp0 rs-reg [] MOV + temp1 rs-reg -1 bootstrap-cells [+] MOV + temp2 rs-reg -2 bootstrap-cells [+] MOV rs-reg 3 bootstrap-cells SUB - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV - ds-reg -2 bootstrap-cells [+] arg2 MOV ; + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV + ds-reg -2 bootstrap-cells [+] temp2 MOV ; [ jit->r @@ -126,13 +145,14 @@ big-endian off ] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define [ - jit-3>r + jit-3>r f CALL jit-3r> ] 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 - ds-reg bootstrap-cell SUB ! pop stack - arg0 quot-xt-offset [+] JMP ! call quotation + ! load from stack + temp0 ds-reg [] MOV + ! 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 - ds-reg bootstrap-cell SUB ! pop stack - arg0 word-xt-offset [+] JMP ! execute word + ! load from stack + temp0 ds-reg [] MOV + ! 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 - arg1 tag-mask get AND ! compute tag - arg1 tag-bits get SHL ! tag the tag - ds-reg [] arg1 MOV ! push to stack + ! load from stack + temp0 ds-reg [] MOV + ! compute tag + 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 - ds-reg bootstrap-cell SUB ! adjust stack pointer - arg1 ds-reg [] MOV ! load object - fixnum>slot@ ! turn slot number into offset - arg1 tag-bits get SHR ! mask off tag - arg1 tag-bits get SHL - arg0 arg1 arg0 [+] MOV ! load slot value - ds-reg [] arg0 MOV ! push to stack + ! load slot number + temp0 ds-reg [] MOV + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! load object + temp1 ds-reg [] MOV + ! turn slot number into offset + 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 - arg1 ds-reg bootstrap-cell neg [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg bootstrap-cell neg [+] MOV ds-reg 2 bootstrap-cells ADD - ds-reg [] arg0 MOV - ds-reg bootstrap-cell neg [+] arg1 MOV + ds-reg [] temp0 MOV + ds-reg bootstrap-cell neg [+] temp1 MOV ] f f f \ 2dup define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - temp-reg ds-reg -2 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp3 ds-reg -2 bootstrap-cells [+] MOV ds-reg 3 bootstrap-cells ADD - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV - ds-reg -2 bootstrap-cells [+] temp-reg MOV + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 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 - arg1 ds-reg -1 bootstrap-cells [+] MOV - ds-reg [] arg1 MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] 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 - arg1 ds-reg -1 bootstrap-cells [+] MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV - ds-reg -2 bootstrap-cells [+] arg0 MOV + ds-reg [] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV + ds-reg -2 bootstrap-cells [+] temp0 MOV ] f f f \ tuck define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg bootstrap-cell neg [+] MOV - ds-reg bootstrap-cell neg [+] arg0 MOV - ds-reg [] arg1 MOV + temp0 ds-reg [] MOV + temp1 ds-reg bootstrap-cell neg [+] MOV + ds-reg bootstrap-cell neg [+] temp0 MOV + ds-reg [] temp1 MOV ] f f f \ swap define-sub-primitive [ - arg0 ds-reg -1 bootstrap-cells [+] MOV - arg1 ds-reg -2 bootstrap-cells [+] MOV - ds-reg -2 bootstrap-cells [+] arg0 MOV - ds-reg -1 bootstrap-cells [+] arg1 MOV + temp0 ds-reg -1 bootstrap-cells [+] MOV + temp1 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp1 MOV ] f f f \ swapd define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - temp-reg ds-reg -2 bootstrap-cells [+] MOV - ds-reg -2 bootstrap-cells [+] arg1 MOV - ds-reg -1 bootstrap-cells [+] arg0 MOV - ds-reg [] temp-reg MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp3 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] temp1 MOV + ds-reg -1 bootstrap-cells [+] temp0 MOV + ds-reg [] temp3 MOV ] f f f \ rot define-sub-primitive [ - arg0 ds-reg [] MOV - arg1 ds-reg -1 bootstrap-cells [+] MOV - temp-reg ds-reg -2 bootstrap-cells [+] MOV - ds-reg -2 bootstrap-cells [+] arg0 MOV - ds-reg -1 bootstrap-cells [+] temp-reg MOV - ds-reg [] arg1 MOV + temp0 ds-reg [] MOV + temp1 ds-reg -1 bootstrap-cells [+] MOV + temp3 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] temp0 MOV + ds-reg -1 bootstrap-cells [+] temp3 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 - arg1 \ f tag-number MOV ! load f - arg0 ds-reg [] MOV ! load first value - ds-reg bootstrap-cell SUB ! adjust stack pointer - ds-reg [] arg0 CMP ! compare with second value - [ arg1 temp-reg ] dip execute ! move t if true - ds-reg [] arg1 MOV ! store - ; + ! load t + temp3 0 MOV + ! load f + temp1 \ f tag-number MOV + ! load first value + temp0 ds-reg [] MOV + ! 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 - ds-reg bootstrap-cell SUB ! pop stack - [ ds-reg [] arg0 ] dip execute ! compute result - ; + ! load second input + temp0 ds-reg [] MOV + ! 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 - ds-reg bootstrap-cell SUB ! pop stack - arg1 ds-reg [] MOV ! load first input - arg0 tag-bits get SAR ! untag second input - arg0 arg1 IMUL2 ! multiply - ds-reg [] arg1 MOV ! push result + ! load second input + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! load first input + 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 - ds-reg [] tag-mask get XOR ! clear tag bits + ! complement + 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 - shift-arg tag-bits get SAR ! untag shift count - ds-reg bootstrap-cell SUB ! adjust stack pointer - temp-reg ds-reg [] MOV ! load value - arg1 temp-reg MOV ! make a copy - arg1 CL SHL ! compute positive shift value in arg1 - shift-arg NEG ! compute negative shift value in arg0 - temp-reg CL SAR - temp-reg tag-mask get bitnot AND - shift-arg 0 CMP ! if shift count was negative, move arg0 to arg1 - arg1 temp-reg CMOVGE - ds-reg [] arg1 MOV ! push to stack + ! load shift count + shift-arg ds-reg [] MOV + ! untag shift count + shift-arg tag-bits get SAR + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! load value + temp3 ds-reg [] MOV + ! make a copy + temp1 temp3 MOV + ! compute positive shift value in temp1 + 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 - div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter - mod-arg div-arg MOV ! make a copy - mod-arg bootstrap-cell-bits 1- SAR ! sign-extend - temp-reg IDIV ; ! divide + ! load second parameter + temp3 ds-reg [] MOV + ! load first parameter + div-arg ds-reg bootstrap-cell neg [+] MOV + ! 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 - ds-reg [] mod-arg MOV ! push to stack + ! adjust stack pointer + 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 - div-arg tag-bits get SHL ! tag it - ds-reg [] div-arg MOV ! push to stack + ! adjust stack pointer + ds-reg bootstrap-cell SUB + ! 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 - ds-reg [] mod-arg MOV ! push to stack + ! tag it + 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 - arg0 tag-mask get AND - arg0 \ f tag-number MOV - arg1 1 tag-fixnum MOV - arg0 arg1 CMOVE - ds-reg [] arg0 MOV + temp0 ds-reg [] OR + temp0 tag-mask get AND + temp0 \ f tag-number MOV + temp1 1 tag-fixnum MOV + temp0 temp1 CMOVE + ds-reg [] temp0 MOV ] f f f \ both-fixnums? define-sub-primitive [ - arg0 ds-reg [] MOV ! load local number - fixnum>slot@ ! turn local number into offset - arg0 rs-reg arg0 [+] MOV ! load local value - ds-reg [] arg0 MOV ! push to stack + ! load local number + temp0 ds-reg [] MOV + ! turn local number into offset + 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 - ds-reg bootstrap-cell SUB ! adjust stack pointer - fixnum>slot@ ! turn local number into offset - rs-reg arg0 SUB ! decrement retain stack pointer + ! load local count + temp0 ds-reg [] MOV + ! adjust 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 diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 52dc389fe6..8173ff6a5b 100644 --- a/basis/db/db-docs.factor +++ b/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 } { $subsection } "Using statements with the database:" diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor index 85363c8404..1666d60c83 100644 --- a/basis/io/unix/backend/backend.factor +++ b/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 ] [ diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor index 6b687a8afb..b4e2b7af6f 100644 --- a/basis/io/unix/kqueue/kqueue.factor +++ b/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 ; : ( -- mx ) kqueue-mx new-mx - H{ } clone >>monitors kqueue dup io-error >>fd max-events "kevent" >>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 ) - [ - [ EVFILT_READ EV_DELETE make-kevent ] dip - register-kevent - ] [ remove-input-callbacks ] 2bi ; +M: kqueue-mx remove-input-callbacks ( fd mx -- seq ) + 2dup reads>> key? [ + [ call-next-method ] [ + [ EVFILT_READ EV_DELETE make-kevent ] dip + register-kevent + ] 2bi + ] [ 2drop f ] if ; -: cancel-output-callbacks ( fd mx -- seq ) - [ - [ EVFILT_WRITE EV_DELETE make-kevent ] dip - register-kevent - ] [ remove-output-callbacks ] 2bi ; - -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 ; +M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) + 2dup writes>> key? [ + [ + [ EVFILT_WRITE EV_DELETE make-kevent ] dip + register-kevent + ] [ call-next-method ] 2bi + ] [ 2drop f ] if ; : wait-kevent ( mx timespec -- n ) [ diff --git a/basis/io/unix/macosx/macosx.factor b/basis/io/unix/macosx/macosx.factor index 77140b81c9..ef52b676fb 100644 --- a/basis/io/unix/macosx/macosx.factor +++ b/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 ( -- ) + mx set-global ; macosx set-io-backend diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index e9e1bfa16a..77b87d1b49 100644 --- a/basis/locals/locals-docs.factor +++ b/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:" diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor index d84e49f784..24810a6c3e 100644 --- a/basis/logging/analysis/analysis.factor +++ b/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 - message-histogram get at+ + dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array + message-histogram get inc-at ] when drop ; diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index 8c35ae25a8..2ad16a4d8d 100644 --- a/basis/tools/memory/memory.factor +++ b/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> diff --git a/basis/unix/kqueue/kqueue.factor b/basis/unix/kqueue/kqueue.factor index 83c3bb5232..d7623df8be 100644 --- a/basis/unix/kqueue/kqueue.factor +++ b/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 >> diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index b02e0189b2..2f486cd948 100644 --- a/core/assocs/assocs-docs.factor +++ b/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." } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 76745cc015..320e370ec9 100644 --- a/core/assocs/assocs.factor +++ b/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 -- ) - [ 0 or + ] change-at ; +: at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline + +: inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline : map>assoc ( seq quot exemplar -- assoc ) [ [ 2array ] compose { } map-as ] dip assoc-like ; inline diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 3bac6c87b3..5b1844b78b 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/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 / ;" + " [ name>> ] [ salary>> 26 / ] bi ;" } "An example of using a changer:" { $code diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 1c23e700ca..6794825897 100644 --- a/core/memory/memory-tests.factor +++ b/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 diff --git a/extra/crypto/barrett/barrett-tests.factor b/extra/crypto/barrett/barrett-tests.factor index 01163f730f..13dae69dce 100644 --- a/extra/crypto/barrett/barrett-tests.factor +++ b/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 diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index d8a363ca71..d9db83b5e3 100644 --- a/extra/fuel/fuel.factor +++ b/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 -definitions eval io io.files io.streams.string kernel listener listener.private -make math namespaces parser prettyprint quotations sequences strings -vectors vocabs.loader ; +USING: accessors arrays classes classes.tuple compiler.units +combinators continuations debugger definitions eval help +io io.files io.streams.string kernel lexer listener listener.private +make math namespaces parser prettyprint prettyprint.config +quotations sequences strings source-files vectors vocabs.loader ; IN: fuel -! > 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 ( -- ) - f error set-global ; +: fuel-forget-error ( -- ) f error set-global ; inline +: 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 - f fuel-eval-output set-global ; + fuel-forget-result + fuel-forget-output ; : (fuel-end-eval) ( quot -- ) with-string-writer fuel-eval-output set-global - fuel-retort - pop-fuel-status ; + fuel-retort pop-fuel-status ; inline : (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 ( -- ) [ ] (fuel-end-eval) ; inline : fuel-get-edit-location ( defspec -- ) where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ; -: fuel-startup ( -- ) - "listener" run ; +: fuel-run-file ( path -- ) run-file ; inline + +: fuel-startup ( -- ) "listener" run ; inline MAIN: fuel-startup diff --git a/extra/math/binpack/authors.txt b/extra/math/binpack/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/math/binpack/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/math/binpack/binpack-docs.factor b/extra/math/binpack/binpack-docs.factor new file mode 100644 index 0000000000..36a29c7aa1 --- /dev/null +++ b/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." } ; + diff --git a/extra/math/binpack/binpack-tests.factor b/extra/math/binpack/binpack-tests.factor new file mode 100644 index 0000000000..d0d4630484 --- /dev/null +++ b/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 + + diff --git a/extra/math/binpack/binpack.factor b/extra/math/binpack/binpack.factor new file mode 100644 index 0000000000..e3a009feb5 --- /dev/null +++ b/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 dup length ] dip + tuck / ceiling [ ] 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 ; + diff --git a/extra/math/binpack/summary.txt b/extra/math/binpack/summary.txt new file mode 100644 index 0000000000..c8b91966bb --- /dev/null +++ b/extra/math/binpack/summary.txt @@ -0,0 +1 @@ +Bin-packing algorithms. diff --git a/extra/time/authors.txt b/extra/time/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/time/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/time/time-docs.factor b/extra/time/time-docs.factor new file mode 100644 index 0000000000..8fbc59e315 --- /dev/null +++ b/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" + + diff --git a/extra/time/time-tests.factor b/extra/time/time-tests.factor new file mode 100644 index 0000000000..0b0602bd62 --- /dev/null +++ b/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 ; + +[ 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 + diff --git a/extra/time/time.factor b/extra/time/time.factor new file mode 100644 index 0000000000..be19fb0919 --- /dev/null +++ b/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 + + + [[ [ "%" ] ]] +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 + '[ _ @ reverse concat nip ] ; + + diff --git a/misc/fuel/README b/misc/fuel/README index 078490abfd..18f6fa1e94 100644 --- a/misc/fuel/README +++ b/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 accept also C- (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 accept also C- (e.g. C-cC-z is -the same as C-cz). +* In the debugger (it pops up upon eval/compilation errors): + + - g : go to error + - : invoke nth restart + - q : bury buffer + + diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index d79930bb22..b3952074f5 100644 --- a/misc/fuel/factor-mode.el +++ b/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 ()") + (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: diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el new file mode 100644 index 0000000000..b3aad7f3dc --- /dev/null +++ b/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 +;; 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 diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index bef7171f6f..62001cc48c 100644 --- a/misc/fuel/fuel-eval.el +++ b/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) - (let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs)))) +(defsubst fuel-eval--eval-strings (strs &optional no-restart) + (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) - (fuel-eval--eval-strings (list str))) +(defsubst fuel-eval--eval-string (str &optional no-restart) + (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) - (fuel-eval--eval-strings/context (list str))) +(defsubst fuel-eval--eval-string/context (str &optional no-restart) + (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) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index c8673f742b..4c710635ba 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -21,30 +21,23 @@ ;;; Faces: -(defmacro fuel-font-lock--face (face def doc) - (let ((face (intern (format "factor-font-lock-%s" (symbol-name face)))) - (def (intern (format "font-lock-%s-face" (symbol-name def))))) +(defmacro fuel-font-lock--make-face (prefix def-prefix group face def doc) + (let ((face (intern (format "%s-%s" prefix face))) + (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 () - (cons 'progn - (mapcar (lambda (f) (cons 'fuel-font-lock--face f)) - '((comment comment "comments") - (constructor type "constructors ()") - (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"))))) - -(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) (append '(fuel-font-lock--make-face + ,prefix ,def-prefix ,group) f)) + ',faces))) + (,setup)))) ;;; Font lock: diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index dcf17d2716..1db9b25d69 100644 --- a/misc/fuel/fuel-help.el +++ b/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) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index c741a77a5d..9fa330993c 100644 --- a/misc/fuel/fuel-listener.el +++ b/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 - (make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image))) + (setq fuel-listener-buffer (get-buffer-create "*fuel listener*")) (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-k" 'comint-kill-whole-line) +(define-key fuel-listener-mode-map "\C-ch" 'fuel-help) +(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) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index bd9b127c7d..ea1d4b93ed 100644 --- a/misc/fuel/fuel-mode.el +++ b/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)) - (err (fuel-eval--retort-error ret))) - (message "%s" (or err (fuel--shorten-region begin end 70)))) - (when arg (pop-to-buffer fuel-listener-buffer))) + (fuel-debug--display-retort + (fuel-eval--eval-region/context begin end) + (format "%s%s" + (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 -listener's buffer afterwards." +to Fuel's listener for evaluation. +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) diff --git a/vm/code_heap.c b/vm/code_heap.c index 6ed5ea4309..9a1c45c7df 100755 --- a/vm/code_heap.c +++ b/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); diff --git a/vm/data_gc.c b/vm/data_gc.c index 6e15718b2d..2122f930f0 100755 --- a/vm/data_gc.c +++ b/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) - total_size = 2 * tenured_size; - else if(data_heap->gen_count == 2) + 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; diff --git a/vm/data_gc.h b/vm/data_gc.h index 4ec3fdd5f2..6d367a25fd 100755 --- a/vm/data_gc.h +++ b/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 */