diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index c3ae644b47..ae148e3ac0 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -204,7 +204,7 @@ M: byte-array byte-length length ; dup length [ nip malloc dup ] 2keep memcpy ; : memory>byte-array ( alien len -- byte-array ) - [ nip dup ] 2keep memcpy ; + [ nip (byte-array) dup ] 2keep memcpy ; : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 78355a4670..fb7292b989 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -100,4 +100,8 @@ SYMBOL: bootstrap-time "output-image" get save-image-and-exit ] if -] [ drop "resource:basis/bootstrap/bootstrap-error.factor" run-file ] recover +] [ + drop + load-help? off + "resource:basis/bootstrap/bootstrap-error.factor" run-file +] recover diff --git a/basis/byte-vectors/byte-vectors.factor b/basis/byte-vectors/byte-vectors.factor index e24c808bbc..d146017db0 100644 --- a/basis/byte-vectors/byte-vectors.factor +++ b/basis/byte-vectors/byte-vectors.factor @@ -10,7 +10,7 @@ TUPLE: byte-vector { length array-capacity } ; : ( n -- byte-vector ) - 0 byte-vector boa ; inline + (byte-array) 0 byte-vector boa ; inline : >byte-vector ( seq -- byte-vector ) T{ byte-vector f B{ } 0 } clone-like ; @@ -22,7 +22,7 @@ M: byte-vector like ] unless ; M: byte-vector new-sequence - drop [ ] [ >fixnum ] bi byte-vector boa ; + drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; M: byte-vector equal? over byte-vector? [ sequence= ] [ 2drop f ] if ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index ceac5e960c..3a4c702bc5 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -54,15 +54,19 @@ IN: compiler.cfg.intrinsics.allot : bytes>cells ( m -- n ) cell align cell /i ; -:: emit- ( node -- ) - [let | len [ node node-input-infos first literal>> ] | - len expand-? [ - [let | elt [ 0 ^^load-literal ] - reg [ len ^^allot-byte-array ] | - ds-drop - len reg store-length - elt reg len bytes>cells store-initial-element - reg ds-push - ] - ] [ node emit-primitive ] if - ] ; +: emit-allot-byte-array ( len -- dst ) + ds-drop + dup ^^allot-byte-array + [ store-length ] [ ds-push ] [ ] tri ; + +: emit-(byte-array) ( node -- ) + dup node-input-infos first literal>> dup expand-? + [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; + +: emit- ( node -- ) + dup node-input-infos first literal>> dup expand-? [ + nip + [ 0 ^^load-literal ] dip + [ emit-allot-byte-array ] keep + bytes>cells store-initial-element + ] [ drop emit-primitive ] if ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 6656cd11f7..5f75330865 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -52,6 +52,7 @@ IN: compiler.cfg.intrinsics classes.tuple.private: arrays: byte-arrays: + byte-arrays:(byte-array) math.private: math.private: kernel: @@ -139,6 +140,7 @@ IN: compiler.cfg.intrinsics { \ classes.tuple.private: [ emit- iterate-next ] } { \ arrays: [ emit- iterate-next ] } { \ byte-arrays: [ emit- iterate-next ] } + { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] } { \ math.private: [ emit-simple-allot iterate-next ] } { \ math.private: [ emit-simple-allot iterate-next ] } { \ kernel: [ emit-simple-allot iterate-next ] } 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/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 83e71c3363..8192b1c520 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -14,12 +14,13 @@ IN: compiler.tree.propagation.slots UNION: fixed-length-sequence array byte-array string ; : sequence-constructor? ( word -- ? ) - { } memq? ; + { (byte-array) } memq? ; : constructor-output-class ( word -- class ) { { array } { byte-array } + { (byte-array) byte-array } { string } } at ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 04bdcca68b..f29dec128c 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -10,19 +10,20 @@ 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 ; +: arg ( -- reg ) EAX ; +: 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..20a953b6d5 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -5,9 +5,7 @@ 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 ; +: arg ( -- reg ) RDI ; << "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..3accca400f 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -5,9 +5,7 @@ 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 ; +: arg ( -- reg ) RCX ; << "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..42fcfaa6a2 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 + arg ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! call quotation + arg 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/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/epoll/epoll.factor b/basis/io/unix/epoll/epoll.factor index 05a9bcfa8d..e8d33787f3 100644 --- a/basis/io/unix/epoll/epoll.factor +++ b/basis/io/unix/epoll/epoll.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.ports io.unix.backend -bit-arrays sequences assocs unix unix.linux.epoll math -namespaces unix.time ; +USING: accessors alien.c-types kernel io.ports io.unix.backend +bit-arrays sequences assocs struct-arrays math namespaces locals +fry unix unix.linux.epoll unix.time ; IN: io.unix.epoll TUPLE: epoll-mx < mx events ; @@ -14,47 +14,50 @@ TUPLE: epoll-mx < mx events ; : ( -- mx ) epoll-mx new-mx - max-events epoll_create dup io-error over set-mx-fd - max-events "epoll-event" over set-epoll-mx-events ; + max-events epoll_create dup io-error >>fd + max-events "epoll-event" >>events ; -GENERIC: io-task-events ( task -- n ) - -M: input-task io-task-events drop EPOLLIN ; - -M: output-task io-task-events drop EPOLLOUT ; - -: make-event ( task -- event ) +: make-event ( fd events -- event ) "epoll-event" - over io-task-events over set-epoll-event-events - swap io-task-fd over set-epoll-event-fd ; + [ set-epoll-event-events ] keep + [ set-epoll-event-fd ] keep ; -: do-epoll-ctl ( task mx what -- ) - >r mx-fd r> rot dup io-task-fd swap make-event - epoll_ctl io-error ; +:: do-epoll-ctl ( fd mx what events -- ) + mx fd>> what fd fd events make-event epoll_ctl io-error ; -M: epoll-mx register-io-task ( task mx -- ) - [ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ; +: do-epoll-add ( fd mx events -- ) + EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ; -M: epoll-mx unregister-io-task ( task mx -- ) - [ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ; +: do-epoll-del ( fd mx events -- ) + EPOLL_CTL_DEL swap do-epoll-ctl ; -: wait-event ( mx timeout -- n ) - >r { mx-fd epoll-mx-events } get-slots max-events - r> epoll_wait dup multiplexer-error ; +M: epoll-mx add-input-callback ( thread fd mx -- ) + [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ; -: epoll-read-task ( mx fd -- ) - over mx-reads at* [ perform-io-task ] [ 2drop ] if ; +M: epoll-mx add-output-callback ( thread fd mx -- ) + [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ; -: epoll-write-task ( mx fd -- ) - over mx-writes at* [ perform-io-task ] [ 2drop ] if ; +M: epoll-mx remove-input-callbacks ( fd mx -- seq ) + 2dup reads>> key? [ + [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi + ] [ 2drop f ] if ; -: handle-event ( mx kevent -- ) - epoll-event-fd 2dup epoll-read-task epoll-write-task ; +M: epoll-mx remove-output-callbacks ( fd mx -- seq ) + 2dup writes>> key? [ + [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi + ] [ 2drop f ] if ; + +: wait-event ( mx us -- n ) + [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi* + epoll_wait dup multiplexer-error ; + +: handle-event ( event mx -- ) + [ epoll-event-fd ] dip + [ EPOLLIN EPOLLOUT bitor do-epoll-del ] + [ input-available ] [ output-available ] 2tri ; : handle-events ( mx n -- ) - [ - over epoll-mx-events epoll-event-nth handle-event - ] with each ; + [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ; -M: epoll-mx wait-for-events ( ms mx -- ) - dup rot wait-event handle-events ; +M: epoll-mx wait-for-events ( us mx -- ) + swap 60000000 or dupd wait-event handle-events ; diff --git a/basis/io/unix/files/macosx/macosx.factor b/basis/io/unix/files/macosx/macosx.factor index 322358ba14..397145c9ae 100644 --- a/basis/io/unix/files/macosx/macosx.factor +++ b/basis/io/unix/files/macosx/macosx.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.strings combinators grouping io.encodings.utf8 io.files kernel math sequences -system unix io.unix.files +system unix io.unix.files specialized-arrays.direct.uint arrays unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx ; IN: io.unix.files.macosx @@ -33,7 +33,7 @@ M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-i [ statfs64-f_bavail >>blocks-available ] [ statfs64-f_files >>files ] [ statfs64-f_ffree >>files-free ] - [ statfs64-f_fsid >>id ] + [ statfs64-f_fsid 2 >array >>id ] [ statfs64-f_owner >>owner ] [ statfs64-f_type >>type-id ] [ statfs64-f_flags >>flags ] 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/linux/linux.factor b/basis/io/unix/linux/linux.factor index e75f4c5f6b..be5b83f1b0 100644 --- a/basis/io/unix/linux/linux.factor +++ b/basis/io/unix/linux/linux.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.backend io.monitors io.unix.backend -io.unix.select io.unix.linux.monitors system namespaces ; +io.unix.epoll io.unix.linux.monitors system namespaces ; IN: io.unix.linux M: linux init-io ( -- ) - mx set-global ; + mx set-global ; linux set-io-backend 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/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 894ddc83c6..664727dbdb 100755 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -5,7 +5,7 @@ io.encodings.utf16n io.ports io.windows kernel math splitting fry alien.strings windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces make words symbols system destructors accessors math.bitwise continuations -windows.errors arrays byte-arrays ; +windows.errors arrays byte-arrays generalizations ; IN: io.windows.files : open-file ( path access-mode create-mode flags -- handle ) @@ -117,7 +117,7 @@ M: windows delete-directory ( path -- ) : find-first-file ( path -- WIN32_FIND_DATA handle ) "WIN32_FIND_DATA" tuck FindFirstFile - [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep ; + [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ; : find-next-file ( path -- WIN32_FIND_DATA/f ) "WIN32_FIND_DATA" tuck @@ -257,13 +257,15 @@ M: winnt link-info ( path -- info ) HOOK: root-directory os ( string -- string' ) -: file-system-type ( normalized-path -- str ) - MAX_PATH 1+ - MAX_PATH 1+ - "DWORD" "DWORD" "DWORD" - MAX_PATH 1+ - MAX_PATH 1+ - [ GetVolumeInformation win32-error=0/f ] 2keep drop +: volume-information ( normalized-path -- volume-name volume-serial max-component flags type ) + MAX_PATH 1+ [ ] keep + "DWORD" + "DWORD" + "DWORD" + MAX_PATH 1+ [ ] keep + [ GetVolumeInformation win32-error=0/f ] 7 nkeep + drop 5 nrot drop + [ utf16n alien>string ] 4 ndip utf16n alien>string ; : file-system-space ( normalized-path -- available-space total-space free-space ) @@ -278,14 +280,20 @@ HOOK: root-directory os ( string -- string' ) [ ] } cleave ; +TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ; + M: winnt file-system-info ( path -- file-system-info ) normalize-path root-directory - dup [ file-system-type ] [ file-system-space ] bi - \ file-system-info new + dup [ volume-information ] [ file-system-space ] bi + \ win32-file-system-info new swap *ulonglong >>free-space swap *ulonglong >>total-space swap *ulonglong >>available-space swap >>type + swap *uint >>flags + swap *uint >>max-component + swap *uint >>device-serial + swap >>device-name swap >>mount-point calculate-file-system-info ; @@ -299,16 +307,16 @@ M: winnt file-system-info ( path -- file-system-info ) ] if ; : find-first-volume ( -- string handle ) - MAX_PATH 1+ dup length + MAX_PATH 1+ [ ] keep dupd FindFirstVolume dup win32-error=0/f [ utf16n alien>string ] dip ; : find-next-volume ( handle -- string/f ) - MAX_PATH 1+ dup length - over [ FindNextVolume ] dip swap 0 = [ + MAX_PATH 1+ [ tuck ] keep + FindNextVolume 0 = [ GetLastError ERROR_NO_MORE_FILES = - [ drop f ] [ win32-error ] if + [ drop f ] [ win32-error-string throw ] if ] [ utf16n alien>string ] if ; diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 95ad264000..f60403055e 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -82,7 +82,6 @@ t display-stacks? set-global : stacks. ( -- ) display-stacks? get [ datastack [ nl "--- Data stack:" title. stack. ] unless-empty - retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ] when ; : prompt. ( -- ) 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/specialized-arrays/double/double.factor b/basis/specialized-arrays/double/double.factor index 0501458532..02e47ca140 100644 --- a/basis/specialized-arrays/double/double.factor +++ b/basis/specialized-arrays/double/double.factor @@ -9,6 +9,8 @@ USING: hints math.vectors arrays kernel math accessors sequences ; HINTS: { 2 } { 3 } ; +HINTS: (double-array) { 2 } { 3 } ; + HINTS: vneg { array } { double-array } ; HINTS: v*n { array object } { double-array float } ; HINTS: n*v { array object } { float double-array } ; diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 2894649428..579da5b84a 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -10,10 +10,14 @@ ERROR: bad-byte-array-length byte-array type ; M: bad-byte-array-length summary drop "Byte array length doesn't divide type width" ; +: (c-array) ( n c-type -- array ) + heap-size * (byte-array) ; inline + FUNCTOR: define-array ( T -- ) A DEFINES ${T}-array DEFINES <${A}> +(A) DEFINES (${A}) >A DEFINES >${A} byte-array>A DEFINES byte-array>${A} A{ DEFINES ${A}{ @@ -29,6 +33,8 @@ TUPLE: A : ( n -- specialized-array ) dup T A boa ; inline +: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline + : byte-array>A ( byte-array -- specialized-array ) dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless swap A boa ; inline @@ -45,7 +51,7 @@ M: A set-nth-unsafe underlying>> SET-NTH call ; M: A like drop dup A instance? [ >A execute ] unless ; -M: A new-sequence drop execute ; +M: A new-sequence drop (A) execute ; M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index a998e5394b..bce42f1456 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -480,6 +480,9 @@ M: object infer-call* \ { integer } { byte-array } define-primitive \ make-flushable +\ (byte-array) { integer } { byte-array } define-primitive +\ (byte-array) make-flushable + \ { integer c-ptr } { c-ptr } define-primitive \ make-flushable diff --git a/basis/tools/files/files-tests.factor b/basis/tools/files/files-tests.factor index 4dc4ef23f0..6cbc7d192c 100644 --- a/basis/tools/files/files-tests.factor +++ b/basis/tools/files/files-tests.factor @@ -7,5 +7,4 @@ IN: tools.files.tests [ ] [ "" directory. ] unit-test -[ ] -[ { device-name free-space used-space total-space percent-used } file-systems. ] unit-test +[ ] [ file-systems. ] unit-test diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index a8ce9c9554..7968639d47 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -41,9 +41,9 @@ percent-used percent-free ; : file-system-spec ( file-system-info obj -- str ) { - { device-name [ device-name>> ] } - { mount-point [ mount-point>> ] } - { type [ type>> ] } + { device-name [ device-name>> [ "" ] unless* ] } + { mount-point [ mount-point>> [ "" ] unless* ] } + { type [ type>> [ "" ] unless* ] } { available-space [ available-space>> [ 0 ] unless* ] } { free-space [ free-space>> [ 0 ] unless* ] } { used-space [ used-space>> [ 0 ] unless* ] } @@ -58,10 +58,14 @@ percent-used percent-free ; : file-systems-info ( spec -- seq ) file-systems swap '[ _ [ file-system-spec ] with map ] map ; -: file-systems. ( spec -- ) +: print-file-systems ( spec -- ) [ file-systems-info ] [ [ unparse ] map ] bi prefix simple-table. ; +: file-systems. ( -- ) + { device-name free-space used-space total-space percent-used mount-point } + print-file-systems ; + { { [ os unix? ] [ "tools.files.unix" ] } { [ os windows? ] [ "tools.files.windows" ] } 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/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 27358b53fc..8915d2d611 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.filter arrays accessors -generic generic.standard definitions make ; +generic generic.standard definitions make sbufs ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -147,6 +147,7 @@ SYMBOL: +stopped+ { (call-next-method) [ (step-into-call-next-method) ] } } [ "step-into" set-word-prop ] assoc-each +! Never step into these words { >n ndrop >c c> continue continue-with 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/basis/unix/linux/epoll/epoll.factor b/basis/unix/linux/epoll/epoll.factor index c18fa2ee6c..72935807c3 100644 --- a/basis/unix/linux/epoll/epoll.factor +++ b/basis/unix/linux/epoll/epoll.factor @@ -18,14 +18,15 @@ FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int tim : EPOLL_CTL_DEL 2 ; inline ! Remove a file decriptor from the interface. : EPOLL_CTL_MOD 3 ; inline ! Change file decriptor epoll_event structure. -: EPOLLIN HEX: 001 ; inline -: EPOLLPRI HEX: 002 ; inline -: EPOLLOUT HEX: 004 ; inline -: EPOLLRDNORM HEX: 040 ; inline -: EPOLLRDBAND HEX: 080 ; inline -: EPOLLWRNORM HEX: 100 ; inline -: EPOLLWRBAND HEX: 200 ; inline -: EPOLLMSG HEX: 400 ; inline -: EPOLLERR HEX: 008 ; inline -: EPOLLHUP HEX: 010 ; inline -: EPOLLET 31 2^ ; inline +: EPOLLIN HEX: 001 ; inline +: EPOLLPRI HEX: 002 ; inline +: EPOLLOUT HEX: 004 ; inline +: EPOLLRDNORM HEX: 040 ; inline +: EPOLLRDBAND HEX: 080 ; inline +: EPOLLWRNORM HEX: 100 ; inline +: EPOLLWRBAND HEX: 200 ; inline +: EPOLLMSG HEX: 400 ; inline +: EPOLLERR HEX: 008 ; inline +: EPOLLHUP HEX: 010 ; inline +: EPOLLONESHOT 30 2^ ; inline +: EPOLLET 31 2^ ; inline diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 662d667485..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" @@ -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/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index cc05efc46e..6cc97531a4 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -468,6 +468,7 @@ tuple { "dlsym" "alien" } { "dlclose" "alien" } { "" "byte-arrays" } + { "(byte-array)" "byte-arrays" } { "" "alien" } { "alien-signed-cell" "alien.accessors" } { "set-alien-signed-cell" "alien.accessors" } diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index 07b82f6111..edaea108a1 100644 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -1,7 +1,10 @@ IN: byte-arrays.tests -USING: tools.test byte-arrays ; +USING: tools.test byte-arrays sequences kernel ; -[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test +[ 6 B{ 1 2 3 } ] [ + 6 B{ 1 2 3 } resize-byte-array + [ length ] [ 3 head ] bi +] unit-test [ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index f981e758d7..f0d188ce4a 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -9,7 +9,7 @@ M: byte-array length length>> ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline -M: byte-array new-sequence drop ; +M: byte-array new-sequence drop (byte-array) ; M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; 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/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 0b3e0003ac..7354759bb6 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1,6 +1,6 @@ USING: arrays help.markup help.syntax math sequences.private vectors strings kernel math.order layouts -quotations ; +quotations generic.standard ; IN: sequences HELP: sequence @@ -14,8 +14,8 @@ HELP: length HELP: set-length { $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } } -{ $contract "Resizes the sequence. Not all sequences are resizable." } -{ $errors "Throws a " { $link bounds-error } " if the new length is negative." } +{ $contract "Resizes a sequence. The initial contents of the new area is undefined." } +{ $errors "Throws a " { $link no-method } " error if the sequence is not resizable, and a " { $link bounds-error } " if the new length is negative." } { $side-effects "seq" } ; HELP: lengthen @@ -59,7 +59,7 @@ HELP: immutable HELP: new-sequence { $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } } -{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ; +{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } ". The initial contents of the sequence are undefined." } ; HELP: new-resizable { $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 8c9eff94f5..e364359928 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -845,9 +845,10 @@ PRIVATE> USE: arrays : array-length ( array -- len ) - { array } declare length>> ; + { array } declare length>> ; inline : array-flip ( matrix -- newmatrix ) + { array } declare [ dup first array-length [ array-length min ] reduce ] keep [ [ array-nth ] with { } map-as ] curry { } map-as ; diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index a1e892229a..9afd211876 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -6,8 +6,10 @@ continuations debugger math ; IN: benchmark : run-benchmark ( vocab -- result ) - [ [ require ] [ [ run ] benchmark ] bi ] curry - [ error. f ] recover ; + [ "=== " write vocab-name print flush ] [ + [ [ require ] [ [ run ] benchmark ] bi ] curry + [ error. f ] recover + ] bi ; : run-benchmarks ( -- assoc ) "benchmark" all-child-vocabs-seq 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/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/primitives.c b/vm/primitives.c index a01a8653b7..dcf082d40d 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -74,6 +74,7 @@ void *primitives[] = { primitive_dlsym, primitive_dlclose, primitive_byte_array, + primitive_uninitialized_byte_array, primitive_displaced_alien, primitive_alien_signed_cell, primitive_set_alien_signed_cell, diff --git a/vm/types.c b/vm/types.c index 1afbcd3a40..c9e657f8ee 100755 --- a/vm/types.c +++ b/vm/types.c @@ -243,6 +243,12 @@ void primitive_byte_array(void) dpush(tag_object(allot_byte_array(size))); } +void primitive_uninitialized_byte_array(void) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_byte_array_internal(size))); +} + F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) { CELL to_copy = array_capacity(array); @@ -250,7 +256,7 @@ F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) to_copy = capacity; REGISTER_UNTAGGED(array); - F_BYTE_ARRAY *new_array = allot_byte_array(capacity); + F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); UNREGISTER_UNTAGGED(array); memcpy(new_array + 1,array + 1,to_copy); diff --git a/vm/types.h b/vm/types.h index ba8d9689fe..5850489a4c 100755 --- a/vm/types.h +++ b/vm/types.h @@ -116,6 +116,7 @@ void primitive_tuple(void); void primitive_tuple_boa(void); void primitive_tuple_layout(void); void primitive_byte_array(void); +void primitive_uninitialized_byte_array(void); void primitive_clone(void); F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); @@ -125,6 +126,7 @@ void primitive_resize_byte_array(void); F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); +void primitive_uninitialized_string(void); void primitive_string(void); F_STRING *reallot_string(F_STRING *string, CELL capacity); void primitive_resize_string(void);