steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Eduardo Cavazos 2008-12-10 13:55:35 -06:00
parent 22fb541856 d821cd7281
commit 84675ad96d
53 changed files with 993 additions and 445 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/c-types/c-types.factor
View File

@ -204,7 +204,7 @@ M: byte-array byte-length length ;
dup length [ nip malloc dup ] 2keep memcpy ; dup length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array ) : memory>byte-array ( alien len -- byte-array )
[ nip <byte-array> dup ] 2keep memcpy ; [ nip (byte-array) dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- ) : byte-array>memory ( byte-array base -- )
swap dup length memcpy ; swap dup length memcpy ;

6
basis/bootstrap/stage2.factor
View File

@ -100,4 +100,8 @@ SYMBOL: bootstrap-time
"output-image" get save-image-and-exit "output-image" get save-image-and-exit
] if ] if
] [ drop "resource:basis/bootstrap/bootstrap-error.factor" run-file ] recover ] [
drop
load-help? off
"resource:basis/bootstrap/bootstrap-error.factor" run-file
] recover

4
basis/byte-vectors/byte-vectors.factor
View File

@ -10,7 +10,7 @@ TUPLE: byte-vector
{ length array-capacity } ; { length array-capacity } ;
: <byte-vector> ( n -- byte-vector ) : <byte-vector> ( n -- byte-vector )
<byte-array> 0 byte-vector boa ; inline (byte-array) 0 byte-vector boa ; inline
: >byte-vector ( seq -- byte-vector ) : >byte-vector ( seq -- byte-vector )
T{ byte-vector f B{ } 0 } clone-like ; T{ byte-vector f B{ } 0 } clone-like ;
@ -22,7 +22,7 @@ M: byte-vector like
] unless ; ] unless ;
M: byte-vector new-sequence M: byte-vector new-sequence
drop [ <byte-array> ] [ >fixnum ] bi byte-vector boa ; drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;
M: byte-vector equal? M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ; over byte-vector? [ sequence= ] [ 2drop f ] if ;

28
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -54,15 +54,19 @@ IN: compiler.cfg.intrinsics.allot
: bytes>cells ( m -- n ) cell align cell /i ; : bytes>cells ( m -- n ) cell align cell /i ;
:: emit-<byte-array> ( node -- ) : emit-allot-byte-array ( len -- dst )
[let | len [ node node-input-infos first literal>> ] | ds-drop
len expand-<byte-array>? [ dup ^^allot-byte-array
[let | elt [ 0 ^^load-literal ] [ store-length ] [ ds-push ] [ ] tri ;
reg [ len ^^allot-byte-array ] |
ds-drop : emit-(byte-array) ( node -- )
len reg store-length dup node-input-infos first literal>> dup expand-<byte-array>?
elt reg len bytes>cells store-initial-element [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
reg ds-push
] : emit-<byte-array> ( node -- )
] [ node emit-primitive ] if dup node-input-infos first literal>> dup expand-<byte-array>? [
] ; nip
[ 0 ^^load-literal ] dip
[ emit-allot-byte-array ] keep
bytes>cells store-initial-element
] [ drop emit-primitive ] if ;

2
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -52,6 +52,7 @@ IN: compiler.cfg.intrinsics
classes.tuple.private:<tuple-boa> classes.tuple.private:<tuple-boa>
arrays:<array> arrays:<array>
byte-arrays:<byte-array> byte-arrays:<byte-array>
byte-arrays:(byte-array)
math.private:<complex> math.private:<complex>
math.private:<ratio> math.private:<ratio>
kernel:<wrapper> kernel:<wrapper>
@ -139,6 +140,7 @@ IN: compiler.cfg.intrinsics
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] } { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
{ \ arrays:<array> [ emit-<array> iterate-next ] } { \ arrays:<array> [ emit-<array> iterate-next ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] } { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
{ \ math.private:<complex> [ emit-simple-allot iterate-next ] } { \ math.private:<complex> [ emit-simple-allot iterate-next ] }
{ \ math.private:<ratio> [ emit-simple-allot iterate-next ] } { \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] } { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }

4
basis/compiler/tree/debugger/debugger.factor
View File

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

2
basis/compiler/tree/propagation/inlining/inlining.factor
View File

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

3
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -14,12 +14,13 @@ IN: compiler.tree.propagation.slots
UNION: fixed-length-sequence array byte-array string ; UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( word -- ? ) : sequence-constructor? ( word -- ? )
{ <array> <byte-array> <string> } memq? ; { <array> <byte-array> (byte-array) <string> } memq? ;
: constructor-output-class ( word -- class ) : constructor-output-class ( word -- class )
{ {
{ <array> array } { <array> array }
{ <byte-array> byte-array } { <byte-array> byte-array }
{ (byte-array) byte-array }
{ <string> string } { <string> string }
} at ; } at ;

15
basis/cpu/x86/32/bootstrap.factor
View File

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

15
basis/cpu/x86/64/bootstrap.factor
View File

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

4
basis/cpu/x86/64/unix/bootstrap.factor
View File

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

4
basis/cpu/x86/64/winnt/bootstrap.factor
View File

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

434
basis/cpu/x86/bootstrap.factor
View File

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

4
basis/io/unix/backend/backend.factor
View File

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

73
basis/io/unix/epoll/epoll.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.ports io.unix.backend USING: accessors alien.c-types kernel io.ports io.unix.backend
bit-arrays sequences assocs unix unix.linux.epoll math bit-arrays sequences assocs struct-arrays math namespaces locals
namespaces unix.time ; fry unix unix.linux.epoll unix.time ;
IN: io.unix.epoll IN: io.unix.epoll
TUPLE: epoll-mx < mx events ; TUPLE: epoll-mx < mx events ;
@ -14,47 +14,50 @@ TUPLE: epoll-mx < mx events ;
: <epoll-mx> ( -- mx ) : <epoll-mx> ( -- mx )
epoll-mx new-mx epoll-mx new-mx
max-events epoll_create dup io-error over set-mx-fd max-events epoll_create dup io-error >>fd
max-events "epoll-event" <c-array> over set-epoll-mx-events ; max-events "epoll-event" <struct-array> >>events ;
GENERIC: io-task-events ( task -- n ) : make-event ( fd events -- event )
M: input-task io-task-events drop EPOLLIN ;
M: output-task io-task-events drop EPOLLOUT ;
: make-event ( task -- event )
"epoll-event" <c-object> "epoll-event" <c-object>
over io-task-events over set-epoll-event-events [ set-epoll-event-events ] keep
swap io-task-fd over set-epoll-event-fd ; [ set-epoll-event-fd ] keep ;
: do-epoll-ctl ( task mx what -- ) :: do-epoll-ctl ( fd mx what events -- )
>r mx-fd r> rot dup io-task-fd swap make-event mx fd>> what fd fd events make-event epoll_ctl io-error ;
epoll_ctl io-error ;
M: epoll-mx register-io-task ( task mx -- ) : do-epoll-add ( fd mx events -- )
[ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ; EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ;
M: epoll-mx unregister-io-task ( task mx -- ) : do-epoll-del ( fd mx events -- )
[ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ; EPOLL_CTL_DEL swap do-epoll-ctl ;
: wait-event ( mx timeout -- n ) M: epoll-mx add-input-callback ( thread fd mx -- )
>r { mx-fd epoll-mx-events } get-slots max-events [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ;
r> epoll_wait dup multiplexer-error ;
: epoll-read-task ( mx fd -- ) M: epoll-mx add-output-callback ( thread fd mx -- )
over mx-reads at* [ perform-io-task ] [ 2drop ] if ; [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ;
: epoll-write-task ( mx fd -- ) M: epoll-mx remove-input-callbacks ( fd mx -- seq )
over mx-writes at* [ perform-io-task ] [ 2drop ] if ; 2dup reads>> key? [
[ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
] [ 2drop f ] if ;
: handle-event ( mx kevent -- ) M: epoll-mx remove-output-callbacks ( fd mx -- seq )
epoll-event-fd 2dup epoll-read-task epoll-write-task ; 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 -- ) : handle-events ( mx n -- )
[ [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ;
over epoll-mx-events epoll-event-nth handle-event
] with each ;
M: epoll-mx wait-for-events ( ms mx -- ) M: epoll-mx wait-for-events ( us mx -- )
dup rot wait-event handle-events ; swap 60000000 or dupd wait-event handle-events ;

4
basis/io/unix/files/macosx/macosx.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings combinators USING: accessors alien.c-types alien.strings combinators
grouping io.encodings.utf8 io.files kernel math sequences 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 ; unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx ;
IN: io.unix.files.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_bavail >>blocks-available ]
[ statfs64-f_files >>files ] [ statfs64-f_files >>files ]
[ statfs64-f_ffree >>files-free ] [ statfs64-f_ffree >>files-free ]
[ statfs64-f_fsid >>id ] [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs64-f_owner >>owner ] [ statfs64-f_owner >>owner ]
[ statfs64-f_type >>type-id ] [ statfs64-f_type >>type-id ]
[ statfs64-f_flags >>flags ] [ statfs64-f_flags >>flags ]

40
basis/io/unix/kqueue/kqueue.factor
View File

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

4
basis/io/unix/linux/linux.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.unix.backend 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 IN: io.unix.linux
M: linux init-io ( -- ) M: linux init-io ( -- )
<select-mx> mx set-global ; <epoll-mx> mx set-global ;
linux set-io-backend linux set-io-backend

6
basis/io/unix/macosx/macosx.factor
View File

@ -1,6 +1,10 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.macosx 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 macosx set-io-backend

38
basis/io/windows/files/files.factor
View File

@ -5,7 +5,7 @@ io.encodings.utf16n io.ports io.windows kernel math splitting
fry alien.strings windows windows.kernel32 windows.time calendar fry alien.strings windows windows.kernel32 windows.time calendar
combinators math.functions sequences namespaces make words combinators math.functions sequences namespaces make words
symbols system destructors accessors math.bitwise continuations symbols system destructors accessors math.bitwise continuations
windows.errors arrays byte-arrays ; windows.errors arrays byte-arrays generalizations ;
IN: io.windows.files IN: io.windows.files
: open-file ( path access-mode create-mode flags -- handle ) : 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 ) : find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object> tuck "WIN32_FIND_DATA" <c-object> tuck
FindFirstFile 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 ) : find-next-file ( path -- WIN32_FIND_DATA/f )
"WIN32_FIND_DATA" <c-object> tuck "WIN32_FIND_DATA" <c-object> tuck
@ -257,13 +257,15 @@ M: winnt link-info ( path -- info )
HOOK: root-directory os ( string -- string' ) HOOK: root-directory os ( string -- string' )
: file-system-type ( normalized-path -- str ) : volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
MAX_PATH 1+ <byte-array> MAX_PATH 1+ [ <byte-array> ] keep
MAX_PATH 1+ "DWORD" <c-object>
"DWORD" <c-object> "DWORD" <c-object> "DWORD" <c-object> "DWORD" <c-object>
MAX_PATH 1+ <byte-array> "DWORD" <c-object>
MAX_PATH 1+ MAX_PATH 1+ [ <byte-array> ] keep
[ GetVolumeInformation win32-error=0/f ] 2keep drop [ GetVolumeInformation win32-error=0/f ] 7 nkeep
drop 5 nrot drop
[ utf16n alien>string ] 4 ndip
utf16n alien>string ; utf16n alien>string ;
: file-system-space ( normalized-path -- available-space total-space free-space ) : file-system-space ( normalized-path -- available-space total-space free-space )
@ -278,14 +280,20 @@ HOOK: root-directory os ( string -- string' )
[ ] [ ]
} cleave ; } cleave ;
TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;
M: winnt file-system-info ( path -- file-system-info ) M: winnt file-system-info ( path -- file-system-info )
normalize-path root-directory normalize-path root-directory
dup [ file-system-type ] [ file-system-space ] bi dup [ volume-information ] [ file-system-space ] bi
\ file-system-info new \ win32-file-system-info new
swap *ulonglong >>free-space swap *ulonglong >>free-space
swap *ulonglong >>total-space swap *ulonglong >>total-space
swap *ulonglong >>available-space swap *ulonglong >>available-space
swap >>type swap >>type
swap *uint >>flags
swap *uint >>max-component
swap *uint >>device-serial
swap >>device-name
swap >>mount-point swap >>mount-point
calculate-file-system-info ; calculate-file-system-info ;
@ -299,16 +307,16 @@ M: winnt file-system-info ( path -- file-system-info )
] if ; ] if ;
: find-first-volume ( -- string handle ) : find-first-volume ( -- string handle )
MAX_PATH 1+ <byte-array> dup length MAX_PATH 1+ [ <byte-array> ] keep
dupd dupd
FindFirstVolume dup win32-error=0/f FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ; [ utf16n alien>string ] dip ;
: find-next-volume ( handle -- string/f ) : find-next-volume ( handle -- string/f )
MAX_PATH 1+ <byte-array> dup length MAX_PATH 1+ [ <byte-array> tuck ] keep
over [ FindNextVolume ] dip swap 0 = [ FindNextVolume 0 = [
GetLastError ERROR_NO_MORE_FILES = GetLastError ERROR_NO_MORE_FILES =
[ drop f ] [ win32-error ] if [ drop f ] [ win32-error-string throw ] if
] [ ] [
utf16n alien>string utf16n alien>string
] if ; ] if ;

1
basis/listener/listener.factor
View File

@ -82,7 +82,6 @@ t display-stacks? set-global
: stacks. ( -- ) : stacks. ( -- )
display-stacks? get [ display-stacks? get [
datastack [ nl "--- Data stack:" title. stack. ] unless-empty datastack [ nl "--- Data stack:" title. stack. ] unless-empty
retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty
] when ; ] when ;
: prompt. ( -- ) : prompt. ( -- )

2
basis/locals/locals-docs.factor
View File

@ -67,6 +67,8 @@ HELP: :>
{ $syntax ":> binding" } { $syntax ":> binding" }
{ $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." } { $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." }
{ $notes { $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: :> } "." "Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "."
$nl $nl
"Lambdas desugar as follows:" "Lambdas desugar as follows:"

6
basis/logging/analysis/analysis.factor
View File

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

2
basis/specialized-arrays/double/double.factor
View File

@ -9,6 +9,8 @@ USING: hints math.vectors arrays kernel math accessors sequences ;
HINTS: <double-array> { 2 } { 3 } ; HINTS: <double-array> { 2 } { 3 } ;
HINTS: (double-array) { 2 } { 3 } ;
HINTS: vneg { array } { double-array } ; HINTS: vneg { array } { double-array } ;
HINTS: v*n { array object } { double-array float } ; HINTS: v*n { array object } { double-array float } ;
HINTS: n*v { array object } { float double-array } ; HINTS: n*v { array object } { float double-array } ;

8
basis/specialized-arrays/functor/functor.factor
View File

@ -10,10 +10,14 @@ ERROR: bad-byte-array-length byte-array type ;
M: bad-byte-array-length summary M: bad-byte-array-length summary
drop "Byte array length doesn't divide type width" ; drop "Byte array length doesn't divide type width" ;
: (c-array) ( n c-type -- array )
heap-size * (byte-array) ; inline
FUNCTOR: define-array ( T -- ) FUNCTOR: define-array ( T -- )
A DEFINES ${T}-array A DEFINES ${T}-array
<A> DEFINES <${A}> <A> DEFINES <${A}>
(A) DEFINES (${A})
>A DEFINES >${A} >A DEFINES >${A}
byte-array>A DEFINES byte-array>${A} byte-array>A DEFINES byte-array>${A}
A{ DEFINES ${A}{ A{ DEFINES ${A}{
@ -29,6 +33,8 @@ TUPLE: A
: <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline : <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline
: byte-array>A ( byte-array -- specialized-array ) : byte-array>A ( byte-array -- specialized-array )
dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
swap A boa ; inline 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 like drop dup A instance? [ >A execute ] unless ;
M: A new-sequence drop <A> execute ; M: A new-sequence drop (A) execute ;
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;

3
basis/stack-checker/known-words/known-words.factor
View File

@ -480,6 +480,9 @@ M: object infer-call*
\ <byte-array> { integer } { byte-array } define-primitive \ <byte-array> { integer } { byte-array } define-primitive
\ <byte-array> make-flushable \ <byte-array> make-flushable
\ (byte-array) { integer } { byte-array } define-primitive
\ (byte-array) make-flushable
\ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive \ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive
\ <displaced-alien> make-flushable \ <displaced-alien> make-flushable

3
basis/tools/files/files-tests.factor
View File

@ -7,5 +7,4 @@ IN: tools.files.tests
[ ] [ "" directory. ] unit-test [ ] [ "" directory. ] unit-test
[ ] [ ] [ file-systems. ] unit-test
[ { device-name free-space used-space total-space percent-used } file-systems. ] unit-test

12
basis/tools/files/files.factor
View File

@ -41,9 +41,9 @@ percent-used percent-free ;
: file-system-spec ( file-system-info obj -- str ) : file-system-spec ( file-system-info obj -- str )
{ {
{ device-name [ device-name>> ] } { device-name [ device-name>> [ "" ] unless* ] }
{ mount-point [ mount-point>> ] } { mount-point [ mount-point>> [ "" ] unless* ] }
{ type [ type>> ] } { type [ type>> [ "" ] unless* ] }
{ available-space [ available-space>> [ 0 ] unless* ] } { available-space [ available-space>> [ 0 ] unless* ] }
{ free-space [ free-space>> [ 0 ] unless* ] } { free-space [ free-space>> [ 0 ] unless* ] }
{ used-space [ used-space>> [ 0 ] unless* ] } { used-space [ used-space>> [ 0 ] unless* ] }
@ -58,10 +58,14 @@ percent-used percent-free ;
: file-systems-info ( spec -- seq ) : file-systems-info ( spec -- seq )
file-systems swap '[ _ [ file-system-spec ] with map ] map ; file-systems swap '[ _ [ file-system-spec ] with map ] map ;
: file-systems. ( spec -- ) : print-file-systems ( spec -- )
[ file-systems-info ] [ file-systems-info ]
[ [ unparse ] map ] bi prefix simple-table. ; [ [ 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 unix? ] [ "tools.files.unix" ] }
{ [ os windows? ] [ "tools.files.windows" ] } { [ os windows? ] [ "tools.files.windows" ] }

2
basis/tools/memory/memory.factor
View File

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

3
basis/tools/walker/walker.factor
View File

@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words concurrency.messaging quotations kernel.private words
sequences.private assocs models models.filter arrays accessors sequences.private assocs models models.filter arrays accessors
generic generic.standard definitions make ; generic generic.standard definitions make sbufs ;
IN: tools.walker IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- ) SYMBOL: show-walker-hook ! ( status continuation thread -- )
@ -147,6 +147,7 @@ SYMBOL: +stopped+
{ (call-next-method) [ (step-into-call-next-method) ] } { (call-next-method) [ (step-into-call-next-method) ] }
} [ "step-into" set-word-prop ] assoc-each } [ "step-into" set-word-prop ] assoc-each
! Never step into these words
{ {
>n ndrop >c c> >n ndrop >c c>
continue continue-with continue continue-with

3
basis/unix/kqueue/kqueue.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: unix.kqueue
<< "unix.kqueue." os name>> append require >> << "unix.kqueue." os name>> append require >>

23
basis/unix/linux/epoll/epoll.factor
View File

@ -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_DEL 2 ; inline ! Remove a file decriptor from the interface.
: EPOLL_CTL_MOD 3 ; inline ! Change file decriptor epoll_event structure. : EPOLL_CTL_MOD 3 ; inline ! Change file decriptor epoll_event structure.
: EPOLLIN HEX: 001 ; inline : EPOLLIN HEX: 001 ; inline
: EPOLLPRI HEX: 002 ; inline : EPOLLPRI HEX: 002 ; inline
: EPOLLOUT HEX: 004 ; inline : EPOLLOUT HEX: 004 ; inline
: EPOLLRDNORM HEX: 040 ; inline : EPOLLRDNORM HEX: 040 ; inline
: EPOLLRDBAND HEX: 080 ; inline : EPOLLRDBAND HEX: 080 ; inline
: EPOLLWRNORM HEX: 100 ; inline : EPOLLWRNORM HEX: 100 ; inline
: EPOLLWRBAND HEX: 200 ; inline : EPOLLWRBAND HEX: 200 ; inline
: EPOLLMSG HEX: 400 ; inline : EPOLLMSG HEX: 400 ; inline
: EPOLLERR HEX: 008 ; inline : EPOLLERR HEX: 008 ; inline
: EPOLLHUP HEX: 010 ; inline : EPOLLHUP HEX: 010 ; inline
: EPOLLET 31 2^ ; inline : EPOLLONESHOT 30 2^ ; inline
: EPOLLET 31 2^ ; inline

6
core/assocs/assocs-docs.factor
View File

@ -90,6 +90,7 @@ ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
{ $subsection rename-at } { $subsection rename-at }
{ $subsection change-at } { $subsection change-at }
{ $subsection at+ } { $subsection at+ }
{ $subsection inc-at }
{ $see-also set-at delete-at clear-assoc push-at } ; { $see-also set-at delete-at clear-assoc push-at } ;
ARTICLE: "assocs-conversions" "Associative mapping conversions" 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." } { $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" } ; { $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 HELP: >alist
{ $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } } { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } }
{ $contract "Converts an associative structure into an association list." } { $contract "Converts an associative structure into an association list." }

5
core/assocs/assocs.factor
View File

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

1
core/bootstrap/primitives.factor
View File

@ -468,6 +468,7 @@ tuple
{ "dlsym" "alien" } { "dlsym" "alien" }
{ "dlclose" "alien" } { "dlclose" "alien" }
{ "<byte-array>" "byte-arrays" } { "<byte-array>" "byte-arrays" }
{ "(byte-array)" "byte-arrays" }
{ "<displaced-alien>" "alien" } { "<displaced-alien>" "alien" }
{ "alien-signed-cell" "alien.accessors" } { "alien-signed-cell" "alien.accessors" }
{ "set-alien-signed-cell" "alien.accessors" } { "set-alien-signed-cell" "alien.accessors" }

7
core/byte-arrays/byte-arrays-tests.factor
View File

@ -1,7 +1,10 @@
IN: byte-arrays.tests 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 [ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test

2
core/byte-arrays/byte-arrays.factor
View File

@ -9,7 +9,7 @@ M: byte-array length length>> ;
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
M: byte-array new-sequence drop <byte-array> ; M: byte-array new-sequence drop (byte-array) ;
M: byte-array equal? M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ; over byte-array? [ sequence= ] [ 2drop f ] if ;

10
core/memory/memory-tests.factor
View File

@ -1,8 +1,16 @@
USING: generic kernel kernel.private math memory prettyprint io USING: generic kernel kernel.private math memory prettyprint io
sequences tools.test words namespaces layouts classes sequences tools.test words namespaces layouts classes
classes.builtin arrays quotations ; classes.builtin arrays quotations io.launcher system ;
IN: memory.tests 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 [ [ ] instances ] must-infer
! Code GC wasn't kicking in when needed ! Code GC wasn't kicking in when needed

8
core/sequences/sequences-docs.factor
View File

@ -1,6 +1,6 @@
USING: arrays help.markup help.syntax math USING: arrays help.markup help.syntax math
sequences.private vectors strings kernel math.order layouts sequences.private vectors strings kernel math.order layouts
quotations ; quotations generic.standard ;
IN: sequences IN: sequences
HELP: sequence HELP: sequence
@ -14,8 +14,8 @@ HELP: length
HELP: set-length HELP: set-length
{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } } { $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
{ $contract "Resizes the sequence. Not all sequences are resizable." } { $contract "Resizes a sequence. The initial contents of the new area is undefined." }
{ $errors "Throws a " { $link bounds-error } " if the new length is negative." } { $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" } ; { $side-effects "seq" } ;
HELP: lengthen HELP: lengthen
@ -59,7 +59,7 @@ HELP: immutable
HELP: new-sequence HELP: new-sequence
{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable 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 HELP: new-resizable
{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } } { $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } }

3
core/sequences/sequences.factor
View File

@ -845,9 +845,10 @@ PRIVATE>
USE: arrays USE: arrays
: array-length ( array -- len ) : array-length ( array -- len )
{ array } declare length>> ; { array } declare length>> ; inline
: array-flip ( matrix -- newmatrix ) : array-flip ( matrix -- newmatrix )
{ array } declare
[ dup first array-length [ array-length min ] reduce ] keep [ dup first array-length [ array-length min ] reduce ] keep
[ [ array-nth ] with { } map-as ] curry { } map-as ; [ [ array-nth ] with { } map-as ] curry { } map-as ;

6
extra/benchmark/benchmark.factor
View File

@ -6,8 +6,10 @@ continuations debugger math ;
IN: benchmark IN: benchmark
: run-benchmark ( vocab -- result ) : run-benchmark ( vocab -- result )
[ [ require ] [ [ run ] benchmark ] bi ] curry [ "=== " write vocab-name print flush ] [
[ error. f ] recover ; [ [ require ] [ [ run ] benchmark ] bi ] curry
[ error. f ] recover
] bi ;
: run-benchmarks ( -- assoc ) : run-benchmarks ( -- assoc )
"benchmark" all-child-vocabs-seq "benchmark" all-child-vocabs-seq

123
extra/fuel/fuel.factor
View File

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

17
misc/fuel/README
View File

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

17
misc/fuel/factor-mode.el
View File

@ -59,6 +59,23 @@ code in the buffer."
:type 'hook :type 'hook
:group 'factor-mode) :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: ;;; Syntax table:

266
misc/fuel/fuel-debug.el Normal file
View File

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

56
misc/fuel/fuel-eval.el
View File

@ -38,7 +38,8 @@
(when (and (> fuel-eval-log-max-length 0) (when (and (> fuel-eval-log-max-length 0)
(> (point) fuel-eval-log-max-length)) (> (point) fuel-eval-log-max-length))
(erase-buffer)) (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))) (let ((beg (point)))
(comint-redirect-send-command-to-process str (current-buffer) proc nil t) (comint-redirect-send-command-to-process str (current-buffer) proc nil t)
(with-current-buffer (process-buffer proc) (with-current-buffer (process-buffer proc)
@ -58,8 +59,6 @@
(defsubst fuel-eval--retort-p (ret) (listp ret)) (defsubst fuel-eval--retort-p (ret) (listp ret))
(defsubst fuel-eval--error-name (err) (car err))
(defsubst fuel-eval--make-parse-error-retort (str) (defsubst fuel-eval--make-parse-error-retort (str)
(fuel-eval--retort-make 'parse-retort-error nil str)) (fuel-eval--retort-make 'parse-retort-error nil str))
@ -83,29 +82,60 @@
(defsubst fuel-eval--factor-array (strs) (defsubst fuel-eval--factor-array (strs)
(format "V{ %S }" (mapconcat 'identity strs " "))) (format "V{ %S }" (mapconcat 'identity strs " ")))
(defsubst fuel-eval--eval-strings (strs) (defsubst fuel-eval--eval-strings (strs &optional no-restart)
(let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs)))) (let ((str (format "fuel-eval-%s %s fuel-eval"
(if no-restart "non-restartable" "restartable")
(fuel-eval--factor-array strs))))
(fuel-eval--send/retort str))) (fuel-eval--send/retort str)))
(defsubst fuel-eval--eval-string (str) (defsubst fuel-eval--eval-string (str &optional no-restart)
(fuel-eval--eval-strings (list str))) (fuel-eval--eval-strings (list str) no-restart))
(defun fuel-eval--eval-strings/context (strs) (defun fuel-eval--eval-strings/context (strs &optional no-restart)
(let ((usings (fuel-syntax--usings-update))) (let ((usings (fuel-syntax--usings-update)))
(fuel-eval--send/retort (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) (fuel-eval--factor-array strs)
(or fuel-syntax--current-vocab "f") (or fuel-syntax--current-vocab "f")
(if usings (fuel-eval--factor-array usings) "f"))))) (if usings (fuel-eval--factor-array usings) "f")))))
(defsubst fuel-eval--eval-string/context (str) (defsubst fuel-eval--eval-string/context (str &optional no-restart)
(fuel-eval--eval-strings/context (list str))) (fuel-eval--eval-strings/context (list str) no-restart))
(defun fuel-eval--eval-region/context (begin end) (defun fuel-eval--eval-region/context (begin end &optional no-restart)
(let ((lines (split-string (buffer-substring-no-properties begin end) (let ((lines (split-string (buffer-substring-no-properties begin end)
"[\f\n\r\v]+" t))) "[\f\n\r\v]+" t)))
(when (> (length lines) 0) (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) (provide 'fuel-eval)

33
misc/fuel/fuel-font-lock.el
View File

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

7
misc/fuel/fuel-help.el
View File

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

49
misc/fuel/fuel-listener.el
View File

@ -59,10 +59,15 @@ buffer."
(error "Could not run factor: %s is not executable" factor)) (error "Could not run factor: %s is not executable" factor))
(unless (file-readable-p image) (unless (file-readable-p image)
(error "Could not run factor: image file %s not readable" image)) (error "Could not run factor: image file %s not readable" image))
(setq fuel-listener-buffer (setq fuel-listener-buffer (get-buffer-create "*fuel listener*"))
(make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image)))
(with-current-buffer fuel-listener-buffer (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) (defun fuel-listener--process (&optional start)
(or (and (buffer-live-p fuel-listener-buffer) (or (and (buffer-live-p fuel-listener-buffer)
@ -74,6 +79,23 @@ buffer."
(setq fuel-eval--default-proc-function 'fuel-listener--process) (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 ;;; Interface: starting fuel listener
@ -94,30 +116,17 @@ buffer."
(defconst fuel-listener--prompt-regex "( [^)]* ) ") (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" (define-derived-mode fuel-listener-mode comint-mode "Fuel Listener"
"Major mode for interacting with an inferior Factor listener process. "Major mode for interacting with an inferior Factor listener process.
\\{fuel-listener-mode-map}" \\{fuel-listener-mode-map}"
(set (make-local-variable 'comint-prompt-regexp) (set (make-local-variable 'comint-prompt-regexp)
fuel-listener--prompt-regex) fuel-listener--prompt-regex)
(set (make-local-variable 'comint-prompt-read-only) t) (set (make-local-variable 'comint-prompt-read-only) t)
(fuel-listener--startup)) (setq fuel-listener--compilation-begin nil))
;; (define-key fuel-listener-mode-map "\C-w" 'comint-kill-region) (define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
;; (define-key fuel-listener-mode-map "\C-k" 'comint-kill-whole-line) (define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file)
(provide 'fuel-listener) (provide 'fuel-listener)

51
misc/fuel/fuel-mode.el
View File

@ -18,6 +18,7 @@
(require 'fuel-base) (require 'fuel-base)
(require 'fuel-syntax) (require 'fuel-syntax)
(require 'fuel-font-lock) (require 'fuel-font-lock)
(require 'fuel-debug)
(require 'fuel-help) (require 'fuel-help)
(require 'fuel-eval) (require 'fuel-eval)
(require 'fuel-listener) (require 'fuel-listener)
@ -37,33 +38,60 @@
;;; User commands ;;; 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) (defun fuel-eval-region (begin end &optional arg)
"Sends region to Fuel's listener for evaluation. "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") (interactive "r\nP")
(let* ((ret (fuel-eval--eval-region/context begin end)) (fuel-debug--display-retort
(err (fuel-eval--retort-error ret))) (fuel-eval--eval-region/context begin end)
(message "%s" (or err (fuel--shorten-region begin end 70)))) (format "%s%s"
(when arg (pop-to-buffer fuel-listener-buffer))) (if fuel-syntax--current-vocab
(format "IN: %s " fuel-syntax--current-vocab)
"")
(fuel--shorten-region begin end 70))
arg
(buffer-file-name)))
(defun fuel-eval-extended-region (begin end &optional arg) (defun fuel-eval-extended-region (begin end &optional arg)
"Sends region extended outwards to nearest definitions, "Sends region extended outwards to nearest definitions,
to Fuel's listener for evaluation. With prefix, switchs to the to Fuel's listener for evaluation.
listener's buffer afterwards." Unless called with a prefix, switchs to the compilation results
buffer in case of errors."
(interactive "r\nP") (interactive "r\nP")
(fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point)) (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) (defun fuel-eval-definition (&optional arg)
"Sends definition around point to Fuel's listener for evaluation. "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") (interactive "P")
(save-excursion (save-excursion
(mark-defun) (mark-defun)
(let* ((begin (point)) (let* ((begin (point))
(end (mark))) (end (mark)))
(unless (< begin end) (error "No evaluable definition around point")) (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) (defun fuel-edit-word-at-point (&optional arg)
"Opens a new window visiting the definition of the word at point. "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 ?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) (define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
(fuel-mode--key ?e ?x 'fuel-eval-definition) (fuel-mode--key ?e ?x 'fuel-eval-definition)

1
vm/primitives.c
View File

@ -74,6 +74,7 @@ void *primitives[] = {
primitive_dlsym, primitive_dlsym,
primitive_dlclose, primitive_dlclose,
primitive_byte_array, primitive_byte_array,
primitive_uninitialized_byte_array,
primitive_displaced_alien, primitive_displaced_alien,
primitive_alien_signed_cell, primitive_alien_signed_cell,
primitive_set_alien_signed_cell, primitive_set_alien_signed_cell,

8
vm/types.c
View File

@ -243,6 +243,12 @@ void primitive_byte_array(void)
dpush(tag_object(allot_byte_array(size))); 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) F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
{ {
CELL to_copy = array_capacity(array); 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; to_copy = capacity;
REGISTER_UNTAGGED(array); 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); UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy); memcpy(new_array + 1,array + 1,to_copy);

2
vm/types.h
View File

@ -116,6 +116,7 @@ void primitive_tuple(void);
void primitive_tuple_boa(void); void primitive_tuple_boa(void);
void primitive_tuple_layout(void); void primitive_tuple_layout(void);
void primitive_byte_array(void); void primitive_byte_array(void);
void primitive_uninitialized_byte_array(void);
void primitive_clone(void); void primitive_clone(void);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); 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_internal(CELL capacity);
F_STRING* allot_string(CELL capacity, CELL fill); F_STRING* allot_string(CELL capacity, CELL fill);
void primitive_uninitialized_string(void);
void primitive_string(void); void primitive_string(void);
F_STRING *reallot_string(F_STRING *string, CELL capacity); F_STRING *reallot_string(F_STRING *string, CELL capacity);
void primitive_resize_string(void); void primitive_resize_string(void);