Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
dffb8c961b
basis
compiler/tree
debugger
propagation/inlining
cpu/x86
io/unix
locals
logging/analysis
tools/memory
unix/kqueue
core
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 >>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -229,7 +229,7 @@ ARTICLE: "db-protocol" "Low-level database protocol"
|
|||
{ $subsection db-open }
|
||||
"Closing a database:"
|
||||
{ $subsection db-close }
|
||||
"Creating tatements:"
|
||||
"Creating statements:"
|
||||
{ $subsection <simple-statement> }
|
||||
{ $subsection <prepared-statement> }
|
||||
"Using statements with the database:"
|
||||
|
|
|
|||
|
|
@ -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 ] [
|
||||
|
|
|
|||
|
|
@ -2,10 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types combinators io.unix.backend
|
||||
kernel math.bitwise sequences struct-arrays unix unix.kqueue
|
||||
unix.time ;
|
||||
unix.time assocs ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
TUPLE: kqueue-mx < mx events monitors ;
|
||||
TUPLE: kqueue-mx < mx events ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
|
|
@ -14,7 +14,6 @@ TUPLE: kqueue-mx < mx events monitors ;
|
|||
|
||||
: <kqueue-mx> ( -- mx )
|
||||
kqueue-mx new-mx
|
||||
H{ } clone >>monitors
|
||||
kqueue dup io-error >>fd
|
||||
max-events "kevent" <struct-array> >>events ;
|
||||
|
||||
|
|
@ -35,30 +34,25 @@ M: kqueue-mx add-input-callback ( thread fd mx -- )
|
|||
|
||||
M: kqueue-mx add-output-callback ( thread fd mx -- )
|
||||
[ call-next-method ] [
|
||||
[ EVFILT_WRITE EV_DELETE make-kevent ] dip
|
||||
[ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
|
||||
register-kevent
|
||||
] 2bi ;
|
||||
|
||||
: cancel-input-callbacks ( fd mx -- seq )
|
||||
[
|
||||
[ 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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,6 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.unix.macosx
|
||||
USING: io.unix.bsd io.backend system ;
|
||||
USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend
|
||||
namespaces system ;
|
||||
|
||||
M: macosx init-io ( -- )
|
||||
<kqueue-mx> mx set-global ;
|
||||
|
||||
macosx set-io-backend
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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 >>
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -197,7 +197,7 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
|
|||
|
||||
ARTICLE: "tuple-examples" "Tuple examples"
|
||||
"An example:"
|
||||
{ $code "TUPLE: employee name salary position ;" }
|
||||
{ $code "TUPLE: employee name position salary ;" }
|
||||
"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
|
||||
{ $table
|
||||
{ "Reader" "Writer" "Setter" "Changer" }
|
||||
|
|
@ -237,7 +237,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
" checks counter check boa ;"
|
||||
""
|
||||
": biweekly-paycheck ( employee -- check )"
|
||||
" dup name>> swap salary>> 26 / <check> ;"
|
||||
" [ name>> ] [ salary>> 26 / ] bi <check> ;"
|
||||
}
|
||||
"An example of using a changer:"
|
||||
{ $code
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
! <PRIVATE
|
||||
! Evaluation status:
|
||||
|
||||
TUPLE: fuel-status in use ds? ;
|
||||
TUPLE: fuel-status in use ds? restarts ;
|
||||
|
||||
SYMBOL: fuel-status-stack
|
||||
V{ } clone fuel-status-stack set-global
|
||||
|
||||
: push-fuel-status ( -- )
|
||||
in get use get clone display-stacks? get
|
||||
fuel-status boa
|
||||
fuel-status-stack get push ;
|
||||
|
||||
: pop-fuel-status ( -- )
|
||||
fuel-status-stack get empty? [
|
||||
fuel-status-stack get pop
|
||||
[ in>> in set ]
|
||||
[ use>> clone use set ]
|
||||
[ ds?>> display-stacks? swap [ on ] [ off ] if ] tri
|
||||
] unless ;
|
||||
|
||||
SYMBOL: fuel-eval-result
|
||||
f clone fuel-eval-result set-global
|
||||
|
||||
SYMBOL: fuel-eval-output
|
||||
f clone fuel-eval-result set-global
|
||||
|
||||
! PRIVATE>
|
||||
SYMBOL: fuel-eval-res-flag
|
||||
t clone fuel-eval-res-flag set-global
|
||||
|
||||
: fuel-eval-restartable? ( -- ? )
|
||||
fuel-eval-res-flag get-global ; inline
|
||||
|
||||
: fuel-eval-restartable ( -- )
|
||||
t fuel-eval-res-flag set-global ; inline
|
||||
|
||||
: fuel-eval-non-restartable ( -- )
|
||||
f fuel-eval-res-flag set-global ; inline
|
||||
|
||||
: push-fuel-status ( -- )
|
||||
in get use get clone display-stacks? get restarts get-global clone
|
||||
fuel-status boa
|
||||
fuel-status-stack get push ;
|
||||
|
||||
: pop-fuel-status ( -- )
|
||||
fuel-status-stack get empty? [
|
||||
fuel-status-stack get pop {
|
||||
[ in>> in set ]
|
||||
[ use>> clone use set ]
|
||||
[ ds?>> display-stacks? swap [ on ] [ off ] if ]
|
||||
[
|
||||
restarts>> fuel-eval-restartable? [ drop ] [
|
||||
clone restarts set-global
|
||||
] if
|
||||
]
|
||||
} cleave
|
||||
] unless ;
|
||||
|
||||
|
||||
! Lispy pretty printing
|
||||
|
||||
GENERIC: fuel-pprint ( obj -- )
|
||||
|
||||
M: object fuel-pprint pprint ;
|
||||
M: object fuel-pprint pprint ; inline
|
||||
|
||||
M: f fuel-pprint drop "nil" write ;
|
||||
M: f fuel-pprint drop "nil" write ; inline
|
||||
|
||||
M: integer fuel-pprint pprint ;
|
||||
M: integer fuel-pprint pprint ; inline
|
||||
|
||||
M: string fuel-pprint pprint ;
|
||||
M: string fuel-pprint pprint ; inline
|
||||
|
||||
M: sequence fuel-pprint
|
||||
dup empty? [ drop f fuel-pprint ] [
|
||||
|
|
@ -53,12 +73,30 @@ M: sequence fuel-pprint
|
|||
")" write
|
||||
] if ;
|
||||
|
||||
M: tuple fuel-pprint tuple>array fuel-pprint ;
|
||||
M: tuple fuel-pprint tuple>array fuel-pprint ; inline
|
||||
|
||||
M: continuation fuel-pprint drop "~continuation~" write ;
|
||||
M: continuation fuel-pprint drop ":continuation" write ; inline
|
||||
|
||||
M: restart fuel-pprint name>> fuel-pprint ; inline
|
||||
|
||||
SYMBOL: :restarts
|
||||
|
||||
: fuel-restarts ( obj -- seq )
|
||||
compute-restarts :restarts prefix ; inline
|
||||
|
||||
M: condition fuel-pprint
|
||||
[ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
|
||||
|
||||
M: source-file-error fuel-pprint
|
||||
[ file>> ] [ error>> ] bi 2array source-file-error prefix
|
||||
fuel-pprint ;
|
||||
|
||||
M: source-file fuel-pprint path>> fuel-pprint ;
|
||||
|
||||
! Evaluation vocabulary
|
||||
|
||||
: fuel-eval-set-result ( obj -- )
|
||||
clone fuel-eval-result set-global ;
|
||||
clone fuel-eval-result set-global ; inline
|
||||
|
||||
: fuel-retort ( -- )
|
||||
error get
|
||||
|
|
@ -66,33 +104,34 @@ M: continuation fuel-pprint drop "~continuation~" write ;
|
|||
fuel-eval-output get-global
|
||||
3array fuel-pprint ;
|
||||
|
||||
: fuel-forget-error ( -- )
|
||||
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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -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." } ;
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: sequences kernel arrays vectors accessors assocs sorting math math.functions ;
|
||||
|
||||
IN: math.binpack
|
||||
|
||||
: (binpack) ( bins item -- )
|
||||
[ [ values sum ] map ] keep
|
||||
zip sort-keys values first push ;
|
||||
|
||||
: binpack ( assoc n -- bins )
|
||||
[ sort-values <reversed> dup length ] dip
|
||||
tuck / ceiling <array> [ <vector> ] map
|
||||
tuck [ (binpack) ] curry each ;
|
||||
|
||||
: binpack* ( items n -- bins )
|
||||
[ dup zip ] dip binpack [ keys ] map ;
|
||||
|
||||
: binpack! ( items quot n -- bins )
|
||||
[ dupd map zip ] dip binpack [ keys ] map ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Bin-packing algorithms.
|
||||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -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"
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: kernel time tools.test calendar ;
|
||||
|
||||
IN: time.tests
|
||||
|
||||
[ "%H:%M:%S" strftime ] must-infer
|
||||
|
||||
: testtime ( -- timestamp )
|
||||
2008 10 9 12 3 15 instant <timestamp> ;
|
||||
|
||||
[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
|
||||
[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
|
||||
|
||||
[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
|
||||
[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
|
||||
|
||||
[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
|
||||
[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
|
||||
|
||||
[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
|
||||
[ t ] [ "October" testtime "%B" strftime = ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors arrays calendar io kernel fry macros math
|
||||
math.functions math.parser peg.ebnf sequences strings vectors ;
|
||||
|
||||
IN: time
|
||||
|
||||
: >timestring ( timestamp -- string )
|
||||
[ hour>> ] keep [ minute>> ] keep second>> 3array
|
||||
[ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline
|
||||
|
||||
: >datestring ( timestamp -- string )
|
||||
[ month>> ] keep [ day>> ] keep year>> 3array
|
||||
[ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline
|
||||
|
||||
: (week-of-year) ( timestamp day -- n )
|
||||
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
|
||||
[ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
|
||||
|
||||
: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
|
||||
|
||||
: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline
|
||||
|
||||
|
||||
<PRIVATE
|
||||
|
||||
EBNF: parse-format-string
|
||||
|
||||
fmt-% = "%" => [[ [ "%" ] ]]
|
||||
fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]]
|
||||
fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
|
||||
fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
|
||||
fmt-B = "B" => [[ [ dup month>> month-name ] ]]
|
||||
fmt-c = "c" => [[ [ "Not yet implemented" throw ] ]]
|
||||
fmt-d = "d" => [[ [ dup day>> number>string 2 CHAR: 0 pad-left ] ]]
|
||||
fmt-H = "H" => [[ [ dup hour>> number>string 2 CHAR: 0 pad-left ] ]]
|
||||
fmt-I = "I" => [[ [ dup hour>> 12 > [ 12 - ] when number>string 2 CHAR: 0 pad-left ] ]]
|
||||
fmt-j = "j" => [[ [ dup day-of-year number>string ] ]]
|
||||
fmt-m = "m" => [[ [ dup month>> number>string 2 CHAR: 0 pad-left ] ]]
|
||||
fmt-M = "M" => [[ [ dup minute>> number>string 2 CHAR: 0 pad-left ] ]]
|
||||
fmt-p = "p" => [[ [ dup hour>> 12 < [ "AM" ] [ "PM" ] ? ] ]]
|
||||
fmt-S = "S" => [[ [ dup second>> round number>string 2 CHAR: 0 pad-left ] ]]
|
||||
fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]]
|
||||
fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
|
||||
fmt-W = "W" => [[ [ dup week-of-year-monday ] ]]
|
||||
fmt-x = "x" => [[ [ dup >datestring ] ]]
|
||||
fmt-X = "X" => [[ [ dup >timestring ] ]]
|
||||
fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]]
|
||||
fmt-Y = "Y" => [[ [ dup year>> number>string ] ]]
|
||||
fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
|
||||
unknown = (.)* => [[ "Unknown directive" throw ]]
|
||||
|
||||
formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
|
||||
fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|
|
||||
fmt-X|fmt-y|fmt-Y|fmt-Z|unknown
|
||||
|
||||
formats = "%" (formats_) => [[ second '[ _ dip ] ]]
|
||||
|
||||
plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
|
||||
|
||||
text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
|
||||
|
||||
;EBNF
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: strftime ( format-string -- )
|
||||
parse-format-string [ length ] keep [ ] join
|
||||
'[ _ <vector> @ reverse concat nip ] ;
|
||||
|
||||
|
||||
|
|
@ -47,18 +47,29 @@ M-x customize-group fuel will show you how many.
|
|||
Quick key reference
|
||||
-------------------
|
||||
|
||||
(Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
|
||||
the same as C-cz)).
|
||||
|
||||
* In factor files:
|
||||
|
||||
- C-cz : switch to listener
|
||||
- C-co : cycle between code, tests and docs factor files
|
||||
|
||||
- M-. : edit word at point in Emacs
|
||||
- M-. : edit word at point in Emacs (also in listener)
|
||||
|
||||
- C-cr, C-cC-er : eval region
|
||||
- C-M-r, C-cC-ee : eval region, extending it to definition boundaries
|
||||
- C-M-x, C-cC-ex : eval definition around point
|
||||
- C-ck, C-cC-ek : compile file
|
||||
|
||||
- C-cC-da : toggle autodoc mode
|
||||
- C-cC-dd : help for word at point
|
||||
- C-cC-ds : short help word at point
|
||||
|
||||
Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
|
||||
the same as C-cz).
|
||||
* In the debugger (it pops up upon eval/compilation errors):
|
||||
|
||||
- g : go to error
|
||||
- <digit> : invoke nth restart
|
||||
- q : bury buffer
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -59,6 +59,23 @@ code in the buffer."
|
|||
:type 'hook
|
||||
:group 'factor-mode)
|
||||
|
||||
|
||||
;;; Faces:
|
||||
|
||||
(fuel-font-lock--define-faces
|
||||
factor-font-lock font-lock factor-mode
|
||||
((comment comment "comments")
|
||||
(constructor type "constructors (<foo>)")
|
||||
(declaration keyword "declaration words")
|
||||
(parsing-word keyword "parsing words")
|
||||
(setter-word function-name "setter words (>>foo)")
|
||||
(stack-effect comment "stack effect specifications")
|
||||
(string string "strings")
|
||||
(symbol variable-name "name of symbol being defined")
|
||||
(type-name type "type names")
|
||||
(vocabulary-name constant "vocabulary names")
|
||||
(word function-name "word, generic or method being defined")))
|
||||
|
||||
|
||||
;;; Syntax table:
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,266 @@
|
|||
;;; fuel-debug.el -- debugging factor code
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Sun Dec 07, 2008 04:16
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; A mode for displaying the results of run-file and evaluation, with
|
||||
;; support for restarts.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-base)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-font-lock)
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
(defgroup fuel-debug nil
|
||||
"Major mode for interaction with the Factor debugger"
|
||||
:group 'fuel)
|
||||
|
||||
(defcustom fuel-debug-mode-hook nil
|
||||
"Hook run after `fuel-debug-mode' activates"
|
||||
:group 'fuel-debug
|
||||
:type 'hook)
|
||||
|
||||
(defcustom fuel-debug-show-short-help t
|
||||
"Whether to show short help on available keys in debugger"
|
||||
:group 'fuel-debug
|
||||
:type 'boolean)
|
||||
|
||||
(fuel-font-lock--define-faces
|
||||
fuel-debug-font-lock font-lock fuel-debug
|
||||
((error warning "highlighting errors")
|
||||
(line variable-name "line numbers in errors/warnings")
|
||||
(column variable-name "column numbers in errors/warnings")
|
||||
(info comment "information headers")
|
||||
(restart-number warning "restart numbers")
|
||||
(restart-name function-name "restart names")))
|
||||
|
||||
|
||||
;;; Font lock and other pattern matching:
|
||||
|
||||
(defconst fuel-debug--compiler-info-alist
|
||||
'((":warnings" . ?w) (":errors" . ?e) (":linkage" . ?l)))
|
||||
|
||||
(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"")
|
||||
(defconst fuel-debug--error-line-regex "\\([0-9]+\\):")
|
||||
(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$")
|
||||
|
||||
(defconst fuel-debug--error-regex
|
||||
(format "%s\n%s"
|
||||
fuel-debug--error-file-regex
|
||||
fuel-debug--error-line-regex))
|
||||
|
||||
(defconst fuel-debug--compiler-info-regex
|
||||
(format "^\\(%s\\) "
|
||||
(regexp-opt (mapcar 'car fuel-debug--compiler-info-alist))))
|
||||
|
||||
(defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)")
|
||||
|
||||
(defconst fuel-debug--font-lock-keywords
|
||||
`((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error)
|
||||
(,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line)
|
||||
(,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column)
|
||||
(,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number)
|
||||
(2 'fuel-debug-font-lock-restart-name))
|
||||
(,fuel-debug--compiler-info-regex 1 'fuel-debug-font-lock-restart-number)
|
||||
("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info)
|
||||
("^Error: " . 'fuel-debug-font-lock-error)))
|
||||
|
||||
(defun fuel-debug--font-lock-setup ()
|
||||
(set (make-local-variable 'font-lock-defaults)
|
||||
'(fuel-debug--font-lock-keywords t nil nil nil)))
|
||||
|
||||
|
||||
;;; Debug buffer:
|
||||
|
||||
(defvar fuel-debug--buffer nil)
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--last-ret nil))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--file nil))
|
||||
|
||||
(defun fuel-debug--buffer ()
|
||||
(or (and (buffer-live-p fuel-debug--buffer) fuel-debug--buffer)
|
||||
(with-current-buffer
|
||||
(setq fuel-debug--buffer (get-buffer-create "*fuel dbg*"))
|
||||
(fuel-debug-mode)
|
||||
(current-buffer))))
|
||||
|
||||
(defun fuel-debug--display-retort (ret &optional success-msg no-pop file)
|
||||
(let ((err (fuel-eval--retort-error ret))
|
||||
(inhibit-read-only t))
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
(erase-buffer)
|
||||
(fuel-debug--display-output ret)
|
||||
(delete-blank-lines)
|
||||
(newline)
|
||||
(when (and (not err) success-msg)
|
||||
(message "%s" success-msg)
|
||||
(insert "\n" success-msg "\n"))
|
||||
(when err
|
||||
(fuel-debug--display-restarts err)
|
||||
(delete-blank-lines)
|
||||
(newline)
|
||||
(let ((hstr (fuel-debug--help-string err file)))
|
||||
(if fuel-debug-show-short-help
|
||||
(insert "-----------\n" hstr "\n")
|
||||
(message "%s" hstr))))
|
||||
(setq fuel-debug--last-ret ret)
|
||||
(setq fuel-debug--file file)
|
||||
(goto-char (point-max))
|
||||
(when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))
|
||||
(not err))))
|
||||
|
||||
(defun fuel-debug--display-output (ret)
|
||||
(let* ((last (fuel-eval--retort-output fuel-debug--last-ret))
|
||||
(current (fuel-eval--retort-output ret))
|
||||
(llen (length last))
|
||||
(clen (length current))
|
||||
(trail (and last (substring-no-properties last (/ llen 2))))
|
||||
(err (fuel-eval--retort-error ret))
|
||||
(p (point)))
|
||||
(save-excursion (insert current))
|
||||
(when (and (> clen llen) (> llen 0) (search-forward trail nil t))
|
||||
(delete-region p (point)))
|
||||
(goto-char (point-max))
|
||||
(when err
|
||||
(insert (format "\nError: %S\n\n" (fuel-eval--error-name err))))))
|
||||
|
||||
(defun fuel-debug--display-restarts (err)
|
||||
(let* ((rs (fuel-eval--error-restarts err))
|
||||
(rsn (length rs)))
|
||||
(when rs
|
||||
(insert "Restarts:\n\n")
|
||||
(dotimes (n rsn)
|
||||
(insert (format ":%s %s\n" (1+ n) (nth n rs))))
|
||||
(newline))))
|
||||
|
||||
(defun fuel-debug--help-string (err &optional file)
|
||||
(format "Press %s%s%sq bury buffer"
|
||||
(if (or file (fuel-eval--error-file err)) "g go to file, " "")
|
||||
(let ((rsn (length (fuel-eval--error-restarts err))))
|
||||
(cond ((zerop rsn) "")
|
||||
((= 1 rsn) "1 invoke restart, ")
|
||||
(t (format "1-%s invoke restarts, " rsn))))
|
||||
(let ((str ""))
|
||||
(dolist (ci fuel-debug--compiler-info-alist str)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(when (search-forward (car ci) nil t)
|
||||
(setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))))
|
||||
|
||||
(defun fuel-debug--buffer-file ()
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
(or fuel-debug--file
|
||||
(and fuel-debug--last-ret
|
||||
(fuel-eval--error-file
|
||||
(fuel-eval--retort-error fuel-debug--last-ret))))))
|
||||
|
||||
(defsubst fuel-debug--buffer-error ()
|
||||
(fuel-eval--retort-error fuel-debug--last-ret))
|
||||
|
||||
(defsubst fuel-debug--buffer-restarts ()
|
||||
(fuel-eval--error-restarts (fuel-debug--buffer-error)))
|
||||
|
||||
|
||||
;;; Buffer navigation:
|
||||
|
||||
(defun fuel-debug-goto-error ()
|
||||
(interactive)
|
||||
(let* ((err (or (fuel-debug--buffer-error)
|
||||
(error "No errors reported")))
|
||||
(file (or (fuel-debug--buffer-file)
|
||||
(error "No file associated with error")))
|
||||
(l/c (fuel-eval--error-line/column err))
|
||||
(line (or (car l/c) 1))
|
||||
(col (or (cdr l/c) 0)))
|
||||
(find-file-other-window file)
|
||||
(goto-line line)
|
||||
(forward-char col)))
|
||||
|
||||
(defun fuel-debug--read-restart-no ()
|
||||
(let ((rs (fuel-debug--buffer-restarts)))
|
||||
(unless rs (error "No restarts available"))
|
||||
(let* ((rsn (length rs))
|
||||
(prompt (format "Restart number? (1-%s): " rsn))
|
||||
(no 0))
|
||||
(while (or (> (setq no (read-number prompt)) rsn)
|
||||
(< no 1)))
|
||||
no)))
|
||||
|
||||
(defun fuel-debug-exec-restart (&optional n confirm)
|
||||
(interactive (list (fuel-debug--read-restart-no)))
|
||||
(let ((n (or n 1))
|
||||
(rs (fuel-debug--buffer-restarts)))
|
||||
(when (zerop (length rs))
|
||||
(error "No restarts available"))
|
||||
(when (or (< n 1) (> n (length rs)))
|
||||
(error "Restart %s not available" n))
|
||||
(when (or (not confirm)
|
||||
(y-or-n-p (format "Invoke restart %s? " n)))
|
||||
(message "Invoking restart %s" n)
|
||||
(let* ((file (fuel-debug--buffer-file))
|
||||
(buffer (if file (find-file-noselect file) (current-buffer))))
|
||||
(with-current-buffer buffer
|
||||
(fuel-debug--display-retort
|
||||
(fuel-eval--eval-string/context (format ":%s" n))
|
||||
(format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
|
||||
|
||||
(defun fuel-debug-show--compiler-info (info)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(unless (re-search-forward (format "^%s" info) nil t)
|
||||
(error "%s information not available" info))
|
||||
(message "Retrieving %s info ..." info)
|
||||
(unless (fuel-debug--display-retort
|
||||
(fuel-eval--eval-string info) "" (fuel-debug--buffer-file))
|
||||
(error "Sorry, no %s info available" info))))
|
||||
|
||||
|
||||
;;; Fuel Debug mode:
|
||||
|
||||
(defvar fuel-debug-mode-map
|
||||
(let ((map (make-keymap)))
|
||||
(suppress-keymap map)
|
||||
(define-key map "g" 'fuel-debug-goto-error)
|
||||
(define-key map "\C-c\C-c" 'fuel-debug-goto-error)
|
||||
(define-key map "n" 'next-line)
|
||||
(define-key map "p" 'previous-line)
|
||||
(define-key map "q" 'bury-buffer)
|
||||
(dotimes (n 9)
|
||||
(define-key map (vector (+ ?1 n))
|
||||
`(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t))))
|
||||
(dolist (ci fuel-debug--compiler-info-alist)
|
||||
(define-key map (vector (cdr ci))
|
||||
`(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci)))))
|
||||
map))
|
||||
|
||||
(defun fuel-debug-mode ()
|
||||
"A major mode for displaying Factor's compilation results and
|
||||
invoking restarts as needed.
|
||||
\\{fuel-debug-mode-map}"
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(setq major-mode 'factor-mode)
|
||||
(setq mode-name "Fuel Debug")
|
||||
(use-local-map fuel-debug-mode-map)
|
||||
(fuel-debug--font-lock-setup)
|
||||
(setq fuel-debug--file nil)
|
||||
(setq fuel-debug--last-ret nil)
|
||||
(toggle-read-only 1)
|
||||
(run-hooks 'fuel-debug-mode-hook))
|
||||
|
||||
|
||||
(provide 'fuel-debug)
|
||||
;;; fuel-debug.el ends here
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 (<foo>)")
|
||||
(declaration keyword "declaration words")
|
||||
(parsing-word keyword "parsing words")
|
||||
(setter-word function-name "setter words (>>foo)")
|
||||
(stack-effect comment "stack effect specifications")
|
||||
(string string "strings")
|
||||
(symbol variable-name "name of symbol being defined")
|
||||
(type-name type "type names")
|
||||
(vocabulary-name constant "vocabulary names")
|
||||
(word function-name "word, generic or method being defined")))))
|
||||
|
||||
(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:
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
Loading…
Reference in New Issue