Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
bc60af6187
|
|
@ -21,8 +21,6 @@ IN: compiler.cfg.builder
|
|||
|
||||
! Convert tree SSA IR to CFG SSA IR.
|
||||
|
||||
: stop-iterating ( -- next ) end-basic-block f ;
|
||||
|
||||
SYMBOL: procedures
|
||||
SYMBOL: current-word
|
||||
SYMBOL: current-label
|
||||
|
|
@ -211,7 +209,7 @@ M: #dispatch emit-node
|
|||
! #call
|
||||
M: #call emit-node
|
||||
dup word>> dup "intrinsic" word-prop
|
||||
[ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
|
||||
[ emit-intrinsic ] [ nip emit-call ] if ;
|
||||
|
||||
! #call-recursive
|
||||
M: #call-recursive emit-node label>> id>> emit-call ;
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ M: ##compare-imm-branch uses-vregs src1>> 1array ;
|
|||
M: ##dispatch uses-vregs src>> 1array ;
|
||||
M: ##alien-getter uses-vregs src>> 1array ;
|
||||
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
|
||||
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: _compare-imm-branch uses-vregs src1>> 1array ;
|
||||
M: insn uses-vregs drop f ;
|
||||
|
|
@ -43,6 +44,7 @@ UNION: vreg-insn
|
|||
##write-barrier
|
||||
##dispatch
|
||||
##effect
|
||||
##fixnum-overflow
|
||||
##conditional-branch
|
||||
##compare-imm-branch
|
||||
_conditional-branch
|
||||
|
|
|
|||
|
|
@ -92,6 +92,15 @@ INSN: ##shr-imm < ##binary-imm ;
|
|||
INSN: ##sar-imm < ##binary-imm ;
|
||||
INSN: ##not < ##unary ;
|
||||
|
||||
! Overflowing arithmetic
|
||||
TUPLE: ##fixnum-overflow < insn src1 src2 ;
|
||||
INSN: ##fixnum-add < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-add-tail < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-sub < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-mul < ##fixnum-overflow ;
|
||||
INSN: ##fixnum-mul-tail < ##fixnum-overflow ;
|
||||
|
||||
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
|
||||
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -3,10 +3,22 @@
|
|||
USING: sequences accessors layouts kernel math namespaces
|
||||
combinators fry locals
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.utilities ;
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.iterator
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.registers ;
|
||||
IN: compiler.cfg.intrinsics.fixnum
|
||||
|
||||
: emit-both-fixnums? ( -- )
|
||||
D 0 ^^peek
|
||||
D 1 ^^peek
|
||||
^^or
|
||||
tag-mask get ^^and-imm
|
||||
0 cc= ^^compare-imm
|
||||
ds-push ;
|
||||
|
||||
: (emit-fixnum-imm-op) ( infos insn -- dst )
|
||||
ds-drop
|
||||
[ ds-pop ]
|
||||
|
|
@ -64,3 +76,16 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
|
||||
: emit-fixnum>bignum ( -- )
|
||||
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
|
||||
|
||||
: emit-fixnum-overflow-op ( quot quot-tail -- next )
|
||||
[ 2inputs 1 ##inc-d ] 2dip
|
||||
tail-call? [
|
||||
##epilogue
|
||||
nip call
|
||||
stop-iterating
|
||||
] [
|
||||
drop call
|
||||
##branch
|
||||
begin-basic-block
|
||||
iterate-next
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@ compiler.cfg.intrinsics.alien
|
|||
compiler.cfg.intrinsics.allot
|
||||
compiler.cfg.intrinsics.fixnum
|
||||
compiler.cfg.intrinsics.float
|
||||
compiler.cfg.intrinsics.slots ;
|
||||
compiler.cfg.intrinsics.slots
|
||||
compiler.cfg.iterator ;
|
||||
QUALIFIED: kernel
|
||||
QUALIFIED: arrays
|
||||
QUALIFIED: byte-arrays
|
||||
|
|
@ -22,6 +23,9 @@ IN: compiler.cfg.intrinsics
|
|||
|
||||
{
|
||||
kernel.private:tag
|
||||
math.private:both-fixnums?
|
||||
math.private:fixnum+
|
||||
math.private:fixnum-
|
||||
math.private:fixnum+fast
|
||||
math.private:fixnum-fast
|
||||
math.private:fixnum-bitand
|
||||
|
|
@ -85,60 +89,67 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-double
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: emit-intrinsic ( node word -- )
|
||||
: enable-fixnum*-intrinsic ( -- )
|
||||
\ math.private:fixnum* t "intrinsic" set-word-prop ;
|
||||
|
||||
: emit-intrinsic ( node word -- node/f )
|
||||
{
|
||||
{ \ kernel.private:tag [ drop emit-tag ] }
|
||||
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
|
||||
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
|
||||
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
|
||||
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
|
||||
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
|
||||
{ \ kernel:eq? [ cc= emit-fixnum-comparison ] }
|
||||
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
|
||||
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
|
||||
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
|
||||
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
|
||||
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
|
||||
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
|
||||
{ \ math.private:float< [ drop cc< emit-float-comparison ] }
|
||||
{ \ math.private:float<= [ drop cc<= emit-float-comparison ] }
|
||||
{ \ math.private:float>= [ drop cc>= emit-float-comparison ] }
|
||||
{ \ math.private:float> [ drop cc> emit-float-comparison ] }
|
||||
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
|
||||
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
|
||||
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
|
||||
{ \ slots.private:slot [ emit-slot ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot ] }
|
||||
{ \ strings.private:string-nth [ drop emit-string-nth ] }
|
||||
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
|
||||
{ \ arrays:<array> [ emit-<array> ] }
|
||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
|
||||
{ \ math.private:<complex> [ emit-simple-allot ] }
|
||||
{ \ math.private:<ratio> [ emit-simple-allot ] }
|
||||
{ \ kernel:<wrapper> [ emit-simple-allot ] }
|
||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
|
||||
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
|
||||
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
|
||||
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
|
||||
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
|
||||
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
|
||||
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
|
||||
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
|
||||
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
|
||||
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
|
||||
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum* [ drop [ ##fixnum-mul ] [ ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
|
||||
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
|
||||
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
|
||||
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
|
||||
{ \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
|
||||
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
|
||||
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
|
||||
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
|
||||
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
|
||||
{ \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
|
||||
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
|
||||
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
|
||||
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
|
||||
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
|
||||
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
|
||||
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
|
||||
{ \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
|
||||
{ \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
|
||||
{ \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
|
||||
{ \ slots.private:slot [ emit-slot iterate-next ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot iterate-next ] }
|
||||
{ \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
|
||||
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
|
||||
{ \ arrays:<array> [ emit-<array> iterate-next ] }
|
||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
|
||||
{ \ math.private:<complex> [ emit-simple-allot iterate-next ] }
|
||||
{ \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
|
||||
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
|
||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
|
||||
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -34,6 +34,12 @@ M: insn compute-stack-frame*
|
|||
|
||||
\ _gc t frame-required? set-word-prop
|
||||
\ _spill t frame-required? set-word-prop
|
||||
\ ##fixnum-add t frame-required? set-word-prop
|
||||
\ ##fixnum-sub t frame-required? set-word-prop
|
||||
\ ##fixnum-mul t frame-required? set-word-prop
|
||||
\ ##fixnum-add-tail f frame-required? set-word-prop
|
||||
\ ##fixnum-sub-tail f frame-required? set-word-prop
|
||||
\ ##fixnum-mul-tail f frame-required? set-word-prop
|
||||
|
||||
: compute-stack-frame ( insns -- )
|
||||
frame-required? off
|
||||
|
|
|
|||
|
|
@ -33,5 +33,7 @@ IN: compiler.cfg.utilities
|
|||
building off
|
||||
basic-block off ;
|
||||
|
||||
: stop-iterating ( -- next ) end-basic-block f ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
word>> ##call ##branch begin-basic-block ;
|
||||
|
|
|
|||
|
|
@ -62,4 +62,8 @@ M: ##compare-imm-branch propagate
|
|||
M: ##dispatch propagate
|
||||
[ resolve ] change-src ;
|
||||
|
||||
M: ##fixnum-overflow propagate
|
||||
[ resolve ] change-src1
|
||||
[ resolve ] change-src2 ;
|
||||
|
||||
M: insn propagate ;
|
||||
|
|
|
|||
|
|
@ -156,6 +156,16 @@ M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
|
|||
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
|
||||
M: ##not generate-insn dst/src %not ;
|
||||
|
||||
: src1/src2 ( insn -- src1 src2 )
|
||||
[ src1>> register ] [ src2>> register ] bi ; inline
|
||||
|
||||
M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
|
||||
M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
|
||||
M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
|
||||
M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
|
||||
M: ##fixnum-mul generate-insn src1/src2 %fixnum-mul ;
|
||||
M: ##fixnum-mul-tail generate-insn src1/src2 %fixnum-mul-tail ;
|
||||
|
||||
: dst/src/temp ( insn -- dst src temp )
|
||||
[ dst/src ] [ temp>> register ] bi ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -254,3 +254,10 @@ TUPLE: id obj ;
|
|||
{ 1 2 3 4 }
|
||||
[ { array } declare 2 <groups> length ] compile-call
|
||||
] unit-test
|
||||
|
||||
! Oops with new intrinsics
|
||||
: fixnum-overflow-control-flow-test ( a b -- c )
|
||||
[ 1 fixnum- ] [ 2 fixnum- ] if 3 fixnum+fast ;
|
||||
|
||||
[ 3 ] [ 1 t fixnum-overflow-control-flow-test ] unit-test
|
||||
[ 2 ] [ 1 f fixnum-overflow-control-flow-test ] unit-test
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ M: #shuffle node>quot
|
|||
[ drop "COMPLEX SHUFFLE" , ]
|
||||
} cond ;
|
||||
|
||||
M: #push node>quot literal>> , ;
|
||||
M: #push node>quot literal>> literalize , ;
|
||||
|
||||
M: #call node>quot word>> , ;
|
||||
|
||||
|
|
|
|||
|
|
@ -77,6 +77,13 @@ HOOK: %shr-imm cpu ( dst src1 src2 -- )
|
|||
HOOK: %sar-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %not cpu ( dst src -- )
|
||||
|
||||
HOOK: %fixnum-add cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-sub cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-sub-tail cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-mul cpu ( src1 src2 -- )
|
||||
HOOK: %fixnum-mul-tail cpu ( src1 src2 -- )
|
||||
|
||||
HOOK: %integer>bignum cpu ( dst src temp -- )
|
||||
HOOK: %bignum>integer cpu ( dst src temp -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -327,6 +327,18 @@ big-endian on
|
|||
\ BLT \ fixnum< define-jit-compare
|
||||
|
||||
! Math
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
4 ds-reg -4 LWZ
|
||||
3 3 4 OR
|
||||
3 3 tag-mask get ANDI
|
||||
\ f tag-number 4 LI
|
||||
0 3 0 CMPI
|
||||
2 BNE
|
||||
1 tag-fixnum 4 LI
|
||||
4 ds-reg 4 STWU
|
||||
] f f f \ both-fixnums? define-sub-primitive
|
||||
|
||||
: jit-math ( insn -- )
|
||||
3 ds-reg 0 LWZ
|
||||
4 ds-reg -4 LWZU
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ IN: cpu.ppc
|
|||
! f30, f31: float scratch
|
||||
|
||||
enable-float-intrinsics
|
||||
enable-fixnum*-intrinsic
|
||||
|
||||
<< \ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop >>
|
||||
|
|
@ -37,6 +38,9 @@ M: ppc %load-immediate ( reg n -- ) swap LOAD ;
|
|||
M: ppc %load-indirect ( reg obj -- )
|
||||
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
: ds-reg 29 ; inline
|
||||
: rs-reg 30 ; inline
|
||||
|
||||
|
|
@ -164,6 +168,91 @@ M: ppc %shr-imm swapd SRWI ;
|
|||
M: ppc %sar-imm SRAWI ;
|
||||
M: ppc %not NOT ;
|
||||
|
||||
: %alien-invoke-tail ( func dll -- )
|
||||
scratch-reg %load-dlsym scratch-reg MTCTR BCTR ;
|
||||
|
||||
:: exchange-regs ( r1 r2 -- )
|
||||
scratch-reg r1 MR
|
||||
r1 r2 MR
|
||||
r2 scratch-reg MR ;
|
||||
|
||||
: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ;
|
||||
|
||||
:: move>args ( src1 src2 -- )
|
||||
{
|
||||
{ [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] }
|
||||
{ [ src1 3 = ] [ 4 src2 ?MR ] }
|
||||
{ [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] }
|
||||
{ [ src2 4 = ] [ 3 src1 ?MR ] }
|
||||
[ 3 src1 MR 4 src2 MR ]
|
||||
} cond ;
|
||||
|
||||
:: overflow-template ( src1 src2 insn func -- )
|
||||
"no-overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
scratch-reg src2 src1 insn call
|
||||
scratch-reg ds-reg 0 STW
|
||||
"no-overflow" get BNO
|
||||
src2 src1 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke
|
||||
"no-overflow" resolve-label ; inline
|
||||
|
||||
:: overflow-template-tail ( src1 src2 insn func -- )
|
||||
"overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
scratch-reg src2 src1 insn call
|
||||
"overflow" get BO
|
||||
scratch-reg ds-reg 0 STW
|
||||
BLR
|
||||
"overflow" resolve-label
|
||||
src2 src1 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke-tail ;
|
||||
|
||||
M: ppc %fixnum-add ( src1 src2 -- )
|
||||
[ ADDO. ] "overflow_fixnum_add" overflow-template ;
|
||||
|
||||
M: ppc %fixnum-add-tail ( src1 src2 -- )
|
||||
[ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
|
||||
|
||||
M: ppc %fixnum-sub ( src1 src2 -- )
|
||||
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
|
||||
|
||||
M: ppc %fixnum-sub-tail ( src1 src2 -- )
|
||||
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
|
||||
|
||||
M:: ppc %fixnum-mul ( src1 src2 -- )
|
||||
"no-overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
src1 src1 tag-bits get SRAWI
|
||||
scratch-reg src1 src2 MULLWO.
|
||||
scratch-reg ds-reg 0 STW
|
||||
"no-overflow" get BNO
|
||||
src2 src2 tag-bits get SRAWI
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
"overflow_fixnum_multiply" f %alien-invoke
|
||||
"no-overflow" resolve-label ;
|
||||
|
||||
M:: ppc %fixnum-mul-tail ( src1 src2 -- )
|
||||
"overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
src1 src1 tag-bits get SRAWI
|
||||
scratch-reg src1 src2 MULLWO.
|
||||
"overflow" get BO
|
||||
scratch-reg ds-reg 0 STW
|
||||
BLR
|
||||
"overflow" resolve-label
|
||||
src2 src2 tag-bits get SRAWI
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
"overflow_fixnum_multiply" f %alien-invoke-tail ;
|
||||
|
||||
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
|
||||
|
||||
M:: ppc %integer>bignum ( dst src temp -- )
|
||||
|
|
@ -318,9 +407,6 @@ M: ppc %set-alien-cell swap 0 STW ;
|
|||
M: ppc %set-alien-float swap 0 STFS ;
|
||||
M: ppc %set-alien-double swap 0 STFD ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
[ "nursery" f ] dip %load-dlsym ;
|
||||
|
||||
|
|
@ -538,11 +624,11 @@ M: ppc %prepare-alien-invoke
|
|||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
"stack_chain" f 11 %load-dlsym
|
||||
11 11 0 LWZ
|
||||
1 11 0 STW
|
||||
ds-reg 11 8 STW
|
||||
rs-reg 11 12 STW ;
|
||||
"stack_chain" f scratch-reg %load-dlsym
|
||||
scratch-reg scratch-reg 0 LWZ
|
||||
1 scratch-reg 0 STW
|
||||
ds-reg scratch-reg 8 STW
|
||||
rs-reg scratch-reg 12 STW ;
|
||||
|
||||
M: ppc %alien-invoke ( symbol dll -- )
|
||||
11 %load-dlsym 11 MTLR BLRL ;
|
||||
|
|
|
|||
|
|
@ -23,8 +23,8 @@ M: x86.32 machine-registers
|
|||
M: x86.32 ds-reg ESI ;
|
||||
M: x86.32 rs-reg EDI ;
|
||||
M: x86.32 stack-reg ESP ;
|
||||
M: x86.32 temp-reg-1 EAX ;
|
||||
M: x86.32 temp-reg-2 ECX ;
|
||||
M: x86.32 temp-reg-1 ECX ;
|
||||
M: x86.32 temp-reg-2 EDX ;
|
||||
|
||||
M:: x86.32 %dispatch ( src temp offset -- )
|
||||
! Load jump table base.
|
||||
|
|
@ -38,12 +38,18 @@ M:: x86.32 %dispatch ( src temp offset -- )
|
|||
[ align-code ]
|
||||
bi ;
|
||||
|
||||
! Registers for fastcall
|
||||
M: x86.32 param-reg-1 EAX ;
|
||||
M: x86.32 param-reg-2 EDX ;
|
||||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
|
||||
M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
|
||||
|
||||
M: x86.32 struct-small-enough? ( size -- ? )
|
||||
heap-size { 1 2 4 8 } member?
|
||||
os { linux netbsd solaris } member? not and ;
|
||||
|
|
|
|||
|
|
@ -21,8 +21,8 @@ M: x86.64 machine-registers
|
|||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
M: x86.64 temp-reg-1 RAX ;
|
||||
M: x86.64 temp-reg-2 RCX ;
|
||||
M: x86.64 temp-reg-1 R8 ;
|
||||
M: x86.64 temp-reg-2 R9 ;
|
||||
|
||||
M:: x86.64 %dispatch ( src temp offset -- )
|
||||
! Load jump table base.
|
||||
|
|
@ -37,8 +37,8 @@ M:: x86.64 %dispatch ( src temp offset -- )
|
|||
[ align-code ]
|
||||
bi ;
|
||||
|
||||
: param-reg-1 int-regs param-regs first ; inline
|
||||
: param-reg-2 int-regs param-regs second ; inline
|
||||
M: x86.64 param-reg-1 int-regs param-regs first ;
|
||||
M: x86.64 param-reg-2 int-regs param-regs second ;
|
||||
: param-reg-3 int-regs param-regs third ; inline
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
|
|
@ -168,6 +168,11 @@ M: x86.64 %alien-invoke
|
|||
rc-absolute-cell rel-dlsym
|
||||
R11 CALL ;
|
||||
|
||||
M: x86.64 %alien-invoke-tail
|
||||
R11 0 MOV
|
||||
rc-absolute-cell rel-dlsym
|
||||
R11 JMP ;
|
||||
|
||||
M: x86.64 %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
RBP RAX MOV ;
|
||||
|
|
|
|||
|
|
@ -379,6 +379,17 @@ big-endian off
|
|||
ds-reg bootstrap-cell neg [+] div-arg MOV
|
||||
] f f f \ fixnum/mod-fast define-sub-primitive
|
||||
|
||||
[
|
||||
arg0 ds-reg [] MOV
|
||||
arg0 ds-reg bootstrap-cell neg [+] OR
|
||||
ds-reg bootstrap-cell ADD
|
||||
arg0 tag-mask get AND
|
||||
arg0 \ f tag-number MOV
|
||||
arg1 1 tag-fixnum MOV
|
||||
arg0 arg1 CMOVE
|
||||
ds-reg [] arg0 MOV
|
||||
] f f f \ both-fixnums? define-sub-primitive
|
||||
|
||||
[
|
||||
arg0 ds-reg [] MOV ! load local number
|
||||
fixnum>slot@ ! turn local number into offset
|
||||
|
|
|
|||
|
|
@ -14,6 +14,9 @@ M: x86 two-operand? t ;
|
|||
HOOK: temp-reg-1 cpu ( -- reg )
|
||||
HOOK: temp-reg-2 cpu ( -- reg )
|
||||
|
||||
HOOK: param-reg-1 cpu ( -- reg )
|
||||
HOOK: param-reg-2 cpu ( -- reg )
|
||||
|
||||
M: x86 %load-immediate MOV ;
|
||||
|
||||
M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ;
|
||||
|
|
@ -90,6 +93,58 @@ M: x86 %shr-imm nip SHR ;
|
|||
M: x86 %sar-imm nip SAR ;
|
||||
M: x86 %not drop NOT ;
|
||||
|
||||
: ?MOV ( dst src -- )
|
||||
2dup = [ 2drop ] [ MOV ] if ; inline
|
||||
|
||||
:: move>args ( src1 src2 -- )
|
||||
{
|
||||
{ [ src1 param-reg-2 = ] [ param-reg-1 src2 ?MOV param-reg-1 param-reg-2 XCHG ] }
|
||||
{ [ src1 param-reg-1 = ] [ param-reg-2 src2 ?MOV ] }
|
||||
{ [ src2 param-reg-1 = ] [ param-reg-2 src1 ?MOV param-reg-1 param-reg-2 XCHG ] }
|
||||
{ [ src2 param-reg-2 = ] [ param-reg-1 src1 ?MOV ] }
|
||||
[
|
||||
param-reg-1 src1 MOV
|
||||
param-reg-2 src2 MOV
|
||||
]
|
||||
} cond ;
|
||||
|
||||
HOOK: %alien-invoke-tail cpu ( func dll -- )
|
||||
|
||||
:: overflow-template ( src1 src2 insn inverse func -- )
|
||||
<label> "no-overflow" set
|
||||
src1 src2 insn call
|
||||
ds-reg [] src1 MOV
|
||||
"no-overflow" get JNO
|
||||
src1 src2 inverse call
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke
|
||||
"no-overflow" resolve-label ; inline
|
||||
|
||||
:: overflow-template-tail ( src1 src2 insn inverse func -- )
|
||||
<label> "no-overflow" set
|
||||
src1 src2 insn call
|
||||
"no-overflow" get JNO
|
||||
src1 src2 inverse call
|
||||
src1 src2 move>args
|
||||
%prepare-alien-invoke
|
||||
func f %alien-invoke-tail
|
||||
"no-overflow" resolve-label
|
||||
ds-reg [] src1 MOV
|
||||
0 RET ; inline
|
||||
|
||||
M: x86 %fixnum-add ( src1 src2 -- )
|
||||
[ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template ;
|
||||
|
||||
M: x86 %fixnum-add-tail ( src1 src2 -- )
|
||||
[ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template-tail ;
|
||||
|
||||
M: x86 %fixnum-sub ( src1 src2 -- )
|
||||
[ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template ;
|
||||
|
||||
M: x86 %fixnum-sub-tail ( src1 src2 -- )
|
||||
[ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template-tail ;
|
||||
|
||||
: bignum@ ( reg n -- op )
|
||||
cells bignum tag-number - [+] ; inline
|
||||
|
||||
|
|
@ -158,9 +213,6 @@ M: x86 %div-float nip DIVSD ;
|
|||
M: x86 %integer>float CVTSI2SD ;
|
||||
M: x86 %float>integer CVTTSD2SI ;
|
||||
|
||||
: ?MOV ( dst src -- )
|
||||
2dup = [ 2drop ] [ MOV ] if ; inline
|
||||
|
||||
M: x86 %copy ( dst src -- ) ?MOV ;
|
||||
|
||||
M: x86 %copy-float ( dst src -- )
|
||||
|
|
|
|||
|
|
@ -325,6 +325,15 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
|
|||
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
|
||||
} ;
|
||||
|
||||
ARTICLE: "cookbook-images" "Image file cookbook"
|
||||
"Factor has the ability to save the entire state of the system into an " { $emphasis "image file" } "."
|
||||
$nl
|
||||
"You can save a custom image if you find yourself loading the same libraries in every Factor session; some libraries take a little while to compile, so saving an image with those libraries loaded can save you a lot of time."
|
||||
$nl
|
||||
"For example, to save an image with the web framework loaded,"
|
||||
{ $code "USE: furnace" "save" }
|
||||
"See " { $link "images" } " for details." ;
|
||||
|
||||
ARTICLE: "cookbook-next" "Next steps"
|
||||
"Once you have read through " { $link "first-program" } " and " { $link "cookbook" } ", the best way to keep learning Factor is to start looking at some simple example programs. Here are a few particularly nice vocabularies which should keep you busy for a little while:"
|
||||
{ $list
|
||||
|
|
@ -349,6 +358,7 @@ ARTICLE: "cookbook" "Factor cookbook"
|
|||
{ $subsection "cookbook-application" }
|
||||
{ $subsection "cookbook-scripts" }
|
||||
{ $subsection "cookbook-compiler" }
|
||||
{ $subsection "cookbook-images" }
|
||||
{ $subsection "cookbook-philosophy" }
|
||||
{ $subsection "cookbook-pitfalls" }
|
||||
{ $subsection "cookbook-next" } ;
|
||||
|
|
|
|||
|
|
@ -285,15 +285,16 @@ M: f ($instance)
|
|||
|
||||
: $see ( element -- ) first [ see ] ($see) ;
|
||||
|
||||
: $see-methods ( element -- ) first [ see-methods ] ($see) ;
|
||||
|
||||
: $synopsis ( element -- ) first [ synopsis write ] ($see) ;
|
||||
|
||||
: $definition ( element -- )
|
||||
"Definition" $heading $see ;
|
||||
|
||||
: $methods ( element -- )
|
||||
"Methods" $heading $see-methods ;
|
||||
first methods [
|
||||
"Methods" $heading
|
||||
[ see-all ] ($see)
|
||||
] unless-empty ;
|
||||
|
||||
: $value ( object -- )
|
||||
"Variable value" $heading
|
||||
|
|
|
|||
|
|
@ -42,10 +42,10 @@ IN: opengl
|
|||
[ glDisableClientState ] each ; inline
|
||||
|
||||
MACRO: all-enabled ( seq quot -- )
|
||||
>r words>values r> [ (all-enabled) ] 2curry ;
|
||||
[ words>values ] dip [ (all-enabled) ] 2curry ;
|
||||
|
||||
MACRO: all-enabled-client-state ( seq quot -- )
|
||||
>r words>values r> [ (all-enabled-client-state) ] 2curry ;
|
||||
[ words>values ] dip [ (all-enabled-client-state) ] 2curry ;
|
||||
|
||||
: do-matrix ( mode quot -- )
|
||||
swap [ glMatrixMode glPushMatrix call ] keep
|
||||
|
|
@ -136,7 +136,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
circle-points concat >c-float-array ;
|
||||
|
||||
: (gen-gl-object) ( quot -- id )
|
||||
>r 1 0 <uint> r> keep *uint ; inline
|
||||
[ 1 0 <uint> ] dip keep *uint ; inline
|
||||
|
||||
: gen-texture ( -- id )
|
||||
[ glGenTextures ] (gen-gl-object) ;
|
||||
|
|
@ -145,7 +145,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
[ glGenBuffers ] (gen-gl-object) ;
|
||||
|
||||
: (delete-gl-object) ( id quot -- )
|
||||
>r 1 swap <uint> r> call ; inline
|
||||
[ 1 swap <uint> ] dip call ; inline
|
||||
|
||||
: delete-texture ( id -- )
|
||||
[ glDeleteTextures ] (delete-gl-object) ;
|
||||
|
|
@ -164,7 +164,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
|
||||
: <gl-buffer> ( target data hint -- id )
|
||||
pick gen-gl-buffer [ [
|
||||
>r dup byte-length swap r> glBufferData
|
||||
[ dup byte-length swap ] dip glBufferData
|
||||
] with-gl-buffer ] keep ;
|
||||
|
||||
: buffer-offset ( int -- alien )
|
||||
|
|
@ -198,9 +198,11 @@ TUPLE: sprite loc dim dim2 dlist texture ;
|
|||
gen-texture [
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
>r >r GL_TEXTURE_2D 0 GL_RGBA r>
|
||||
[
|
||||
[ GL_TEXTURE_2D 0 GL_RGBA ] dip
|
||||
sprite-size2 0 GL_LUMINANCE_ALPHA
|
||||
GL_UNSIGNED_BYTE r> glTexImage2D
|
||||
GL_UNSIGNED_BYTE
|
||||
] dip glTexImage2D
|
||||
] do-attribs
|
||||
] keep ;
|
||||
|
||||
|
|
@ -252,7 +254,7 @@ MEMO: (rect-texture-coords) ( -- seq )
|
|||
[ nip [ free-sprite ] when* ] assoc-each ;
|
||||
|
||||
: with-translation ( loc quot -- )
|
||||
GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline
|
||||
GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline
|
||||
|
||||
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
|
||||
[ first2 [ >fixnum ] bi@ ] bi@ ;
|
||||
|
|
|
|||
|
|
@ -370,9 +370,12 @@ M: word see
|
|||
: (see-methods) ( generic -- seq )
|
||||
"methods" word-prop values natural-sort ;
|
||||
|
||||
: see-methods ( word -- )
|
||||
: methods ( word -- seq )
|
||||
[
|
||||
dup class? [ dup (see-implementors) % ] when
|
||||
dup generic? [ dup (see-methods) % ] when
|
||||
drop
|
||||
] { } make prune see-all ;
|
||||
] { } make prune ;
|
||||
|
||||
: see-methods ( word -- )
|
||||
methods see-all ;
|
||||
|
|
|
|||
|
|
@ -281,6 +281,8 @@ M: object infer-call*
|
|||
\ <complex> { real real } { complex } define-primitive
|
||||
\ <complex> make-foldable
|
||||
|
||||
\ both-fixnums? { object object } { object object object } define-primitive
|
||||
|
||||
\ fixnum+ { fixnum fixnum } { integer } define-primitive
|
||||
\ fixnum+ make-foldable
|
||||
|
||||
|
|
|
|||
|
|
@ -26,12 +26,12 @@ M: word reset
|
|||
] when
|
||||
[
|
||||
over dup def>> "unannotated-def" set-word-prop
|
||||
>r dup def>> r> call define
|
||||
[ dup def>> ] dip call define
|
||||
] with-compilation-unit ; inline
|
||||
|
||||
: word-inputs ( word -- seq )
|
||||
stack-effect [
|
||||
>r datastack r> in>> length tail*
|
||||
[ datastack ] dip in>> length tail*
|
||||
] [
|
||||
datastack
|
||||
] if* ;
|
||||
|
|
@ -41,21 +41,25 @@ M: word reset
|
|||
word-inputs stack.
|
||||
"\\--" print flush ;
|
||||
|
||||
: word-outputs ( word -- seq )
|
||||
stack-effect [
|
||||
[ datastack ] dip out>> length tail*
|
||||
] [
|
||||
datastack
|
||||
] if* ;
|
||||
|
||||
: leaving ( str -- )
|
||||
"/-- Leaving: " write dup .
|
||||
stack-effect [
|
||||
>r datastack r> out>> length tail* stack.
|
||||
] [
|
||||
.s
|
||||
] if* "\\--" print flush ;
|
||||
word-outputs stack.
|
||||
"\\--" print flush ;
|
||||
|
||||
: (watch) ( word def -- def ) over '[ _ entering @ _ leaving ] ;
|
||||
: (watch) ( word def -- def )
|
||||
over '[ _ entering @ _ leaving ] ;
|
||||
|
||||
: watch ( word -- )
|
||||
dup [ (watch) ] annotate ;
|
||||
|
||||
: (watch-vars) ( quot word vars -- newquot )
|
||||
rot
|
||||
: (watch-vars) ( word vars quot -- newquot )
|
||||
'[
|
||||
"--- Entering: " write _ .
|
||||
"--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
|
||||
|
|
@ -63,12 +67,12 @@ M: word reset
|
|||
] ;
|
||||
|
||||
: watch-vars ( word vars -- )
|
||||
dupd [ (watch-vars) ] 2curry annotate ;
|
||||
dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
|
||||
|
||||
GENERIC# annotate-methods 1 ( word quot -- )
|
||||
|
||||
M: generic annotate-methods
|
||||
>r "methods" word-prop values r> [ annotate ] curry each ;
|
||||
[ "methods" word-prop values ] dip [ annotate ] curry each ;
|
||||
|
||||
M: word annotate-methods
|
||||
annotate ;
|
||||
|
|
@ -77,4 +81,4 @@ M: word annotate-methods
|
|||
[ add-breakpoint ] annotate-methods ;
|
||||
|
||||
: breakpoint-if ( word quot -- )
|
||||
[ [ [ break ] when ] rot 3append ] curry annotate-methods ;
|
||||
'[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ;
|
||||
|
|
|
|||
|
|
@ -11,3 +11,7 @@ ARTICLE: "vocab-index" "Vocabulary index"
|
|||
{ $subsection "vocab-tags" }
|
||||
{ $subsection "vocab-authors" }
|
||||
{ $describe-vocab "" } ;
|
||||
|
||||
HELP: words.
|
||||
{ $values { "vocab" "a vocabulary name" } }
|
||||
{ $description "Printings a listing of all the words in a vocabulary, categorized by type." } ;
|
||||
|
|
|
|||
|
|
@ -53,3 +53,20 @@ HELP: draw-world
|
|||
{ $values { "world" world } }
|
||||
{ $description "Redraws a world." }
|
||||
{ $notes "This word should only be called by the UI backend. To force a gadget to redraw from user code, call " { $link relayout-1 } "." } ;
|
||||
|
||||
HELP: find-gl-context
|
||||
{ $values { "gadget" gadget } }
|
||||
{ $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." }
|
||||
{ $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ;
|
||||
|
||||
ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
|
||||
"The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
|
||||
{ $subsection draw-gadget* }
|
||||
"Custom drawing code has access to the full OpenGL API in the " { $vocab-link "opengl" } " vocabulary."
|
||||
$nl
|
||||
"Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:"
|
||||
{ $subsection find-gl-context }
|
||||
"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
|
||||
{ $subsection "ui-paint-coord" }
|
||||
{ $subsection "gl-utilities" }
|
||||
{ $subsection "text-rendering" } ;
|
||||
|
|
|
|||
|
|
@ -191,6 +191,43 @@ HELP: gesture>string
|
|||
{ $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" }
|
||||
} ;
|
||||
|
||||
HELP: left-action
|
||||
{ $class-description "Gesture sent when the user performs a multi-touch three-finger swipe left." } ;
|
||||
|
||||
HELP: right-action
|
||||
{ $class-description "Gesture sent when the user performs a multi-touch three-finger swipe right." } ;
|
||||
|
||||
HELP: up-action
|
||||
{ $class-description "Gesture sent when the user performs a multi-touch three-finger swipe up." } ;
|
||||
|
||||
HELP: down-action
|
||||
{ $class-description "Gesture sent when the user performs a multi-touch three-finger swipe down." } ;
|
||||
|
||||
HELP: zoom-in-action
|
||||
{ $class-description "Gesture sent when the user performs a multi-touch two-finger pinch in." } ;
|
||||
|
||||
HELP: zoom-out-action
|
||||
{ $class-description "Gesture sent when the user performs a multi-touch two-finger pinch out." } ;
|
||||
|
||||
ARTICLE: "gesture-differences" "Gesture handling differences between platforms"
|
||||
"On Mac OS X, the modifier keys map as follows:"
|
||||
{ $table
|
||||
{ { $link S+ } "Shift" }
|
||||
{ { $link A+ } "Command (Apple)" }
|
||||
{ { $link C+ } "Control" }
|
||||
{ { $link M+ } "Option" }
|
||||
}
|
||||
"On Windows and X11:"
|
||||
{ $table
|
||||
{ { $link S+ } "Shift" }
|
||||
{ { $link A+ } "Alt" }
|
||||
{ { $link C+ } "Control" }
|
||||
{ { $link M+ } "Windows key" }
|
||||
}
|
||||
"On Windows, " { $link key-up } " gestures are not reported for all keyboard events."
|
||||
$nl
|
||||
{ $link "multitouch-gestures" } " are only supported on Mac OS X." ;
|
||||
|
||||
ARTICLE: "ui-gestures" "UI gestures"
|
||||
"User actions such as keyboard input and mouse button clicks deliver " { $emphasis "gestures" } " to gadgets. If the direct receiver of the gesture does not handle it, the gesture is passed on to the receiver's parent, and this way it travels up the gadget hierarchy. Gestures which are not handled at some point are ignored."
|
||||
$nl
|
||||
|
|
@ -207,6 +244,9 @@ $nl
|
|||
{ $subsection "ui-user-input" }
|
||||
"Mouse input:"
|
||||
{ $subsection "mouse-gestures" }
|
||||
{ $subsection "multitouch-gestures" }
|
||||
"Guidelines for cross-platform applications:"
|
||||
{ $subsection "gesture-differences" }
|
||||
"Abstractions built on top of gestures:"
|
||||
{ $subsection "ui-commands" }
|
||||
{ $subsection "ui-operations" } ;
|
||||
|
|
@ -301,6 +341,18 @@ $nl
|
|||
"Global variable set when a mouse scroll wheel gesture is sent:"
|
||||
{ $subsection scroll-direction } ;
|
||||
|
||||
ARTICLE: "multitouch-gestures" "Multi-touch gestures"
|
||||
"Multi-touch gestures are only supported on Mac OS X with newer MacBook and MacBook Pro models."
|
||||
$nl
|
||||
"Three-finger swipe:"
|
||||
{ $subsection left-action }
|
||||
{ $subsection right-action }
|
||||
{ $subsection up-action }
|
||||
{ $subsection down-action }
|
||||
"Two-finger pinch:"
|
||||
{ $subsection zoom-in-action }
|
||||
{ $subsection zoom-out-action } ;
|
||||
|
||||
ARTICLE: "action-gestures" "Action gestures"
|
||||
"Action gestures exist to keep keyboard shortcuts for common clipboard operations consistent."
|
||||
{ $subsection cut-action }
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: ui.gadgets ui.gestures help.markup help.syntax
|
||||
kernel classes strings opengl.gl models math.geometry.rect ;
|
||||
kernel classes strings opengl opengl.gl models
|
||||
math.geometry.rect ;
|
||||
IN: ui.render
|
||||
|
||||
HELP: gadget
|
||||
|
|
@ -128,21 +129,11 @@ $nl
|
|||
{ $subsection draw-string }
|
||||
{ $subsection draw-text } ;
|
||||
|
||||
ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
|
||||
"The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
|
||||
{ $subsection draw-gadget* }
|
||||
"Custom drawing code has access to the full OpenGL API in the " { $vocab-link "opengl" } " vocabulary."
|
||||
$nl
|
||||
ARTICLE: "ui-paint-coord" "The UI co-ordinate system"
|
||||
"The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is not saved or restored when rendering a gadget. Instead, the origin of the gadget relative to the OpenGL context is stored in a variable:"
|
||||
{ $subsection origin }
|
||||
"Custom drawing implementations can translate co-ordinates manually, or save and restore the " { $link GL_MODELVIEW } " matrix."
|
||||
"Custom drawing implementations can translate co-ordinates manually, or save and restore the " { $link GL_MODELVIEW } " matrix using a word such as " { $link with-translation } "."
|
||||
$nl
|
||||
"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
|
||||
$nl
|
||||
"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $snippet "clipped?" } " slot to " { $link t } " in the gadget's constructor."
|
||||
$nl
|
||||
"Saving the " { $link GL_MODELVIEW } " matrix and enabling/disabling flags can be done in a clean way using the combinators documented in the following section."
|
||||
{ $subsection "gl-utilities" }
|
||||
{ $subsection "text-rendering" } ;
|
||||
"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $slot "clipped?" } " slot to " { $link t } " in the gadget's constructor." ;
|
||||
|
||||
ABOUT: "ui-paint-custom"
|
||||
|
|
|
|||
|
|
@ -76,17 +76,6 @@ $nl
|
|||
|
||||
;
|
||||
|
||||
ARTICLE: "ui-tool-tutorial" "UI tool tutorial"
|
||||
"The following is an example of a typical session with the UI which should give you a taste of its power:"
|
||||
{ $list
|
||||
{ "You decide to refactor some code, and move a few words from a source file you have already loaded, into a new source file." }
|
||||
{ "You press " { $operation edit } " in the listener, which displays a gadget where you can type part of a loaded file's name, and then press " { $snippet "RET" } " when the correct completion is highlighted. This opens the file in your editor." }
|
||||
{ "You refactor your words, move them to a new source file, and load the new file using " { $link run-file } "." }
|
||||
{ "Interactively testing the new code reveals a problem with one particular code snippet, so you enter it in the listener's input area, and press " { $operation walk } " to invoke the single stepper." }
|
||||
{ "Single stepping through the code makes the problem obvious, so you right-click on a presentation of the broken word in the stepper, and choose " { $strong "Edit" } " from the menu." }
|
||||
{ "After fixing the problem in the source editor, you right click on the word in the stepper and invoke " { $strong "Reload" } " from the menu." }
|
||||
} ;
|
||||
|
||||
ARTICLE: "ui-completion-words" "Word completion popup"
|
||||
"Clicking a word in the word completion popup displays the word definition in the " { $link "ui-browser" } ". Pressing " { $snippet "RET" } " with a word selected inserts the word name in the listener, along with a " { $link POSTPONE: USE: } " declaration (if necessary)."
|
||||
{ $operations \ $operations } ;
|
||||
|
|
@ -110,18 +99,16 @@ $nl
|
|||
{ $subsection "ui-completion-sources" } ;
|
||||
|
||||
ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
|
||||
"See " { $link "gesture-differences" } " to find out how your platform's modifier keys map to modifiers in the Factor UI."
|
||||
{ $command-map workspace "tool-switching" }
|
||||
{ $command-map workspace "scrolling" }
|
||||
{ $command-map workspace "workflow" }
|
||||
{ $command-map workspace "multi-touch" }
|
||||
{ $heading "Implementation" }
|
||||
"Workspaces are instances of " { $link workspace } "." ;
|
||||
{ $command-map workspace "multi-touch" } ;
|
||||
|
||||
ARTICLE: "ui-tools" "UI developer tools"
|
||||
"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
|
||||
$nl
|
||||
"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
|
||||
{ $subsection "ui-tool-tutorial" }
|
||||
{ $subsection "ui-workspace-keys" }
|
||||
{ $subsection "ui-presentations" }
|
||||
{ $subsection "ui-completion" }
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax strings quotations debugger
|
||||
io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ;
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect colors ;
|
||||
IN: ui
|
||||
|
||||
HELP: windows
|
||||
|
|
@ -47,18 +47,19 @@ HELP: (open-window)
|
|||
{ $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
|
||||
{ $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
|
||||
|
||||
HELP: raise-window
|
||||
{ $values { "gadget" gadget } }
|
||||
{ $description "Makes the native window containing the given gadget the front-most window." } ;
|
||||
|
||||
HELP: with-ui
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation, starting the UI first if necessary." }
|
||||
{ $notes "This combinator should be used in the " { $link POSTPONE: MAIN: } " word of a vocabulary, in order for the vocabulary to work when run from the UI listener (" { $snippet "\"my-app\" run" } " and the command line (" { $snippet "./factor -run=my-app" } ")." }
|
||||
{ $examples "The " { $vocab-link "hello-ui" } " vocabulary implements a simple UI application which uses this combinator." } ;
|
||||
|
||||
ARTICLE: "ui-glossary" "UI glossary"
|
||||
{ $table
|
||||
{ "color specifier"
|
||||
{ "an array of four elements, all numbers between 0 and 1:"
|
||||
{ $list
|
||||
"red"
|
||||
"green"
|
||||
"blue"
|
||||
"alpha - 0 is completely transparent, 1 is completely opaque"
|
||||
}
|
||||
}
|
||||
}
|
||||
{ "color" { "an instance of " { $link color } } }
|
||||
{ "dimension" "a pair of integers denoting pixel size on screen" }
|
||||
{ "font specifier"
|
||||
{ "an array of three elements:"
|
||||
|
|
@ -129,9 +130,7 @@ ARTICLE: "ui-backend" "Developing UI backends"
|
|||
"UI backends may implement the " { $link "clipboard-protocol" } "." ;
|
||||
|
||||
ARTICLE: "ui-backend-init" "UI initialization and the event loop"
|
||||
"An UI backend is required to define a word to start the UI:"
|
||||
{ $subsection ui }
|
||||
"This word should contain backend initialization, together with some boilerplate:"
|
||||
"An UI backend is required to define a method on the " { $link ui } " word. This word should contain backend initialization, together with some boilerplate:"
|
||||
{ $code
|
||||
"IN: shells"
|
||||
""
|
||||
|
|
@ -163,10 +162,6 @@ ARTICLE: "ui-backend-windows" "UI backend window management"
|
|||
"If the user clicks the window's close box, you must call the following word:"
|
||||
{ $subsection close-window } ;
|
||||
|
||||
HELP: raise-window
|
||||
{ $values { "gadget" gadget } }
|
||||
{ $description "Makes the native window containing the given gadget the front-most window." } ;
|
||||
|
||||
ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
|
||||
"A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."
|
||||
{ $subsection "ui-layout-basics" }
|
||||
|
|
@ -240,7 +235,23 @@ $nl
|
|||
{ $subsection "clipboard-protocol" }
|
||||
{ $see-also "ui-layout-impl" } ;
|
||||
|
||||
ARTICLE: "starting-ui" "Starting the UI"
|
||||
"The UI starts automatically where possible:"
|
||||
{ $list
|
||||
{ "On Windows, the UI starts when the Factor executable is run." }
|
||||
{ "On X11, the UI starts if the " { $snippet "DISPLAY" } " environment variable is set." }
|
||||
{ "On Mac OS X, the UI starts if the " { $snippet "Factor.app" } " application bundle is run." }
|
||||
}
|
||||
"In all cases, passing the " { $snippet "-run=listener" } " command line switch starts the terminal listener instead. The UI can be started from the terminal listener using a word:"
|
||||
{ $subsection ui }
|
||||
"To run the terminal listener and the UI simultaneously, start the UI in a new thread:"
|
||||
{ $code "USING: threads ui ;" "[ ui ] in-thread" }
|
||||
"The main word of a vocabulary implementing a UI application should use a combinator to ensure that the application works when run from the command line as well as in the UI listener:"
|
||||
{ $subsection with-ui } ;
|
||||
|
||||
ARTICLE: "ui" "UI framework"
|
||||
"The " { $vocab-link "ui" } " vocabulary hierarchy implements the Factor UI framework. The implementation relies on a small amount of platform-specific code to open windows and receive keyboard and mouse events; UI gadgets are rendered using OpenGL."
|
||||
{ $subsection "starting-ui" }
|
||||
{ $subsection "ui-glossary" }
|
||||
{ $subsection "building-ui" }
|
||||
{ $subsection "new-gadgets" }
|
||||
|
|
|
|||
|
|
@ -285,7 +285,7 @@ SYMBOL: nc-buttons
|
|||
swap [ push ] [ delete ] if ;
|
||||
|
||||
: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ;
|
||||
: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
|
||||
: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
|
||||
|
||||
: mouse-absolute>relative ( lparam handle -- array )
|
||||
[ >lo-hi ] dip
|
||||
|
|
@ -338,8 +338,8 @@ SYMBOL: nc-buttons
|
|||
>lo-hi swap window move-hand fire-motion ;
|
||||
|
||||
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
|
||||
lParam mouse-wheel
|
||||
hWnd mouse-absolute>relative
|
||||
wParam mouse-wheel
|
||||
lParam hWnd mouse-absolute>relative
|
||||
hWnd window send-wheel ;
|
||||
|
||||
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
|
||||
|
|
|
|||
|
|
@ -348,6 +348,7 @@ tuple
|
|||
{
|
||||
{ "(execute)" "words.private" }
|
||||
{ "(call)" "kernel.private" }
|
||||
{ "both-fixnums?" "math.private" }
|
||||
{ "fixnum+fast" "math.private" }
|
||||
{ "fixnum-fast" "math.private" }
|
||||
{ "fixnum*fast" "math.private" }
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ HELP: no-math-method
|
|||
HELP: math-method
|
||||
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
|
||||
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
|
||||
{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float=>+ ]" } } ;
|
||||
{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ { fixnum float } declare [ >float ] dip float=>+ ]" } } ;
|
||||
|
||||
HELP: math-class
|
||||
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
|
||||
|
|
|
|||
|
|
@ -56,9 +56,11 @@ ERROR: no-math-method left right generic ;
|
|||
|
||||
: math-method ( word class1 class2 -- quot )
|
||||
2dup and [
|
||||
2dup math-upgrade
|
||||
[ math-class-max over order min-class applicable-method ] dip
|
||||
prepend
|
||||
[
|
||||
2dup 2array , \ declare ,
|
||||
2dup math-upgrade %
|
||||
math-class-max over order min-class applicable-method %
|
||||
] [ ] make
|
||||
] [
|
||||
2drop object-method
|
||||
] if ;
|
||||
|
|
@ -67,13 +69,9 @@ SYMBOL: picker
|
|||
|
||||
: math-vtable ( picker quot -- quot )
|
||||
[
|
||||
swap picker set
|
||||
picker get , [ tag 0 eq? ] %
|
||||
num-tags get swap [ bootstrap-type>class ] prepose map
|
||||
unclip ,
|
||||
[
|
||||
picker get , [ tag 1 fixnum-fast ] % , \ dispatch ,
|
||||
] [ ] make , \ if ,
|
||||
[ , \ tag , ]
|
||||
[ num-tags get swap [ bootstrap-type>class ] prepose map , ] bi*
|
||||
\ dispatch ,
|
||||
] [ ] make ; inline
|
||||
|
||||
TUPLE: math-combination ;
|
||||
|
|
@ -84,13 +82,18 @@ M: math-combination make-default-method
|
|||
M: math-combination perform-combination
|
||||
drop
|
||||
dup
|
||||
[
|
||||
\ both-fixnums? ,
|
||||
dup fixnum bootstrap-word dup math-method ,
|
||||
\ over [
|
||||
dup math-class? [
|
||||
\ dup [ [ 2dup ] dip math-method ] math-vtable
|
||||
] [
|
||||
over object-method
|
||||
] if nip
|
||||
] math-vtable nip define ;
|
||||
] math-vtable nip ,
|
||||
\ if ,
|
||||
] [ ] make define ;
|
||||
|
||||
PREDICATE: math-generic < generic ( word -- ? )
|
||||
"combination" word-prop math-combination? ;
|
||||
|
|
|
|||
123
misc/factor.el
123
misc/factor.el
|
|
@ -118,6 +118,10 @@ buffer."
|
|||
"Face for parsing words."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-declaration (face-default-spec font-lock-keyword-face)
|
||||
"Face for declaration words (inline, parsing ...)."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-comment (face-default-spec font-lock-comment-face)
|
||||
"Face for comments."
|
||||
:group 'factor-faces)
|
||||
|
|
@ -178,10 +182,15 @@ buffer."
|
|||
"UNION:" "USE:" "USING:" "V{" "VAR:" "VARS:" "W{"))
|
||||
|
||||
(defconst factor--regex-parsing-words-ext
|
||||
(regexp-opt '("B" "call-next-method" "delimiter" "f" "flushable" "foldable"
|
||||
"initial:" "inline" "parsing" "read-only" "recursive")
|
||||
(regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
|
||||
'words))
|
||||
|
||||
(defconst factor--declaration-words
|
||||
'("flushable" "foldable" "inline" "parsing" "recursive"))
|
||||
|
||||
(defconst factor--regex-declaration-words
|
||||
(regexp-opt factor--declaration-words 'words))
|
||||
|
||||
(defsubst factor--regex-second-word (prefixes)
|
||||
(format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
|
||||
|
||||
|
|
@ -202,7 +211,7 @@ buffer."
|
|||
|
||||
(defconst factor--regex-stack-effect " ( .* )")
|
||||
|
||||
(defconst factor--regex-using-line "^USING: +\\([^;]*\\);")
|
||||
(defconst factor--regex-using-lines "^USING: +\\(\\([^;]\\|[\n\r\f]\\)*\\);")
|
||||
|
||||
(defconst factor--regex-use-line "^USE: +\\(.*\\)$")
|
||||
|
||||
|
|
@ -213,30 +222,31 @@ buffer."
|
|||
'(2 'factor-font-lock-parsing-word)))
|
||||
factor--parsing-words)
|
||||
(,factor--regex-parsing-words-ext . 'factor-font-lock-parsing-word)
|
||||
(,factor--regex-declaration-words 1 'factor-font-lock-declaration)
|
||||
(,factor--regex-word-definition 2 'factor-font-lock-word-definition)
|
||||
(,factor--regex-type-definition 2 'factor-font-lock-type-definition)
|
||||
(,factor--regex-parent-type 1 'factor-font-lock-type-definition)
|
||||
(,factor--regex-constructor . 'factor-font-lock-constructor)
|
||||
(,factor--regex-setter . 'factor-font-lock-setter-word)
|
||||
(,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
|
||||
(,factor--regex-using-line 1 'factor-font-lock-vocabulary-name)
|
||||
(,factor--regex-using-lines 1 'factor-font-lock-vocabulary-name)
|
||||
(,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))
|
||||
"Font lock keywords definition for Factor mode.")
|
||||
|
||||
|
||||
;;; Factor mode syntax:
|
||||
|
||||
(defconst factor--regexp-word-starters
|
||||
(defconst factor--regex-definition-starters
|
||||
(regexp-opt '("TUPLE" "MACRO" "MACRO:" "M" ":" "")))
|
||||
|
||||
(defconst factor--regexp-word-start
|
||||
(format "^\\(%s:\\) " factor--regexp-word-starters))
|
||||
(defconst factor--regex-definition-start
|
||||
(format "^\\(%s:\\) " factor--regex-definition-starters))
|
||||
|
||||
(defconst factor--regex-definition-end
|
||||
(format "\\(;\\( +%s\\)*\\)" factor--regex-declaration-words))
|
||||
|
||||
(defconst factor--font-lock-syntactic-keywords
|
||||
`((,(format "^\\(%s\\)\\(:\\)" factor--regexp-word-starters)
|
||||
(1 "w") (2 "(;"))
|
||||
("\\(;\\)" (1 "):"))
|
||||
("\\(#!\\)" (1 "<"))
|
||||
`(("\\(#!\\)" (1 "<"))
|
||||
(" \\(!\\)" (1 "<"))
|
||||
("^\\(!\\)" (1 "<"))
|
||||
("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))))
|
||||
|
|
@ -290,6 +300,7 @@ buffer."
|
|||
(modify-syntax-entry ?\" "\"" factor-mode-syntax-table)
|
||||
(modify-syntax-entry ?\\ "/" factor-mode-syntax-table)))
|
||||
|
||||
|
||||
;;; symbol-at-point
|
||||
|
||||
(defun factor--beginning-of-symbol ()
|
||||
|
|
@ -323,7 +334,7 @@ buffer."
|
|||
(save-excursion
|
||||
(beginning-of-buffer)
|
||||
(while (not iw)
|
||||
(if (not (re-search-forward factor--regexp-word-start nil t))
|
||||
(if (not (re-search-forward factor--regex-definition-start nil t))
|
||||
(setq iw factor-default-indent-width)
|
||||
(forward-line)
|
||||
(when (looking-at word-cont)
|
||||
|
|
@ -336,13 +347,17 @@ buffer."
|
|||
(defsubst factor--ppss-brackets-start ()
|
||||
(nth 1 (syntax-ppss)))
|
||||
|
||||
(defun factor--ppss-brackets-end ()
|
||||
(save-excursion
|
||||
(goto-char (factor--ppss-brackets-start))
|
||||
(condition-case nil
|
||||
(progn (forward-sexp)
|
||||
(1- (point)))
|
||||
(error -1))))
|
||||
|
||||
(defsubst factor--indentation-at (pos)
|
||||
(save-excursion (goto-char pos) (current-indentation)))
|
||||
|
||||
(defconst factor--regex-closing-paren "[])}]")
|
||||
(defsubst factor--at-closing-paren-p ()
|
||||
(looking-at factor--regex-closing-paren))
|
||||
|
||||
(defsubst factor--at-first-char-p ()
|
||||
(= (- (point) (line-beginning-position)) (current-indentation)))
|
||||
|
||||
|
|
@ -350,16 +365,28 @@ buffer."
|
|||
(format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
|
||||
"PRIVATE>" "<PRIVATE" "SYMBOL:" "USE:"))))
|
||||
|
||||
(defconst factor--regex-begin-of-def
|
||||
(format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
|
||||
factor--regex-definition-start
|
||||
factor--regex-single-liner))
|
||||
|
||||
(defconst factor--regex-end-of-def-line
|
||||
(format "^.*%s" factor--regex-definition-end))
|
||||
|
||||
(defconst factor--regex-end-of-def
|
||||
(format "\\(%s\\)\\|\\(%s .*\\)"
|
||||
factor--regex-end-of-def-line
|
||||
factor--regex-single-liner))
|
||||
|
||||
(defsubst factor--at-begin-of-def ()
|
||||
(looking-at factor--regexp-word-start))
|
||||
(looking-at factor--regex-begin-of-def))
|
||||
|
||||
(defsubst factor--at-end-of-def ()
|
||||
(looking-at factor--regex-end-of-def))
|
||||
|
||||
(defsubst factor--looking-at-emptiness ()
|
||||
(looking-at "^[ \t]*$"))
|
||||
|
||||
(defun factor--at-end-of-def ()
|
||||
(or (looking-at ".*;[ \t]*$")
|
||||
(looking-at factor--regex-single-liner)))
|
||||
|
||||
(defun factor--at-setter-line ()
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
|
|
@ -382,13 +409,12 @@ buffer."
|
|||
(defun factor--indent-in-brackets ()
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(when (or (and (re-search-forward factor--regex-closing-paren
|
||||
(line-end-position) t)
|
||||
(not (backward-char)))
|
||||
(> (factor--ppss-brackets-depth) 0))
|
||||
(let ((op (factor--ppss-brackets-start)))
|
||||
(when (> (line-number-at-pos) (line-number-at-pos op))
|
||||
(if (factor--at-closing-paren-p)
|
||||
(when (> (factor--ppss-brackets-depth) 0)
|
||||
(let ((op (factor--ppss-brackets-start))
|
||||
(cl (factor--ppss-brackets-end))
|
||||
(ln (line-number-at-pos)))
|
||||
(when (> ln (line-number-at-pos op))
|
||||
(if (and (> cl 0) (= ln (line-number-at-pos cl)))
|
||||
(factor--indentation-at op)
|
||||
(factor--increased-indentation (factor--indentation-at op))))))))
|
||||
|
||||
|
|
@ -417,7 +443,8 @@ buffer."
|
|||
(forward-line -1))
|
||||
(if (or (factor--at-end-of-def) (factor--at-setter-line))
|
||||
(factor--decreased-indentation)
|
||||
(if (factor--at-begin-of-def)
|
||||
(if (and (factor--at-begin-of-def)
|
||||
(not (looking-at factor--regex-using-lines)))
|
||||
(factor--increased-indentation)
|
||||
(current-indentation)))))
|
||||
|
||||
|
|
@ -448,6 +475,12 @@ buffer."
|
|||
(defvar factor-mode-map (make-sparse-keymap)
|
||||
"Key map used by Factor mode.")
|
||||
|
||||
(defsubst factor--beginning-of-defun (times)
|
||||
(re-search-backward factor--regex-begin-of-def nil t times))
|
||||
|
||||
(defsubst factor--end-of-defun ()
|
||||
(re-search-forward factor--regex-end-of-def nil t))
|
||||
|
||||
;;;###autoload
|
||||
(defun factor-mode ()
|
||||
"A mode for editing programs written in the Factor programming language.
|
||||
|
|
@ -469,8 +502,9 @@ buffer."
|
|||
|
||||
(set-syntax-table factor-mode-syntax-table)
|
||||
;; Defun navigation
|
||||
(setq defun-prompt-regexp "[^ :]+")
|
||||
(set (make-local-variable 'open-paren-in-column-0-is-defun-start) t)
|
||||
(set (make-local-variable 'beginning-of-defun-function) 'factor--beginning-of-defun)
|
||||
(set (make-local-variable 'end-of-defun-function) 'factor--end-of-defun)
|
||||
(set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
|
||||
;; Indentation
|
||||
(set (make-local-variable 'indent-line-function) 'factor--indent-line)
|
||||
(setq factor-indent-width (factor--guess-indent-width))
|
||||
|
|
@ -506,7 +540,8 @@ buffer."
|
|||
(defun factor--listener-process (&optional start)
|
||||
(or (and (buffer-live-p factor--listener-buffer)
|
||||
(get-buffer-process factor--listener-buffer))
|
||||
(when start
|
||||
(if (not start)
|
||||
(error "No running factor listener. Try M-x run-factor.")
|
||||
(factor--listener-start-process)
|
||||
(factor--listener-process t))))
|
||||
|
||||
|
|
@ -566,7 +601,6 @@ buffer."
|
|||
(defun factor--current-listener-vocab ()
|
||||
(car (factor--listener-send-cmd "USING: parser ; in get .")))
|
||||
|
||||
|
||||
(defun factor--set-current-listener-vocab (&optional vocab)
|
||||
(factor--listener-send-cmd
|
||||
(format "IN: %s" (or vocab (factor--current-buffer-vocab))))
|
||||
|
|
@ -630,9 +664,8 @@ buffer."
|
|||
(defun factor-see-current-word (&optional word)
|
||||
"Echo in the minibuffer information about word at point."
|
||||
(interactive)
|
||||
(unless (factor--listener-process)
|
||||
(error "No factor listener running. Try M-x run-factor"))
|
||||
(let ((word (or word (factor--symbol-at-point)))
|
||||
(let* ((proc (factor--listener-process))
|
||||
(word (or word (factor--symbol-at-point)))
|
||||
(msg (factor--see-current-word word)))
|
||||
(if msg (message "%s" msg)
|
||||
(if word (message "No help found for '%s'" word)
|
||||
|
|
@ -751,9 +784,8 @@ buffer."
|
|||
(defvar factor--help-history nil)
|
||||
|
||||
(defun factor--listener-show-help (&optional see)
|
||||
(unless (factor--listener-process)
|
||||
(error "No running factor listener. Try M-x run-factor"))
|
||||
(let* ((def (factor--symbol-at-point))
|
||||
(let* ((proc (factor--listener-process))
|
||||
(def (factor--symbol-at-point))
|
||||
(prompt (format "See%s help on%s: " (if see " short" "")
|
||||
(if def (format " (%s)" def) "")))
|
||||
(ask (or (not (eq major-mode 'factor-mode))
|
||||
|
|
@ -762,8 +794,7 @@ buffer."
|
|||
(cmd (format "\\ %s %s"
|
||||
(if ask (read-string prompt nil 'factor--help-history def) def)
|
||||
(if see "see" "help")))
|
||||
(hb (factor--listener-help-buffer))
|
||||
(proc (factor--listener-process)))
|
||||
(hb (factor--listener-help-buffer)))
|
||||
(comint-redirect-send-command-to-process cmd hb proc nil)
|
||||
(pop-to-buffer hb)
|
||||
(beginning-of-buffer hb)))
|
||||
|
|
@ -804,6 +835,13 @@ vocabularies which have been modified on disk."
|
|||
(define-key m (vector '(control ?c) key) cmd)
|
||||
(define-key m (vector '(control ?c) `(control ,key)) cmd))))
|
||||
|
||||
(defun factor--define-auto-indent-key (key)
|
||||
(define-key factor-mode-map (vector key)
|
||||
(lambda (n)
|
||||
(interactive "p")
|
||||
(self-insert-command n)
|
||||
(indent-for-tab-command))))
|
||||
|
||||
(factor--define-key ?f 'factor-run-file)
|
||||
(factor--define-key ?r 'factor-send-region)
|
||||
(factor--define-key ?d 'factor-send-definition)
|
||||
|
|
@ -812,6 +850,9 @@ vocabularies which have been modified on disk."
|
|||
(factor--define-key ?z 'switch-to-factor t)
|
||||
(factor--define-key ?c 'comment-region)
|
||||
|
||||
(factor--define-auto-indent-key ?\])
|
||||
(factor--define-auto-indent-key ?\})
|
||||
|
||||
(define-key factor-mode-map "\C-ch" 'factor-help)
|
||||
(define-key factor-help-mode-map "\C-ch" 'factor-help)
|
||||
(define-key factor-mode-map "\C-m" 'newline-and-indent)
|
||||
|
|
|
|||
41
vm/cpu-ppc.S
41
vm/cpu-ppc.S
|
|
@ -2,6 +2,47 @@
|
|||
in the public domain. */
|
||||
#include "asm.h"
|
||||
|
||||
#define DS_REG r29
|
||||
|
||||
DEF(void,primitive_fixnum_add,(void)):
|
||||
lwz r3,0(DS_REG)
|
||||
lwz r4,-4(DS_REG)
|
||||
subi DS_REG,DS_REG,4
|
||||
li r0,0
|
||||
mtxer r0
|
||||
addo. r5,r3,r4
|
||||
bso add_overflow
|
||||
stw r5,0(DS_REG)
|
||||
blr
|
||||
add_overflow:
|
||||
b MANGLE(overflow_fixnum_add)
|
||||
|
||||
DEF(void,primitive_fixnum_subtract,(void)):
|
||||
lwz r3,0(DS_REG)
|
||||
lwz r4,-4(DS_REG)
|
||||
subi DS_REG,DS_REG,4
|
||||
li r0,0
|
||||
mtxer r0
|
||||
subfo. r5,r3,r4
|
||||
bso sub_overflow
|
||||
stw r5,0(DS_REG)
|
||||
blr
|
||||
sub_overflow:
|
||||
b MANGLE(overflow_fixnum_subtract)
|
||||
|
||||
DEF(void,primitive_fixnum_multiply,(void)):
|
||||
lwz r3,0(DS_REG)
|
||||
lwz r4,-4(DS_REG)
|
||||
subi DS_REG,DS_REG,4
|
||||
srawi r3,r3,3
|
||||
mullwo. r5,r3,r4
|
||||
bso multiply_overflow
|
||||
stw r5,0(DS_REG)
|
||||
blr
|
||||
multiply_overflow:
|
||||
srawi r4,r4,3
|
||||
b MANGLE(overflow_fixnum_multiply)
|
||||
|
||||
/* Note that the XT is passed to the quotation in r11 */
|
||||
#define CALL_OR_JUMP_QUOT \
|
||||
lwz r11,9(r3) /* load quotation-xt slot */ XX \
|
||||
|
|
|
|||
|
|
@ -12,6 +12,10 @@ and the callstack top is passed in EDX */
|
|||
|
||||
#define NV_TEMP_REG %ebx
|
||||
|
||||
#define ARITH_TEMP_1 %ebp
|
||||
#define ARITH_TEMP_2 %ebx
|
||||
#define DIV_RESULT %eax
|
||||
|
||||
#define CELL_SIZE 4
|
||||
#define STACK_PADDING 12
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,10 @@
|
|||
|
||||
#define NV_TEMP_REG %rbp
|
||||
|
||||
#define ARITH_TEMP_1 %r8
|
||||
#define ARITH_TEMP_2 %r9
|
||||
#define DIV_RESULT %rax
|
||||
|
||||
#ifdef WINDOWS
|
||||
|
||||
#define ARG0 %rcx
|
||||
|
|
|
|||
36
vm/cpu-x86.S
36
vm/cpu-x86.S
|
|
@ -1,3 +1,39 @@
|
|||
DEF(void,primitive_fixnum_add,(void)):
|
||||
mov (DS_REG),ARG0
|
||||
mov -CELL_SIZE(DS_REG),ARG1
|
||||
sub $CELL_SIZE,DS_REG
|
||||
mov ARG1,ARITH_TEMP_1
|
||||
add ARG0,ARITH_TEMP_1
|
||||
jo MANGLE(overflow_fixnum_add)
|
||||
mov ARITH_TEMP_1,(DS_REG)
|
||||
ret
|
||||
|
||||
DEF(void,primitive_fixnum_subtract,(void)):
|
||||
mov (DS_REG),ARG1
|
||||
mov -CELL_SIZE(DS_REG),ARG0
|
||||
sub $CELL_SIZE,DS_REG
|
||||
mov ARG0,ARITH_TEMP_1
|
||||
sub ARG1,ARITH_TEMP_1
|
||||
jo MANGLE(overflow_fixnum_subtract)
|
||||
mov ARITH_TEMP_1,(DS_REG)
|
||||
ret
|
||||
|
||||
DEF(void,primitive_fixnum_multiply,(void)):
|
||||
mov (DS_REG),ARITH_TEMP_1
|
||||
mov ARITH_TEMP_1,DIV_RESULT
|
||||
mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
|
||||
sar $3,ARITH_TEMP_2
|
||||
sub $CELL_SIZE,DS_REG
|
||||
imul ARITH_TEMP_2
|
||||
jo multiply_overflow
|
||||
mov DIV_RESULT,(DS_REG)
|
||||
ret
|
||||
multiply_overflow:
|
||||
sar $3,ARITH_TEMP_1
|
||||
mov ARITH_TEMP_1,ARG0
|
||||
mov ARITH_TEMP_2,ARG1
|
||||
jmp MANGLE(overflow_fixnum_multiply)
|
||||
|
||||
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
|
||||
PUSH_NONVOLATILE
|
||||
mov ARG0,NV_TEMP_REG
|
||||
|
|
|
|||
61
vm/math.c
61
vm/math.c
|
|
@ -1,7 +1,6 @@
|
|||
#include "master.h"
|
||||
|
||||
/* Fixnums */
|
||||
|
||||
F_FIXNUM to_fixnum(CELL tagged)
|
||||
{
|
||||
switch(TAG(tagged))
|
||||
|
|
@ -31,37 +30,21 @@ void primitive_float_to_fixnum(void)
|
|||
drepl(tag_fixnum(float_to_fixnum(dpeek())));
|
||||
}
|
||||
|
||||
#define POP_FIXNUMS(x,y) \
|
||||
F_FIXNUM y = untag_fixnum_fast(dpop()); \
|
||||
F_FIXNUM x = untag_fixnum_fast(dpeek());
|
||||
|
||||
void primitive_fixnum_add(void)
|
||||
/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
|
||||
overflow, they call these functions. */
|
||||
F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y)
|
||||
{
|
||||
POP_FIXNUMS(x,y)
|
||||
drepl(allot_integer(x + y));
|
||||
drepl(tag_bignum(fixnum_to_bignum(
|
||||
untag_fixnum_fast(x) + untag_fixnum_fast(y))));
|
||||
}
|
||||
|
||||
void primitive_fixnum_subtract(void)
|
||||
F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y)
|
||||
{
|
||||
POP_FIXNUMS(x,y)
|
||||
drepl(allot_integer(x - y));
|
||||
drepl(tag_bignum(fixnum_to_bignum(
|
||||
untag_fixnum_fast(x) - untag_fixnum_fast(y))));
|
||||
}
|
||||
|
||||
/* Multiply two integers, and trap overflow.
|
||||
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
|
||||
void primitive_fixnum_multiply(void)
|
||||
{
|
||||
POP_FIXNUMS(x,y)
|
||||
|
||||
if(x == 0 || y == 0)
|
||||
drepl(tag_fixnum(0));
|
||||
else
|
||||
{
|
||||
F_FIXNUM prod = x * y;
|
||||
/* if this is not equal, we have overflow */
|
||||
if(prod / x == y)
|
||||
drepl(allot_integer(prod));
|
||||
else
|
||||
F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y)
|
||||
{
|
||||
F_ARRAY *bx = fixnum_to_bignum(x);
|
||||
REGISTER_BIGNUM(bx);
|
||||
|
|
@ -69,12 +52,13 @@ void primitive_fixnum_multiply(void)
|
|||
UNREGISTER_BIGNUM(bx);
|
||||
drepl(tag_bignum(bignum_multiply(bx,by)));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* Division can only overflow when we are dividing the most negative fixnum
|
||||
by -1. */
|
||||
void primitive_fixnum_divint(void)
|
||||
{
|
||||
POP_FIXNUMS(x,y)
|
||||
F_FIXNUM y = untag_fixnum_fast(dpop()); \
|
||||
F_FIXNUM x = untag_fixnum_fast(dpeek());
|
||||
F_FIXNUM result = x / y;
|
||||
if(result == -FIXNUM_MIN)
|
||||
drepl(allot_integer(-FIXNUM_MIN));
|
||||
|
|
@ -99,31 +83,30 @@ void primitive_fixnum_divmod(void)
|
|||
}
|
||||
|
||||
/*
|
||||
* Note the hairy overflow check.
|
||||
* If we're shifting right by n bits, we won't overflow as long as none of the
|
||||
* high WORD_SIZE-TAG_BITS-n bits are set.
|
||||
*/
|
||||
#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
|
||||
#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
|
||||
#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
|
||||
|
||||
void primitive_fixnum_shift(void)
|
||||
{
|
||||
POP_FIXNUMS(x,y)
|
||||
F_FIXNUM y = untag_fixnum_fast(dpop()); \
|
||||
F_FIXNUM x = untag_fixnum_fast(dpeek());
|
||||
|
||||
if(x == 0 || y == 0)
|
||||
{
|
||||
drepl(tag_fixnum(x));
|
||||
if(x == 0)
|
||||
return;
|
||||
}
|
||||
else if(y < 0)
|
||||
{
|
||||
if(y <= -WORD_SIZE)
|
||||
drepl(x < 0 ? tag_fixnum(-1) : tag_fixnum(0));
|
||||
else
|
||||
y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
|
||||
drepl(tag_fixnum(x >> -y));
|
||||
return;
|
||||
}
|
||||
else if(y < WORD_SIZE - TAG_BITS)
|
||||
{
|
||||
F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
|
||||
if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
|
||||
if(!(BRANCHLESS_ABS(x) & mask))
|
||||
{
|
||||
drepl(tag_fixnum(x << y));
|
||||
return;
|
||||
|
|
|
|||
|
|
@ -12,6 +12,11 @@ void primitive_float_to_fixnum(void);
|
|||
void primitive_fixnum_add(void);
|
||||
void primitive_fixnum_subtract(void);
|
||||
void primitive_fixnum_multiply(void);
|
||||
|
||||
DLLEXPORT F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y);
|
||||
DLLEXPORT F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y);
|
||||
DLLEXPORT F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y);
|
||||
|
||||
void primitive_fixnum_divint(void);
|
||||
void primitive_fixnum_divmod(void);
|
||||
void primitive_fixnum_shift(void);
|
||||
|
|
|
|||
Loading…
Reference in New Issue