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

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

db4
Aaron Schaefer 2008-11-29 10:46:32 -05:00
parent db20629a0f f72f9a8f45
commit be7bae07d3
136 changed files with 2030 additions and 1110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/arrays/arrays.factor
View File

@ -8,6 +8,8 @@ UNION: value-type array struct-type ;
M: array c-type ;
M: array c-type-class drop object ;
M: array heap-size unclip heap-size [ * ] reduce ;
M: array c-type-align first c-type-align ;

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

@ -13,13 +13,15 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
class
boxer boxer-quot unboxer unboxer-quot
getter setter
reg-class size align stack-align? ;
: new-c-type ( class -- type )
new
int-regs >>reg-class ;
int-regs >>reg-class
object >>class ;
: <c-type> ( -- type )
\ c-type new-c-type ;
@ -63,6 +65,12 @@ M: string c-type ( name -- type )
] ?if
] if ;
GENERIC: c-type-class ( name -- class )
M: c-type c-type-class class>> ;
M: string c-type-class c-type c-type-class ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
@ -306,6 +314,7 @@ M: long-long-type box-return ( type -- )
[
<c-type>
c-ptr >>class
[ alien-cell ] >>getter
[ set-alien-cell ] >>setter
bootstrap-cell >>size
@ -315,6 +324,7 @@ M: long-long-type box-return ( type -- )
"void*" define-primitive-type
<long-long-type>
integer >>class
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
@ -324,6 +334,7 @@ M: long-long-type box-return ( type -- )
"longlong" define-primitive-type
<long-long-type>
integer >>class
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
@ -333,6 +344,7 @@ M: long-long-type box-return ( type -- )
"ulonglong" define-primitive-type
<c-type>
integer >>class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
@ -342,6 +354,7 @@ M: long-long-type box-return ( type -- )
"long" define-primitive-type
<c-type>
integer >>class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
@ -351,6 +364,7 @@ M: long-long-type box-return ( type -- )
"ulong" define-primitive-type
<c-type>
integer >>class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
@ -360,6 +374,7 @@ M: long-long-type box-return ( type -- )
"int" define-primitive-type
<c-type>
integer >>class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
@ -369,6 +384,7 @@ M: long-long-type box-return ( type -- )
"uint" define-primitive-type
<c-type>
fixnum >>class
[ alien-signed-2 ] >>getter
[ set-alien-signed-2 ] >>setter
2 >>size
@ -378,6 +394,7 @@ M: long-long-type box-return ( type -- )
"short" define-primitive-type
<c-type>
fixnum >>class
[ alien-unsigned-2 ] >>getter
[ set-alien-unsigned-2 ] >>setter
2 >>size
@ -387,6 +404,7 @@ M: long-long-type box-return ( type -- )
"ushort" define-primitive-type
<c-type>
fixnum >>class
[ alien-signed-1 ] >>getter
[ set-alien-signed-1 ] >>setter
1 >>size
@ -396,6 +414,7 @@ M: long-long-type box-return ( type -- )
"char" define-primitive-type
<c-type>
fixnum >>class
[ alien-unsigned-1 ] >>getter
[ set-alien-unsigned-1 ] >>setter
1 >>size
@ -414,6 +433,7 @@ M: long-long-type box-return ( type -- )
"bool" define-primitive-type
<c-type>
float >>class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
@ -425,6 +445,7 @@ M: long-long-type box-return ( type -- )
"float" define-primitive-type
<c-type>
float >>class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size

3
basis/alien/strings/strings.factor
View File

@ -40,6 +40,9 @@ PREDICATE: string-type < pair
M: string-type c-type ;
M: string-type c-type-class
drop object ;
M: string-type heap-size
drop "void*" heap-size ;

2
basis/alien/structs/structs.factor
View File

@ -9,6 +9,8 @@ TUPLE: struct-type size align fields ;
M: struct-type heap-size size>> ;
M: struct-type c-type-class drop object ;
M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;

6
basis/compiler/cfg/builder/builder.factor
View File

@ -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 ;
@ -262,7 +260,7 @@ M: #terminate emit-node drop stop-iterating ;
: emit-alien-node ( node quot -- next )
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
begin-basic-block iterate-next ; inline
##branch begin-basic-block iterate-next ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;

2
basis/compiler/cfg/def-use/def-use.factor
View File

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

9
basis/compiler/cfg/instructions/instructions.factor
View File

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

29
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

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

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

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

6
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

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

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

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

4
basis/compiler/cfg/value-numbering/propagate/propagate.factor
View File

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

10
basis/compiler/codegen/codegen.factor
View File

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

22
basis/compiler/tests/codegen.factor
View File

@ -254,3 +254,25 @@ 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
! LOL
: blah ( a -- b )
{ float } declare dup 0 =
[ drop 1 ] [
dup 0 >=
[ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
[ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
if
] if ;
[ 4.0 ] [ 2.0 blah ] unit-test
[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test

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

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

32
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -37,31 +37,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
\ bitnot { integer } "input-classes" set-word-prop
{
fcosh
flog
fsinh
fexp
fasin
facosh
fasinh
ftanh
fatanh
facos
fpow
fatan
fatan2
fcos
ftan
fsin
fsqrt
} [
dup stack-effect
[ in>> length real <repetition> "input-classes" set-word-prop ]
[ out>> length float <repetition> "default-output-classes" set-word-prop ]
2bi
] each
: ?change-interval ( info quot -- quot' )
over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
@ -222,8 +197,15 @@ generic-comparison-ops [
{
{ >fixnum fixnum }
{ bignum>fixnum fixnum }
{ >bignum bignum }
{ fixnum>bignum bignum }
{ float>bignum bignum }
{ >float float }
{ fixnum>float float }
{ bignum>float float }
} [
'[
_

6
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -8,7 +8,7 @@ math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
float-arrays system sorting ;
float-arrays system sorting math.libm ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@ -594,6 +594,10 @@ MIXIN: empty-mixin
[ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
[ V{ float } ] [ [ fsqrt ] final-classes ] unit-test
[ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test

15
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs words
namespaces classes.algebra combinators classes classes.tuple
classes.tuple.private continuations arrays
classes.tuple.private continuations arrays alien.c-types
math math.private slots generic definitions
stack-checker.state
compiler.tree
@ -137,11 +137,12 @@ M: #call propagate-after
dup word>> "input-classes" word-prop dup
[ propagate-input-classes ] [ 2drop ] if ;
M: #alien-invoke propagate-before
out-d>> [ object-info swap set-value-info ] each ;
: propagate-alien-invoke ( node -- )
[ out-d>> ] [ params>> return>> ] bi
[ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
M: #alien-indirect propagate-before
out-d>> [ object-info swap set-value-info ] each ;
M: #alien-invoke propagate-before propagate-alien-invoke ;
M: #return annotate-node
dup in-d>> (annotate-node) ;
M: #alien-indirect propagate-before propagate-alien-invoke ;
M: #return annotate-node dup in-d>> (annotate-node) ;

7
basis/cpu/architecture/architecture.factor
View File

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

16
basis/cpu/ppc/bootstrap.factor
View File

@ -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
@ -406,9 +418,7 @@ big-endian on
[
3 ds-reg 0 LWZ
3 3 1 SRAWI
4 4 LI
4 3 4 SUBF
rs-reg 3 4 LWZX
rs-reg 3 3 LWZX
3 ds-reg 0 STW
] f f f \ get-local define-sub-primitive

102
basis/cpu/ppc/ppc.factor
View File

@ -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
scratch-reg src1 tag-bits get SRAWI
scratch-reg scratch-reg src2 MULLWO.
scratch-reg ds-reg 0 STW
"no-overflow" get BNO
src2 src2 tag-bits get SRAWI
scratch-reg 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
scratch-reg src1 tag-bits get SRAWI
scratch-reg scratch-reg src2 MULLWO.
"overflow" get BO
scratch-reg ds-reg 0 STW
BLR
"overflow" resolve-label
src2 src2 tag-bits get SRAWI
scratch-reg 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 ;

10
basis/cpu/x86/32/32.factor Normal file → Executable file
View File

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

13
basis/cpu/x86/64/64.factor
View File

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

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

@ -379,12 +379,21 @@ 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
arg1 bootstrap-cell MOV ! load base
arg1 arg0 SUB ! turn it into a stack offset
arg0 rs-reg arg1 [+] MOV ! load local value
arg0 rs-reg arg0 [+] MOV ! load local value
ds-reg [] arg0 MOV ! push to stack
] f f f \ get-local define-sub-primitive

58
basis/cpu/x86/x86.factor
View File

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

14
basis/editors/emacs/emacs-docs.factor
View File

@ -1,13 +1,11 @@
USING: help help.syntax help.markup ;
IN: editors.emacs
ARTICLE: { "emacs" "emacs" } "Integration with Emacs"
"Put this in your .emacs file:"
ARTICLE: "editors.emacs" "Integration with Emacs"
"Put this in your " { $snippet ".emacs" } " file:"
{ $code "(server-start)" }
"If you would like a new window to open when you ask Factor to edit an object, put this in your .emacs file:"
"If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:"
{ $code "(setq server-window 'switch-to-buffer-other-frame)" }
{ $see-also "editor" } ;
ABOUT: "editors.emacs"

7
basis/fry/fry-docs.factor
View File

@ -75,12 +75,6 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
} ;
ARTICLE: "fry.limitations" "Fried quotation limitations"
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead."
$nl
"An error thrown if a fried quotation contains calls to " { $link >r } " and " { $link r> } ":"
{ $subsection >r/r>-in-fry-error } ;
ARTICLE: "fry" "Fried quotations"
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
$nl
@ -92,7 +86,6 @@ $nl
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
{ $subsection "fry.examples" }
{ $subsection "fry.philosophy" }
{ $subsection "fry.limitations" }
"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
$nl
"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"

27
basis/fry/fry.factor
View File

@ -28,11 +28,6 @@ M: >r/r>-in-fry-error summary
dup { >r r> load-locals get-local drop-locals } intersect
empty? [ >r/r>-in-fry-error ] unless ;
: shallow-fry ( quot -- quot' )
check-fry
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
{ _ } split [ length 1- [ncurry] ] [ spread>quot ] bi prefix ;
PREDICATE: fry-specifier < word { _ @ } memq? ;
GENERIC: count-inputs ( quot -- n )
@ -41,15 +36,21 @@ M: callable count-inputs [ count-inputs ] sigma ;
M: fry-specifier count-inputs drop 1 ;
M: object count-inputs drop 0 ;
GENERIC: deep-fry ( obj -- )
: shallow-fry ( quot -- quot' curry# )
check-fry
[ [ deep-fry ] each ] [ ] make
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
{ _ } split [ spread>quot ] [ length 1- ] bi ;
PRIVATE>
: fry ( quot -- quot' )
[
[
dup callable? [
[ count-inputs \ _ <repetition> % ] [ fry % ] bi
] [ , ] if
] each
] [ ] make shallow-fry ;
: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ;
M: callable deep-fry
[ count-inputs \ _ <repetition> % ] [ fry % ] bi ;
M: object deep-fry , ;
: '[ \ ] parse-until fry over push-all ; parsing

160
basis/generalizations/generalizations-docs.factor
View File

@ -17,6 +17,15 @@ HELP: narray
{ $description "A generalization of " { $link 1array } ", "
{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "
"that constructs an array from the top " { $snippet "n" } " elements of the stack."
}
{ $examples
"Some core words expressed in terms of " { $link narray } ":"
{ $table
{ { $link 1array } { $snippet "1 narray" } }
{ { $link 2array } { $snippet "2 narray" } }
{ { $link 3array } { $snippet "3 narray" } }
{ { $link 4array } { $snippet "4 narray" } }
}
} ;
{ nsequence narray } related-words
@ -26,6 +35,15 @@ HELP: firstn
{ $description "A generalization of " { $link first } ", "
{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "
"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."
}
{ $examples
"Some core words expressed in terms of " { $link firstn } ":"
{ $table
{ { $link first } { $snippet "1 firstn" } }
{ { $link first2 } { $snippet "2 firstn" } }
{ { $link first3 } { $snippet "3 firstn" } }
{ { $link first4 } { $snippet "4 firstn" } }
}
} ;
HELP: npick
@ -37,8 +55,13 @@ HELP: npick
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
}
{ $see-also dup over pick } ;
"Some core words expressed in terms of " { $link npick } ":"
{ $table
{ { $link dup } { $snippet "1 npick" } }
{ { $link over } { $snippet "2 npick" } }
{ { $link pick } { $snippet "3 npick" } }
}
} ;
HELP: ndup
{ $values { "n" integer } }
@ -49,8 +72,13 @@ HELP: ndup
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
}
{ $see-also dup 2dup 3dup } ;
"Some core words expressed in terms of " { $link ndup } ":"
{ $table
{ { $link dup } { $snippet "1 ndup" } }
{ { $link 2dup } { $snippet "2 ndup" } }
{ { $link 3dup } { $snippet "3 ndup" } }
}
} ;
HELP: nnip
{ $values { "n" integer } }
@ -60,8 +88,12 @@ HELP: nnip
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" }
}
{ $see-also nip 2nip } ;
"Some core words expressed in terms of " { $link nnip } ":"
{ $table
{ { $link nip } { $snippet "1 nnip" } }
{ { $link 2nip } { $snippet "2 nnip" } }
}
} ;
HELP: ndrop
{ $values { "n" integer } }
@ -71,8 +103,13 @@ HELP: ndrop
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" }
}
{ $see-also drop 2drop 3drop } ;
"Some core words expressed in terms of " { $link ndrop } ":"
{ $table
{ { $link drop } { $snippet "1 ndrop" } }
{ { $link 2drop } { $snippet "2 ndrop" } }
{ { $link 3drop } { $snippet "3 ndrop" } }
}
} ;
HELP: nrot
{ $values { "n" integer } }
@ -81,8 +118,12 @@ HELP: nrot
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
}
{ $see-also rot -nrot } ;
"Some core words expressed in terms of " { $link nrot } ":"
{ $table
{ { $link swap } { $snippet "1 nrot" } }
{ { $link rot } { $snippet "2 nrot" } }
}
} ;
HELP: -nrot
{ $values { "n" integer } }
@ -91,8 +132,12 @@ HELP: -nrot
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
}
{ $see-also rot nrot } ;
"Some core words expressed in terms of " { $link -nrot } ":"
{ $table
{ { $link swap } { $snippet "1 -nrot" } }
{ { $link -rot } { $snippet "2 -nrot" } }
}
} ;
HELP: nrev
{ $values { "n" integer } }
@ -100,11 +145,11 @@ HELP: nrev
}
{ $examples
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" }
}
{ $see-also rot nrot } ;
"The " { $link spin } " word is equivalent to " { $snippet "3 nrev" } "."
} ;
HELP: ndip
{ $values { "quot" quotation } { "n" number } }
{ $values { "quot" quotation } { "n" integer } }
{ $description "A generalization of " { $link dip } " that can work "
"for any stack depth. The quotation will be called with a stack that "
"has 'n' items removed first. The 'n' items are then put back on the "
@ -113,30 +158,93 @@ HELP: ndip
{ $examples
{ $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
}
{ $see-also dip 2dip } ;
"Some core words expressed in terms of " { $link ndip } ":"
{ $table
{ { $link dip } { $snippet "1 ndip" } }
{ { $link 2dip } { $snippet "2 ndip" } }
{ { $link 3dip } { $snippet "3 ndip" } }
}
} ;
HELP: nslip
{ $values { "n" number } }
{ $values { "n" integer } }
{ $description "A generalization of " { $link slip } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"removed from the stack, the quotation called, and the items restored."
}
{ $examples
{ $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
}
{ $see-also slip nkeep } ;
"Some core words expressed in terms of " { $link nslip } ":"
{ $table
{ { $link slip } { $snippet "1 nslip" } }
{ { $link 2slip } { $snippet "2 nslip" } }
{ { $link 3slip } { $snippet "3 nslip" } }
}
} ;
HELP: nkeep
{ $values { "quot" quotation } { "n" number } }
{ $values { "quot" quotation } { "n" integer } }
{ $description "A generalization of " { $link keep } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"saved, the quotation called, and the items restored."
}
{ $examples
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
}
{ $see-also keep nslip } ;
"Some core words expressed in terms of " { $link nkeep } ":"
{ $table
{ { $link keep } { $snippet "1 nkeep" } }
{ { $link 2keep } { $snippet "2 nkeep" } }
{ { $link 3keep } { $snippet "3 nkeep" } }
}
} ;
HELP: ncurry
{ $values { "quot" quotation } { "n" integer } }
{ $description "A generalization of " { $link curry } " that can work for any stack depth."
}
{ $examples
"Some core words expressed in terms of " { $link ncurry } ":"
{ $table
{ { $link curry } { $snippet "1 ncurry" } }
{ { $link 2curry } { $snippet "2 ncurry" } }
{ { $link 3curry } { $snippet "3 ncurry" } }
}
} ;
HELP: nwith
{ $values { "quot" quotation } { "n" integer } }
{ $description "A generalization of " { $link with } " that can work for any stack depth."
}
{ $examples
"Some core words expressed in terms of " { $link nwith } ":"
{ $table
{ { $link with } { $snippet "1 nwith" } }
}
} ;
HELP: napply
{ $values { "quot" quotation } { "n" integer } }
{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."
}
{ $examples
"Some core words expressed in terms of " { $link napply } ":"
{ $table
{ { $link bi@ } { $snippet "1 napply" } }
{ { $link tri@ } { $snippet "2 napply" } }
}
} ;
HELP: mnswap
{ $values { "m" integer } { "n" integer } }
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
{ $examples
"Some core words expressed in terms of " { $link mnswap } ":"
{ $table
{ { $link swap } { $snippet "1 1 mnswap" } }
{ { $link rot } { $snippet "2 1 mnswap" } }
{ { $link -rot } { $snippet "1 2 mnswap" } }
}
} ;
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
@ -155,12 +263,14 @@ $nl
{ $subsection nnip }
{ $subsection ndrop }
{ $subsection nrev }
{ $subsection mnswap }
"Generalized combinators:"
{ $subsection ndip }
{ $subsection nslip }
{ $subsection nkeep }
{ $subsection napply }
"Generalized quotation construction:"
{ $subsection ncurry }
{ $subsection nwith }
{ $subsection napply } ;
{ $subsection nwith } ;
ABOUT: "generalizations"

4
basis/generalizations/generalizations-tests.factor
View File

@ -38,3 +38,7 @@ IN: generalizations.tests
[ "a" ] [ { "a" } 1 firstn ] unit-test
[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test
[ 4 5 1 2 3 ] [ 1 2 3 4 5 2 3 mnswap ] unit-test
[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test

11
basis/generalizations/generalizations.factor
View File

@ -13,14 +13,14 @@ IN: generalizations
>>
MACRO: nsequence ( n seq -- quot )
MACRO: nsequence ( n seq -- )
[
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
MACRO: narray ( n -- quot )
MACRO: narray ( n -- )
'[ _ { } nsequence ] ;
MACRO: firstn ( n -- )
@ -30,7 +30,7 @@ MACRO: firstn ( n -- )
bi prefix '[ _ cleave ]
] if ;
MACRO: npick ( n -- quot )
MACRO: npick ( n -- )
1- [ dup ] [ '[ _ dip swap ] ] repeat ;
MACRO: ndup ( n -- )
@ -51,7 +51,7 @@ MACRO: nnip ( n -- )
MACRO: ntuck ( n -- )
2 + '[ dup _ -nrot ] ;
MACRO: nrev ( n -- quot )
MACRO: nrev ( n -- )
1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
MACRO: ndip ( quot n -- )
@ -73,3 +73,6 @@ MACRO: napply ( n -- )
2 [a,b]
[ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
map concat >quotation [ call ] append ;
MACRO: mnswap ( m n -- )
1+ '[ _ -nrot ] <repetition> spread>quot ;

10
basis/help/cookbook/cookbook.factor
View File

@ -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" } ;

7
basis/help/markup/markup.factor
View File

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

31
basis/locals/backend/backend-tests.factor
View File

@ -1,39 +1,14 @@
IN: locals.backend.tests
USING: tools.test locals.backend kernel arrays ;
[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
: get-local-test-1 ( -- x ) 3 >r 1 get-local r> drop ;
: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
\ get-local-test-1 must-infer
[ 3 ] [ get-local-test-1 ] unit-test
: get-local-test-2 ( -- x ) 3 4 >r >r 2 get-local 2 drop-locals ;
: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
\ get-local-test-2 must-infer
[ 4 ] [ get-local-test-2 ] unit-test
: get-local-test-3 ( -- a b ) 3 4 >r >r 2 get-local r> r> 2array ;
\ get-local-test-3 must-infer
[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
: get-local-test-4 ( -- a b )
3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
\ get-local-test-4 must-infer
[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
: load-locals-test-1 ( -- a b ) 1 2 2 load-locals r> r> ;
\ load-locals-test-1 must-infer
[ 1 2 ] [ load-locals-test-1 ] unit-test
[ 3 ] [ get-local-test-2 ] unit-test

5
basis/locals/backend/backend.factor
View File

@ -1,11 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.private kernel slots.private sequences effects words ;
USING: slots.private ;
IN: locals.backend
: load-locals ( n -- )
dup 0 eq? [ drop ] [ swap >r 1 fixnum-fast load-locals ] if ;
: local-value 2 slot ; inline
: set-local-value 2 set-slot ; inline

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

@ -1,5 +1,5 @@
USING: help.syntax help.markup kernel macros prettyprint
memoize combinators arrays ;
memoize combinators arrays generalizations ;
IN: locals
HELP: [|
@ -131,10 +131,40 @@ $nl
$nl
"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
ARTICLE: "locals-fry" "Locals and fry"
"Locals integrate with " { $link "fry" } " so that mixing locals with fried quotations gives intuitive results."
$nl
"Recall that the following two code snippets are equivalent:"
{ $code "'[ sq _ + ]" }
{ $code "[ [ sq ] dip + ] curry" }
"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as ``inserted'' in the ``hole'' in the quotation's second element."
$nl
"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
{ $code "3 [ - ] curry" }
{ $code "[ 3 - ]" }
"With lambdas, " { $link curry } " behaves differently. Rather than prepending an element, it fills in named parameters from right to left. The following two snippets are equivalent:"
{ $code "3 [| a b | a b - ] curry" }
{ $code "[| a | a 3 - ]" }
"Because of this, the behavior of fry changes when applied to a lambda, to ensure that conceptually, fry behaves as with quotations. So the following snippets are no longer equivalent:"
{ $code "'[ [| a | _ a - ] ]" }
{ $code "'[ [| a | a - ] curry ] call" }
"Instead, the first line above expands into something like the following:"
{ $code "[ [ swap [| a | a - ] ] curry call ]" }
"This ensures that the fried value appears ``underneath'' the local variable " { $snippet "a" } " when the quotation calls."
$nl
"The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ;
ARTICLE: "locals-limitations" "Limitations of locals"
"The first limitation is also shared by " { $vocab-link "fry" } ": the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator. An error is thrown at parse time if an attempt is made to use " { $link >r } " and " { $link r> } " inside a lambda body:"
{ $subsection >r/r>-in-lambda-error }
"Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:"
"There are two main limitations of the current locals implementation, and both concern macros."
{ $heading "Macro expansions with free variables" }
"The expansion of a macro cannot reference local variables bound in the outer scope. For example, the following macro is invalid:"
{ $code "MACRO:: twice ( quot -- ) [ quot call quot call ] ;" }
"The following is fine, though:"
{ $code "MACRO:: twice ( quot -- ) quot quot '[ @ @ ] ;" }
{ $heading "Static stack effect inference and macros" }
"Recall that a macro will only expand at compile-time, and the word containing it will only get a static stack effect, if all inputs to the macro are literal. When locals are used, there is an additional restriction; the literals must immediately precede the macro call, lexically."
$nl
"For example, all of the following three examples are equivalent semantically, but only the first will have a static stack effect and compile with the optimizing compiler:"
{ $code
":: good-cond-usage ( a -- ... )"
" {"
@ -143,7 +173,7 @@ ARTICLE: "locals-limitations" "Limitations of locals"
" { [ a 0 = ] [ ... ] }"
" } cond ;"
}
"But not the following:"
"The following two will not, and will run slower as a result:"
{ $code
": my-cond ( alist -- ) cond ; inline"
""
@ -154,6 +184,14 @@ ARTICLE: "locals-limitations" "Limitations of locals"
" { [ a 0 = ] [ ... ] }"
" } my-cond ;"
}
{ $code
":: bad-cond-usage ( a -- ... )"
" {"
" { [ a 0 < ] [ ... ] }"
" { [ a 0 > ] [ ... ] }"
" { [ a 0 = ] [ ... ] }"
" } swap swap cond ;"
}
"The reason is that locals are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to local transformation, however "{ $vocab-link "macros.expander" } " does not deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ;
ARTICLE: "locals" "Local variables and lexical closures"
@ -174,6 +212,7 @@ $nl
"Additional topics:"
{ $subsection "locals-literals" }
{ $subsection "locals-mutable" }
{ $subsection "locals-fry" }
{ $subsection "locals-limitations" }
"Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ;

61
basis/locals/locals-tests.factor
View File

@ -398,7 +398,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
[ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
[
"USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
@ -431,14 +431,53 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]
! >10? [ a 10 > ] |
! { [ is-integer? ] [ is-even? ] [ >10? ] } &&
! ] ;
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail
! [ f ] [ 1.5 wlet-&&-test ] unit-test
! [ f ] [ 3 wlet-&&-test ] unit-test
! [ f ] [ 8 wlet-&&-test ] unit-test
! [ t ] [ 12 wlet-&&-test ] unit-test
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
:: wlet-&&-test ( a -- ? )
[wlet | is-integer? [ a integer? ]
is-even? [ a even? ]
>10? [ a 10 > ] |
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
] ;
\ wlet-&&-test must-infer
[ f ] [ 1.5 wlet-&&-test ] unit-test
[ f ] [ 3 wlet-&&-test ] unit-test
[ f ] [ 8 wlet-&&-test ] unit-test
[ t ] [ 12 wlet-&&-test ] unit-test
: fry-locals-test-1 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
\ fry-locals-test-1 must-infer
[ 10 ] [ fry-locals-test-1 ] unit-test
:: fry-locals-test-2 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
\ fry-locals-test-2 must-infer
[ 10 ] [ fry-locals-test-2 ] unit-test
[ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
[ -1 ] [ 3 4 [| | [| a | a - ] call ] call ] unit-test
[ -1 ] [ 3 4 [| | [| a | a - ] curry call ] call ] unit-test
[ -1 ] [ 3 4 [| a | a - ] curry call ] unit-test
[ 1 ] [ 3 4 [| | '[ [| a | _ a - ] call ] call ] call ] unit-test
[ -1 ] [ 3 4 [| | '[ [| a | a _ - ] call ] call ] call ] unit-test
[ { 1 2 3 4 } ] [
1 3 2 4
[| | '[ [| a b | a _ b _ 4array ] call ] call ] call
] unit-test
[ 10 ] [
[| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
] unit-test

124
basis/locals/locals.factor
View File

@ -6,18 +6,36 @@ quotations debugger macros arrays macros splitting combinators
prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
locals.backend memoize macros.expander lexer classes summary ;
locals.backend memoize macros.expander lexer classes summary fry
fry.private ;
IN: locals
! Inspired by
! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
ERROR: >r/r>-in-lambda-error ;
M: >r/r>-in-lambda-error summary
drop
"Explicit retain stack manipulation is not permitted in lambda bodies" ;
ERROR: binding-form-in-literal-error ;
M: binding-form-in-literal-error summary
drop "[let, [let* and [wlet not permitted inside literals" ;
ERROR: local-writer-in-literal-error ;
M: local-writer-in-literal-error summary
drop "Local writer words not permitted inside literals" ;
ERROR: local-word-in-literal-error ;
M: local-word-in-literal-error summary
drop "Local words not permitted inside literals" ;
ERROR: bad-lambda-rewrite output ;
M: bad-lambda-rewrite summary
drop "You have found a bug in locals. Please report." ;
<PRIVATE
TUPLE: lambda vars body ;
@ -85,60 +103,53 @@ C: <quote> quote
[ dup quote? [ local>> ] when eq? ] with find drop ;
: read-local-quot ( obj args -- quot )
local-index 1+ [ get-local ] curry ;
local-index neg [ get-local ] curry ;
: localize-writer ( obj args -- quot )
>r "local-reader" word-prop r>
GENERIC# localize 1 ( obj args -- quot )
M: local localize read-local-quot ;
M: quote localize [ local>> ] dip read-local-quot ;
M: local-word localize read-local-quot [ call ] append ;
M: local-reader localize read-local-quot [ local-value ] append ;
M: local-writer localize
[ "local-reader" word-prop ] dip
read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot )
{
{ [ over local? ] [ read-local-quot ] }
{ [ over quote? ] [ >r local>> r> read-local-quot ] }
{ [ over local-word? ] [ read-local-quot [ call ] append ] }
{ [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
{ [ over local-writer? ] [ localize-writer ] }
{ [ over \ lambda eq? ] [ 2drop [ ] ] }
{ [ t ] [ drop 1quotation ] }
} cond ;
M: object localize drop 1quotation ;
UNION: special local quote local-word local-reader local-writer ;
: load-locals-quot ( args -- quot )
[
[ ]
] [
[ [ ] ] [
dup [ local-reader? ] contains? [
<reversed> [
local-reader? [ 1array >r ] [ >r ] ?
] map concat
] [
length [ load-locals ] curry >quotation
] if
dup [ local-reader? [ 1array ] [ ] ? ] map spread>quot
] [ [ ] ] if swap length [ load-locals ] curry append
] if-empty ;
: drop-locals-quot ( args -- quot )
[ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
: point-free-body ( quot args -- newquot )
>r but-last-slice r> [ localize ] curry map concat ;
[ but-last-slice ] dip '[ _ localize ] map concat ;
: point-free-end ( quot args -- newquot )
over peek special?
[ dup drop-locals-quot >r >r peek r> localize r> append ]
[ dup drop-locals-quot nip swap peek suffix ]
[ dup drop-locals-quot [ [ peek ] dip localize ] dip append ]
[ drop-locals-quot swap peek suffix ]
if ;
: (point-free) ( quot args -- newquot )
[ nip load-locals-quot ]
[ point-free-body ]
[ point-free-end ]
2tri 3append >quotation ;
[ reverse point-free-body ]
[ reverse point-free-end ]
2tri [ ] 3append-as ;
: point-free ( quot args -- newquot )
over empty?
[ nip length \ drop <repetition> >quotation ]
[ (point-free) ] if ;
over empty? [ nip length '[ _ ndrop ] ] [ (point-free) ] if ;
UNION: lexical local local-reader local-writer local-word ;
@ -227,9 +238,6 @@ GENERIC: rewrite-element ( obj -- )
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: quotation rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: vector rewrite-element rewrite-sequence ;
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
@ -237,12 +245,22 @@ M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element
[ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
M: quotation rewrite-element local-rewrite* ;
M: lambda rewrite-element local-rewrite* ;
M: binding-form rewrite-element binding-form-in-literal-error ;
M: local rewrite-element , ;
M: local-reader rewrite-element , ;
M: local-writer rewrite-element
local-writer-in-literal-error ;
M: local-word rewrite-element
local-word-in-literal-error ;
M: word rewrite-element literalize , ;
M: wrapper rewrite-element
@ -278,8 +296,9 @@ M: object local-rewrite* , ;
: make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ;
: make-local-word ( name -- word )
<local-word> dup dup name>> set ;
: make-local-word ( name def -- word )
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
: push-locals ( assoc -- )
use get push ;
@ -328,7 +347,7 @@ SYMBOL: in-lambda?
: (parse-wbindings) ( -- )
parse-binding [
first2 >r make-local-word r> 2array ,
first2 [ make-local-word ] keep 2array ,
(parse-wbindings)
] when* ;
@ -340,7 +359,7 @@ SYMBOL: in-lambda?
: let-rewrite ( body bindings -- )
<reversed> [
>r 1array r> spin <lambda> [ call ] curry compose
[ 1array ] dip spin <lambda> '[ @ @ ]
] assoc-each local-rewrite* \ call , ;
M: let local-rewrite*
@ -351,7 +370,7 @@ M: let* local-rewrite*
M: wlet local-rewrite*
[ body>> ] [ bindings>> ] bi
[ [ ] curry ] assoc-map
[ '[ _ ] ] assoc-map
let-rewrite ;
: parse-locals ( -- vars assoc )
@ -359,11 +378,6 @@ M: wlet local-rewrite*
word [ over "declared-effect" set-word-prop ] when*
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
ERROR: bad-lambda-rewrite output ;
M: bad-lambda-rewrite summary
drop "You have found a bug in locals. Please report." ;
: parse-locals-definition ( word -- word quot )
"(" expect parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
@ -431,7 +445,7 @@ M: lambda pprint*
\ | pprint-word
t <inset
<block
[ <block >r pprint-var r> pprint* block> ] assoc-each
[ <block [ pprint-var ] dip pprint* block> ] assoc-each
block>
\ | pprint-word
<block pprint-elements block>
@ -497,3 +511,15 @@ M: lambda-method synopsis*
method-stack-effect effect>string comment. ;
PRIVATE>
! Locals and fry
M: binding-form count-inputs body>> count-inputs ;
M: lambda count-inputs body>> count-inputs ;
M: lambda deep-fry
clone [ shallow-fry swap ] change-body
[ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
M: binding-form deep-fry
clone [ fry '[ @ call ] ] change-body , ;

19
basis/math/bitwise/bitwise-docs.factor
View File

@ -204,8 +204,25 @@ HELP: on-bits
"64 on-bits .h"
"ffffffffffffffff"
}
} ;
HELP: toggle-bit
{ $values
{ "m" integer }
{ "n" integer }
{ "m'" integer }
}
;
{ $description "Toggles the nth bit of an integer." }
{ $examples
{ $example "USING: math.bitwise kernel prettyprint ;"
"0 3 toggle-bit .b"
"1000"
}
{ $example "USING: math.bitwise kernel prettyprint ;"
"BIN: 1000 3 toggle-bit .b"
"0"
}
} ;
HELP: set-bit
{ $values

3
basis/math/bitwise/bitwise-tests.factor
View File

@ -29,3 +29,6 @@ IN: math.bitwise.tests
\ foo must-infer
[ 1 ] [ { 1 } flags ] unit-test
[ 8 ] [ 0 3 toggle-bit ] unit-test
[ 0 ] [ 8 3 toggle-bit ] unit-test

1
basis/math/bitwise/bitwise.factor
View File

@ -17,6 +17,7 @@ IN: math.bitwise
: bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 2^ mask ; inline
: on-bits ( n -- m ) 2^ 1- ; inline
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline
: shift-mod ( n s w -- n )
[ shift ] dip 2^ wrap ; inline

81
basis/math/functions/functions.factor
View File

@ -100,7 +100,7 @@ PRIVATE>
{ [ dup integer? ] [ integer^ ] }
{ [ 2dup real^? ] [ fpow ] }
[ ^complex ]
} cond ;
} cond ; inline
: (^mod) ( n x y -- z )
1 swap [
@ -174,47 +174,61 @@ M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ;
M: complex log >polar swap flog swap rect> ;
: cos ( x -- y )
dup complex? [
>float-rect 2dup
fcosh swap fcos * -rot
fsinh swap fsin neg * rect>
] [ fcos ] if ; foldable
GENERIC: cos ( x -- y ) foldable
M: complex cos
>float-rect 2dup
fcosh swap fcos * -rot
fsinh swap fsin neg * rect> ;
M: real cos fcos ;
: sec ( x -- y ) cos recip ; inline
: cosh ( x -- y )
dup complex? [
>float-rect 2dup
fcos swap fcosh * -rot
fsin swap fsinh * rect>
] [ fcosh ] if ; foldable
GENERIC: cosh ( x -- y ) foldable
M: complex cosh
>float-rect 2dup
fcos swap fcosh * -rot
fsin swap fsinh * rect> ;
M: real cosh fcosh ;
: sech ( x -- y ) cosh recip ; inline
: sin ( x -- y )
dup complex? [
>float-rect 2dup
fcosh swap fsin * -rot
fsinh swap fcos * rect>
] [ fsin ] if ; foldable
GENERIC: sin ( x -- y ) foldable
M: complex sin
>float-rect 2dup
fcosh swap fsin * -rot
fsinh swap fcos * rect> ;
M: real sin fsin ;
: cosec ( x -- y ) sin recip ; inline
: sinh ( x -- y )
dup complex? [
>float-rect 2dup
fcos swap fsinh * -rot
fsin swap fcosh * rect>
] [ fsinh ] if ; foldable
GENERIC: sinh ( x -- y ) foldable
M: complex sinh
>float-rect 2dup
fcos swap fsinh * -rot
fsin swap fcosh * rect> ;
M: real sinh fsinh ;
: cosech ( x -- y ) sinh recip ; inline
: tan ( x -- y )
dup complex? [ dup sin swap cos / ] [ ftan ] if ; inline
GENERIC: tan ( x -- y ) foldable
: tanh ( x -- y )
dup complex? [ dup sinh swap cosh / ] [ ftanh ] if ; inline
M: complex tan [ sin ] [ cos ] bi / ;
M: real tan ftan ;
GENERIC: tanh ( x -- y ) foldable
M: complex tanh [ sinh ] [ cosh ] bi / ;
M: real tanh ftanh ;
: cot ( x -- y ) tan recip ; inline
@ -231,7 +245,7 @@ M: complex log >polar swap flog swap rect> ;
: acosech ( x -- y ) recip asinh ; inline
: atanh ( x -- y )
dup 1+ swap 1- neg / log 2 / ; inline
[ 1+ ] [ 1- neg ] bi / log 2 / ; inline
: acoth ( x -- y ) recip atanh ; inline
@ -246,8 +260,11 @@ M: complex log >polar swap flog swap rect> ;
dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
inline
: atan ( x -- y )
dup complex? [ i* atanh i* ] [ fatan ] if ; inline
GENERIC: atan ( x -- y ) foldable
M: complex atan i* atanh i* ;
M: real atan fatan ;
: asec ( x -- y ) recip acos ; inline

34
basis/math/libm/libm.factor
View File

@ -5,69 +5,69 @@ IN: math.libm
: facos ( x -- y )
"double" "libm" "acos" { "double" } alien-invoke ;
foldable
inline
: fasin ( x -- y )
"double" "libm" "asin" { "double" } alien-invoke ;
foldable
inline
: fatan ( x -- y )
"double" "libm" "atan" { "double" } alien-invoke ;
foldable
inline
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
foldable
inline
: fcos ( x -- y )
"double" "libm" "cos" { "double" } alien-invoke ;
foldable
inline
: fsin ( x -- y )
"double" "libm" "sin" { "double" } alien-invoke ;
foldable
inline
: ftan ( x -- y )
"double" "libm" "tan" { "double" } alien-invoke ;
foldable
inline
: fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ;
foldable
inline
: fsinh ( x -- y )
"double" "libm" "sinh" { "double" } alien-invoke ;
foldable
inline
: ftanh ( x -- y )
"double" "libm" "tanh" { "double" } alien-invoke ;
foldable
inline
: fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ;
foldable
inline
: flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ;
foldable
inline
: fpow ( x y -- z )
"double" "libm" "pow" { "double" "double" } alien-invoke ;
foldable
inline
: fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ;
foldable
inline
! Windows doesn't have these...
: facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ;
foldable
inline
: fasinh ( x -- y )
"double" "libm" "asinh" { "double" } alien-invoke ;
foldable
inline
: fatanh ( x -- y )
"double" "libm" "atanh" { "double" } alien-invoke ;
foldable
inline

6
basis/math/ranges/ranges.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts math math.order namespaces sequences
sequences.private accessors ;
IN: math.ranges
@ -8,9 +10,7 @@ TUPLE: range
{ step read-only } ;
: <range> ( a b step -- range )
[ over - ] dip
[ / 1+ 0 max >integer ] keep
range boa ; inline
[ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline
M: range length ( seq -- n )
length>> ;

20
basis/opengl/opengl.factor
View File

@ -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>
sprite-size2 0 GL_LUMINANCE_ALPHA
GL_UNSIGNED_BYTE r> glTexImage2D
[
[ GL_TEXTURE_2D 0 GL_RGBA ] dip
sprite-size2 0 GL_LUMINANCE_ALPHA
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@ ;

7
basis/prettyprint/prettyprint.factor
View File

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

5
basis/regexp/backend/backend.factor
View File

@ -5,12 +5,13 @@ IN: regexp.backend
TUPLE: regexp
raw
{ stack vector }
parse-tree
{ options hashtable }
stack
parse-tree
nfa-table
dfa-table
minimized-table
matchers
{ nfa-traversal-flags hashtable }
{ dfa-traversal-flags hashtable }
{ state integer }

25
basis/regexp/classes/classes.factor
View File

@ -1,12 +1,25 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.order symbols regexp.parser
USING: accessors kernel math math.order symbols
words regexp.utils unicode.categories combinators.short-circuit ;
IN: regexp.classes
SINGLETONS: any-char any-char-no-nl
letter-class LETTER-class Letter-class digit-class
alpha-class non-newline-blank-class
ascii-class punctuation-class java-printable-class blank-class
control-character-class hex-digit-class java-blank-class c-identifier-class
unmatchable-class terminator-class word-boundary-class ;
SINGLETONS: beginning-of-input beginning-of-line
end-of-input end-of-line ;
MIXIN: node
TUPLE: character-class-range from to ; INSTANCE: character-class-range node
GENERIC: class-member? ( obj class -- ? )
M: word class-member? ( obj class -- ? ) 2drop f ;
M: t class-member? ( obj class -- ? ) 2drop f ;
M: integer class-member? ( obj class -- ? ) 2drop f ;
@ -18,7 +31,7 @@ M: any-char class-member? ( obj class -- ? )
M: any-char-no-nl class-member? ( obj class -- ? )
drop CHAR: \n = not ;
M: letter-class class-member? ( obj class -- ? )
drop letter? ;
@ -70,3 +83,9 @@ M: terminator-class class-member? ( obj class -- ? )
[ CHAR: \u002028 = ]
[ CHAR: \u002029 = ]
} 1|| ;
M: beginning-of-line class-member? ( obj class -- ? )
2drop f ;
M: end-of-line class-member? ( obj class -- ? )
2drop f ;

85
basis/regexp/nfa/nfa.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays assocs grouping kernel regexp.backend
locals math namespaces regexp.parser sequences fry quotations
math.order math.ranges vectors unicode.categories regexp.utils
regexp.transition-tables words sets ;
regexp.transition-tables words sets regexp.classes unicode.case ;
IN: regexp.nfa
SYMBOL: negation-mode
@ -22,8 +22,13 @@ SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag
SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag
SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag
: add-global-flag ( flag -- )
current-regexp get nfa-table>> flags>> conjoin ;
: options ( -- obj ) current-regexp get options>> ;
: option? ( obj -- ? ) options key? ;
: option-on ( obj -- ) options conjoin ;
: option-off ( obj -- ) options delete-at ;
: next-state ( regexp -- state )
[ state>> ] [ [ 1+ ] change-state drop ] bi ;
@ -106,6 +111,7 @@ M: kleene-star nfa-node ( node -- )
M: concatenation nfa-node ( node -- )
seq>>
reversed-regexp option? [ <reversed> ] when
[ [ nfa-node ] each ]
[ length 1- [ concatenate-nodes ] times ] bi ;
@ -115,16 +121,59 @@ M: alternation nfa-node ( node -- )
[ length 1- [ alternate-nodes ] times ] bi ;
M: constant nfa-node ( node -- )
char>> literal-transition add-simple-entry ;
case-insensitive option? [
dup char>> [ ch>lower ] [ ch>upper ] bi
2dup = [
2drop
char>> literal-transition add-simple-entry
] [
[ literal-transition add-simple-entry ] bi@
alternate-nodes drop
] if
] [
char>> literal-transition add-simple-entry
] if ;
M: epsilon nfa-node ( node -- )
drop eps literal-transition add-simple-entry ;
M: word nfa-node ( node -- )
M: word nfa-node ( node -- ) class-transition add-simple-entry ;
M: any-char nfa-node ( node -- )
[ dotall option? ] dip any-char-no-nl ?
class-transition add-simple-entry ;
! M: beginning-of-text nfa-node ( node -- ) ;
M: beginning-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
M: end-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
: choose-letter-class ( node -- node' )
case-insensitive option? Letter-class rot ? ;
M: letter-class nfa-node ( node -- )
choose-letter-class class-transition add-simple-entry ;
M: LETTER-class nfa-node ( node -- )
choose-letter-class class-transition add-simple-entry ;
M: character-class-range nfa-node ( node -- )
class-transition add-simple-entry ;
case-insensitive option? [
dup [ from>> ] [ to>> ] bi
2dup [ Letter? ] bi@ and [
rot drop
[ [ ch>lower ] bi@ character-class-range boa ]
[ [ ch>upper ] bi@ character-class-range boa ] 2bi
[ class-transition add-simple-entry ] bi@
alternate-nodes
] [
2drop
class-transition add-simple-entry
] if
] [
class-transition add-simple-entry
] if ;
M: capture-group nfa-node ( node -- )
eps literal-transition add-simple-entry
@ -141,26 +190,6 @@ M: non-capture-group nfa-node ( node -- )
M: reluctant-kleene-star nfa-node ( node -- )
term>> <kleene-star> nfa-node ;
M: beginning-of-line nfa-node ( node -- )
drop
eps literal-transition add-simple-entry
beginning-of-line add-global-flag ;
M: end-of-line nfa-node ( node -- )
drop
eps literal-transition add-simple-entry
end-of-line add-global-flag ;
M: beginning-of-input nfa-node ( node -- )
drop
eps literal-transition add-simple-entry
beginning-of-input add-global-flag ;
M: end-of-input nfa-node ( node -- )
drop
eps literal-transition add-simple-entry
end-of-input add-global-flag ;
M: negation nfa-node ( node -- )
negation-mode inc
term>> nfa-node
@ -182,6 +211,10 @@ M: lookbehind nfa-node ( node -- )
lookbehind-off add-traversal-flag
2 [ concatenate-nodes ] times ;
M: option nfa-node ( node -- )
[ option>> ] [ on?>> ] bi [ option-on ] [ option-off ] if
eps literal-transition add-simple-entry ;
: construct-nfa ( regexp -- )
[
reset-regexp

4
basis/regexp/parser/parser-tests.factor
View File

@ -19,8 +19,8 @@ IN: regexp.parser
[ ] [ "(?:a)" test-regexp ] unit-test
[ ] [ "(?i:a)" test-regexp ] unit-test
[ ] [ "(?-i:a)" test-regexp ] unit-test
[ "(?z:a)" test-regexp ] [ bad-option? ] must-fail-with
[ "(?-z:a)" test-regexp ] [ bad-option? ] must-fail-with
[ "(?z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
[ "(?-z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
[ ] [ "(?=a)" test-regexp ] unit-test

118
basis/regexp/parser/parser.factor
View File

@ -4,12 +4,11 @@ USING: accessors arrays assocs combinators io io.streams.string
kernel math math.parser namespaces qualified sets
quotations sequences splitting symbols vectors math.order
unicode.categories strings regexp.backend regexp.utils
unicode.case words locals ;
unicode.case words locals regexp.classes ;
IN: regexp.parser
FROM: math.ranges => [a,b] ;
MIXIN: node
TUPLE: concatenation seq ; INSTANCE: concatenation node
TUPLE: alternation seq ; INSTANCE: alternation node
TUPLE: kleene-star term ; INSTANCE: kleene-star node
@ -40,38 +39,31 @@ INSTANCE: independent-group parentheses-group
TUPLE: comment-group term ; INSTANCE: comment-group node
INSTANCE: comment-group parentheses-group
TUPLE: character-class-range from to ; INSTANCE: character-class-range node
SINGLETON: epsilon INSTANCE: epsilon node
SINGLETON: any-char INSTANCE: any-char node
SINGLETON: any-char-no-nl INSTANCE: any-char-no-nl node
SINGLETON: beginning-of-input INSTANCE: beginning-of-input node
SINGLETON: end-of-input INSTANCE: end-of-input node
SINGLETON: beginning-of-line INSTANCE: beginning-of-line node
SINGLETON: end-of-line INSTANCE: end-of-line node
TUPLE: option-on option ; INSTANCE: option-on node
TUPLE: option-off option ; INSTANCE: option-off node
TUPLE: option option on? ; INSTANCE: option node
SINGLETONS: unix-lines dotall multiline comments case-insensitive
unicode-case reversed-regexp ;
SINGLETONS: letter-class LETTER-class Letter-class digit-class
alpha-class non-newline-blank-class
ascii-class punctuation-class java-printable-class blank-class
control-character-class hex-digit-class java-blank-class c-identifier-class
unmatchable-class terminator-class word-boundary-class ;
SINGLETONS: beginning-of-group end-of-group
beginning-of-character-class end-of-character-class
SINGLETONS: beginning-of-character-class end-of-character-class
left-parenthesis pipe caret dash ;
: get-option ( option -- ? ) current-regexp get options>> at ;
: get-unix-lines ( -- ? ) unix-lines get-option ;
: get-dotall ( -- ? ) dotall get-option ;
: get-multiline ( -- ? ) multiline get-option ;
: get-comments ( -- ? ) comments get-option ;
: get-case-insensitive ( -- ? ) case-insensitive get-option ;
: get-unicode-case ( -- ? ) unicode-case get-option ;
: get-reversed-regexp ( -- ? ) reversed-regexp get-option ;
: push1 ( obj -- ) input-stream get stream>> push ;
: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
: drop1 ( -- ) read1 drop ;
: stack ( -- obj ) current-regexp get stack>> ;
: change-whole-stack ( quot -- )
current-regexp get
[ stack>> swap call ] keep (>>stack) ; inline
: push-stack ( obj -- ) stack push ;
: pop-stack ( -- obj ) stack pop ;
: cut-out ( vector n -- vector' vector ) cut rest ;
ERROR: cut-stack-error ;
: cut-stack ( obj vector -- vector' vector )
tuck last-index [ cut-stack-error ] unless* cut-out swap ;
: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;
@ -80,18 +72,11 @@ left-parenthesis pipe caret dash ;
: <negation> ( obj -- negation ) negation boa ;
: <concatenation> ( seq -- concatenation )
>vector get-reversed-regexp [ reverse ] when
[ epsilon ] [ concatenation boa ] if-empty ;
>vector [ epsilon ] [ concatenation boa ] if-empty ;
: <alternation> ( seq -- alternation ) >vector alternation boa ;
: <capture-group> ( obj -- capture-group ) capture-group boa ;
: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
: <constant> ( obj -- constant )
dup Letter? get-case-insensitive and [
[ ch>lower ] [ ch>upper ] bi
[ constant boa ] bi@ 2array <alternation>
] [
constant boa
] if ;
: <constant> ( obj -- constant ) constant boa ;
: first|concatenation ( seq -- first/concatenation )
dup length 1 = [ first ] [ <concatenation> ] if ;
@ -100,21 +85,14 @@ left-parenthesis pipe caret dash ;
dup length 1 = [ first ] [ <alternation> ] if ;
: <character-class-range> ( from to -- obj )
2dup [ Letter? ] bi@ or get-case-insensitive and [
[ [ ch>lower ] bi@ character-class-range boa ]
[ [ ch>upper ] bi@ character-class-range boa ] 2bi
2array [ [ from>> ] [ to>> ] bi < ] filter
[ unmatchable-class ] [ first|alternation ] if-empty
] [
2dup <
[ character-class-range boa ] [ 2drop unmatchable-class ] if
] if ;
2dup <
[ character-class-range boa ] [ 2drop unmatchable-class ] if ;
ERROR: unmatched-parentheses ;
ERROR: bad-option ch ;
ERROR: unknown-regexp-option option ;
: option ( ch -- singleton )
: ch>option ( ch -- singleton )
{
{ CHAR: i [ case-insensitive ] }
{ CHAR: d [ unix-lines ] }
@ -124,13 +102,21 @@ ERROR: bad-option ch ;
{ CHAR: s [ dotall ] }
{ CHAR: u [ unicode-case ] }
{ CHAR: x [ comments ] }
[ bad-option ]
[ unknown-regexp-option ]
} case ;
: option-on ( option -- ) current-regexp get options>> conjoin ;
: option-off ( option -- ) current-regexp get options>> delete-at ;
: option>ch ( option -- string )
{
{ case-insensitive [ CHAR: i ] }
{ multiline [ CHAR: m ] }
{ reversed-regexp [ CHAR: r ] }
{ dotall [ CHAR: s ] }
[ unknown-regexp-option ]
} case ;
: toggle-option ( ch ? -- )
[ ch>option ] dip option boa push-stack ;
: toggle-option ( ch ? -- ) [ option ] dip [ option-on ] [ option-off ] if ;
: (parse-options) ( string ? -- ) [ toggle-option ] curry each ;
: parse-options ( string -- )
@ -176,7 +162,7 @@ DEFER: (parse-regexp)
[ drop1 (parse-special-group) ]
[ capture-group f nested-parse-regexp ] if ;
: handle-dot ( -- ) get-dotall any-char any-char-no-nl ? push-stack ;
: handle-dot ( -- ) any-char push-stack ;
: handle-pipe ( -- ) pipe push-stack ;
: (handle-star) ( obj -- kleene-star )
peek1 {
@ -234,11 +220,8 @@ ERROR: invalid-range a b ;
[ [ nip at-most-n ] [ at-least-n ] if* ] if
] [ drop 0 max exactly-n ] if ;
: handle-front-anchor ( -- )
get-multiline beginning-of-line beginning-of-input ? push-stack ;
: handle-back-anchor ( -- )
get-multiline end-of-line end-of-input ? push-stack ;
: handle-front-anchor ( -- ) beginning-of-line push-stack ;
: handle-back-anchor ( -- ) end-of-line push-stack ;
ERROR: bad-character-class obj ;
ERROR: expected-posix-class ;
@ -247,8 +230,8 @@ ERROR: expected-posix-class ;
read1 CHAR: { = [ expected-posix-class ] unless
"}" read-until [ bad-character-class ] unless
{
{ "Lower" [ get-case-insensitive Letter-class letter-class ? ] }
{ "Upper" [ get-case-insensitive Letter-class LETTER-class ? ] }
{ "Lower" [ letter-class ] }
{ "Upper" [ LETTER-class ] }
{ "Alpha" [ Letter-class ] }
{ "ASCII" [ ascii-class ] }
{ "Digit" [ digit-class ] }
@ -412,7 +395,8 @@ DEFER: handle-left-bracket
[ first|concatenation ] map first|alternation ;
: handle-right-parenthesis ( -- )
stack dup [ parentheses-group "members" word-prop member? ] find-last -rot cut rest
stack dup [ parentheses-group "members" word-prop member? ] find-last
-rot cut rest
[ [ push ] keep current-regexp get (>>stack) ]
[ finish-regexp-parse push-stack ] bi* ;
@ -429,12 +413,9 @@ DEFER: handle-left-bracket
{ CHAR: [ [ handle-left-bracket t ] }
{ CHAR: \ [ handle-escape t ] }
[
dup CHAR: $ = peek1 f = and [
drop
handle-back-anchor f
] [
push-constant t
] if
dup CHAR: $ = peek1 f = and
[ drop handle-back-anchor f ]
[ push-constant t ] if
]
} case ;
@ -451,7 +432,6 @@ DEFER: handle-left-bracket
parse-regexp-beginning (parse-regexp)
] with-input-stream
] unless-empty
current-regexp get
stack finish-regexp-parse
>>parse-tree drop
current-regexp get [ finish-regexp-parse ] change-stack
dup stack>> >>parse-tree drop
] with-variable ;

39
basis/regexp/regexp-tests.factor
View File

@ -238,7 +238,7 @@ IN: regexp-tests
[ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
[ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/r matches? ] unit-test
[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
@ -307,17 +307,30 @@ IN: regexp-tests
! Bug in parsing word
[ t ] [ "a" R' a' matches? ] unit-test
! Convert to lowercase until E
[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test
! Convert to uppercase until E
[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test
[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test
! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
[ t ] [ "a" R/ ^a/ matches? ] unit-test
[ f ] [ "\na" R/ ^a/ matches? ] unit-test
[ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
[ f ] [ "\ra" R/ ^a/ matches? ] unit-test
! [ t ] [ "a" R/ ^a/ matches? ] unit-test
! [ f ] [ "\na" R/ ^a/ matches? ] unit-test
! [ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
! [ f ] [ "\ra" R/ ^a/ matches? ] unit-test
[ t ] [ "a" R/ a$/ matches? ] unit-test
[ f ] [ "a\n" R/ a$/ matches? ] unit-test
[ f ] [ "a\r" R/ a$/ matches? ] unit-test
[ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
! [ t ] [ "a" R/ a$/ matches? ] unit-test
! [ f ] [ "a\n" R/ a$/ matches? ] unit-test
! [ f ] [ "a\r" R/ a$/ matches? ] unit-test
! [ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
! [ t ] [ "a" R/ a$|b$/ matches? ] unit-test
! [ t ] [ "b" R/ a$|b$/ matches? ] unit-test
! [ t ] [ "ab" R/ a$|b$/ matches? ] unit-test
! [ t ] [ "ba" R/ ba$|b$/ matches? ] unit-test
! [ t ] [ "a" R/ \Aa/ matches? ] unit-test
! [ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
@ -347,14 +360,6 @@ IN: regexp-tests
! [ t ] [ "\r\na" R/ ^a/m matches? ] unit-test
! [ t ] [ "\ra" R/ ^a/m matches? ] unit-test
! Convert to lowercase until E
[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test
! Convert to uppercase until E
[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test
[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test
! [ t ] [ "a" "a$" R/ a$/m matches? ] unit-test
! [ t ] [ "a\n" "a$" R/ a$/m matches? ] unit-test
! [ t ] [ "a\r" "a$" R/ a$/m matches? ] unit-test

21
basis/regexp/regexp.factor
View File

@ -16,6 +16,7 @@ IN: regexp
H{ } clone >>nfa-traversal-flags
H{ } clone >>dfa-traversal-flags
H{ } clone >>options
H{ } clone >>matchers
reset-regexp ;
: construct-regexp ( regexp -- regexp' )
@ -93,26 +94,6 @@ IN: regexp
{ "R| " "|" }
} swap [ subseq? not nip ] curry assoc-find drop ;
ERROR: unknown-regexp-option option ;
: option>ch ( option -- string )
{
{ case-insensitive [ CHAR: i ] }
{ multiline [ CHAR: m ] }
{ reversed-regexp [ CHAR: r ] }
{ dotall [ CHAR: s ] }
[ unknown-regexp-option ]
} case ;
: ch>option ( ch -- option )
{
{ CHAR: i [ case-insensitive ] }
{ CHAR: m [ multiline ] }
{ CHAR: r [ reversed-regexp ] }
{ CHAR: s [ dotall ] }
[ unknown-regexp-option ]
} case ;
: string>options ( string -- options )
[ ch>option dup ] H{ } map>assoc ;

7
basis/regexp/transition-tables/transition-tables.factor
View File

@ -20,18 +20,19 @@ TUPLE: default ;
: <literal-transition> ( from to obj -- transition )
literal-transition make-transition ;
: <class-transition> ( from to obj -- transition )
class-transition make-transition ;
: <default-transition> ( from to -- transition )
t default-transition make-transition ;
TUPLE: transition-table transitions start-state final-states flags ;
TUPLE: transition-table transitions start-state final-states ;
: <transition-table> ( -- transition-table )
transition-table new
H{ } clone >>transitions
H{ } clone >>final-states
H{ } clone >>flags ;
H{ } clone >>final-states ;
: maybe-initialize-key ( key hashtable -- )
2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;

17
basis/regexp/utils/utils.factor
View File

@ -26,23 +26,6 @@ IN: regexp.utils
: ?insert-at ( value key hash/f -- hash )
[ H{ } clone ] unless* [ insert-at ] keep ;
: last-state ( regexp -- range ) stack>> peek first2 [a,b] ;
: push1 ( obj -- ) input-stream get stream>> push ;
: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
: drop1 ( -- ) read1 drop ;
: stack ( -- obj ) current-regexp get stack>> ;
: change-whole-stack ( quot -- )
current-regexp get
[ stack>> swap call ] keep (>>stack) ; inline
: push-stack ( obj -- ) stack push ;
: pop-stack ( -- obj ) stack pop ;
: cut-out ( vector n -- vector' vector ) cut rest ;
ERROR: cut-stack-error ;
: cut-stack ( obj vector -- vector' vector )
tuck last-index [ cut-stack-error ] unless* cut-out swap ;
ERROR: bad-octal number ;
ERROR: bad-hex number ;
: check-octal ( octal -- octal ) dup 255 > [ bad-octal ] when ;

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

@ -134,11 +134,11 @@ M: object infer-call*
: infer-load-locals ( -- )
pop-literal nip
consume-d dup reverse copy-values dup output-r
[ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ;
consume-d dup copy-values dup output-r
[ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
: infer-get-local ( -- )
[let* | n [ pop-literal nip ]
[let* | n [ pop-literal nip 1 swap - ]
in-r [ n consume-r ]
out-d [ in-r first copy-value 1array ]
out-r [ in-r copy-values ] |
@ -186,6 +186,9 @@ M: object infer-call*
: infer-local-writer ( word -- )
(( value -- )) apply-word/effect ;
: infer-local-word ( word -- )
"local-word-def" word-prop infer-quot-here ;
{
>r r> declare call (call) slip 2slip 3slip curry compose
execute (execute) if dispatch <tuple-boa> (throw)
@ -209,6 +212,7 @@ M: object infer-call*
{ [ dup local? ] [ infer-local-reader ] }
{ [ dup local-reader? ] [ infer-local-reader ] }
{ [ dup local-writer? ] [ infer-local-writer ] }
{ [ dup local-word? ] [ infer-local-word ] }
{ [ dup recursive-word? ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ]
} cond ;
@ -277,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

5
basis/stack-checker/transforms/transforms.factor
View File

@ -94,7 +94,10 @@ IN: stack-checker.transforms
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
[ inlined-dependency depends-on ] bi@
] [ next-method-quot ] bi
] [
[ next-method-quot ]
[ '[ _ no-next-method ] ] bi or
] bi
] 1 define-transform
! Constructors

32
basis/tools/annotations/annotations.factor
View File

@ -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,34 +41,38 @@ 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 _ .
"--- Entering: " write _ .
"--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
@
] ;
: 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 ;

6
basis/tools/deploy/shaker/shaker.factor
View File

@ -343,6 +343,9 @@ IN: tools.deploy.shaker
: compress-strings ( -- )
[ string? ] [ ] "strings" compress ;
: compress-wrappers ( -- )
[ wrapper? ] [ ] "wrappers" compress ;
: finish-deploy ( final-image -- )
"Finishing up" show
>r { } set-datastack r>
@ -391,7 +394,8 @@ SYMBOL: deploy-vocab
r> strip-words
compress-byte-arrays
compress-quotations
compress-strings ;
compress-strings
compress-wrappers ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave

7
basis/tools/hexdump/hexdump-docs.factor
View File

@ -1,14 +1,15 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences strings ;
USING: help.markup help.syntax kernel sequences byte-arrays
strings ;
IN: tools.hexdump
HELP: hexdump.
{ $values { "seq" sequence } }
{ $values { "byte-array" byte-array } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
HELP: hexdump
{ $values { "seq" sequence } { "str" string } }
{ $values { "byte-array" byte-array } { "str" string } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
{ $see-also hexdump. } ;

8
basis/tools/hexdump/hexdump-tests.factor
View File

@ -1,10 +1,10 @@
USING: tools.hexdump kernel sequences tools.test ;
USING: tools.hexdump kernel sequences tools.test byte-arrays ;
IN: tools.hexdump.tests
[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
[ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
[ t ] [ B{ } hexdump "Length: 0, 0h\n" = ] unit-test
[ t ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
[ t ] [ 256 [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
[

8
basis/tools/hexdump/hexdump.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io io.streams.string kernel math math.parser
namespaces sequences splitting grouping strings ascii ;
namespaces sequences splitting grouping strings ascii byte-arrays ;
IN: tools.hexdump
<PRIVATE
@ -28,9 +28,11 @@ IN: tools.hexdump
PRIVATE>
: hexdump. ( seq -- )
GENERIC: hexdump. ( byte-array -- )
M: byte-array hexdump.
[ length write-header ]
[ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
: hexdump ( seq -- str )
: hexdump ( byte-array -- str )
[ hexdump. ] with-string-writer ;

4
basis/tools/vocabs/browser/browser-docs.factor
View File

@ -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." } ;

2
basis/ui/clipboards/clipboards.factor
View File

@ -33,7 +33,7 @@ SYMBOL: selection
: gadget-copy ( gadget clipboard -- )
over gadget-selection?
[ >r [ gadget-selection ] keep r> copy-clipboard ]
[ [ [ gadget-selection ] keep ] dip copy-clipboard ]
[ 2drop ]
if ;

4
basis/ui/cocoa/cocoa.factor
View File

@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
cocoa.windows cocoa.classes cocoa.application sequences system
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
ui.cocoa.views core-foundation threads math.geometry.rect ;
ui.cocoa.views core-foundation threads math.geometry.rect fry ;
IN: ui.cocoa
TUPLE: handle view window ;
@ -15,7 +15,7 @@ C: <handle> handle
SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
[ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
[ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
TUPLE: pasteboard handle ;

2
basis/ui/cocoa/tools/tools.factor
View File

@ -25,7 +25,7 @@ CLASS: {
}
{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
[ >r 3drop r> finder-run-files ]
[ [ 3drop ] dip finder-run-files ]
}
{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }

25
basis/ui/cocoa/views/views.factor
View File

@ -8,7 +8,7 @@ core-foundation threads combinators math.geometry.rect ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
over >r mouse-location r> window move-hand fire-motion ;
[ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
@ -85,18 +85,19 @@ IN: ui.cocoa.views
mouse-location rot window send-button-up ;
: send-wheel$ ( view event -- )
over >r
dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
mouse-location
r> window send-wheel ;
[
dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
mouse-location
] [ drop window ] 2bi send-wheel ;
: send-action$ ( view event gesture -- junk )
>r drop window r> send-action f ;
[ drop window ] dip send-action f ;
: add-resize-observer ( observer object -- )
>r "updateFactorGadgetSize:"
"NSViewFrameDidChangeNotification" <NSString>
r> add-observer ;
[
"updateFactorGadgetSize:"
"NSViewFrameDidChangeNotification" <NSString>
] dip add-observer ;
: string-or-nil? ( NSString -- ? )
[ CF>string NSStringPboardType = ] [ t ] if* ;
@ -109,7 +110,7 @@ IN: ui.cocoa.views
] if ;
: NSRect>rect ( NSRect world -- rect )
>r dup NSRect-x over NSRect-y r>
[ dup NSRect-x over NSRect-y ] dip
rect-dim second swap - 2array
over NSRect-w rot NSRect-h 2array
<rect> ;
@ -256,7 +257,7 @@ CLASS: {
{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
[
! We return either self or nil
>r >r over window-focus r> r>
[ over window-focus ] 2dip
valid-service? [ drop ] [ 2drop f ] if
]
}
@ -278,7 +279,7 @@ CLASS: {
{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
[
pasteboard-string dup [
>r drop window-focus r> swap user-input 1
[ drop window-focus ] dip swap user-input 1
] [
3drop 0
] if

4
basis/ui/commands/commands.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces make assocs quotations
splitting ui.gestures unicode.case unicode.categories tr ;
splitting ui.gestures unicode.case unicode.categories tr fry ;
IN: ui.commands
SYMBOL: +nullary+
@ -37,7 +37,7 @@ GENERIC: command-word ( command -- word )
[
commands>>
[ drop ] assoc-filter
[ [ invoke-command ] curry swap set ] assoc-each
[ '[ _ invoke-command ] swap set ] assoc-each
] each
] H{ } make-assoc ;

6
basis/ui/freetype/freetype.factor
View File

@ -111,7 +111,7 @@ M: freetype-renderer open-font ( font -- open-font )
freetype drop open-fonts get [ <font> ] cache ;
: load-glyph ( font char -- glyph )
>r handle>> dup r> 0 FT_Load_Char
[ handle>> dup ] dip 0 FT_Load_Char
freetype-error face-glyph ;
: char-width ( open-font char -- w )
@ -174,7 +174,7 @@ M: freetype-renderer string-height ( open-font string -- h )
bi 2array ;
: <char-sprite> ( open-font char -- sprite )
over >r render-glyph dup r> glyph-texture-loc
over [ render-glyph dup ] dip glyph-texture-loc
over glyph-size pick glyph-texture-size <sprite>
[ bitmap>texture ] keep [ init-sprite ] keep ;
@ -206,7 +206,7 @@ M: freetype-renderer string-height ( open-font string -- h )
fonts>> [ open-font H{ } clone 2array ] cache first2 ;
M: freetype-renderer draw-string ( font string loc -- )
>r >r world get font-sprites r> r> (draw-string) ;
[ world get font-sprites ] 2dip (draw-string) ;
: run-char-widths ( open-font string -- widths )
char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;

5
basis/ui/gadgets/books/books.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
USING: accessors kernel sequences models ui.gadgets
math.geometry.rect fry ;
IN: ui.gadgets.books
TUPLE: book < gadget ;
@ -25,6 +26,6 @@ M: book model-changed ( model book -- )
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
M: book layout* ( book -- )
[ children>> ] [ dim>> ] bi [ >>dim drop ] curry each ;
[ children>> ] [ dim>> ] bi '[ _ >>dim drop ] each ;
M: book focusable-child* ( book -- child/t ) current-page ;

7
basis/ui/gadgets/gadgets-tests.factor
View File

@ -152,6 +152,13 @@ M: mock-gadget ungraft*
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
] with-string-writer print
[ { { 10 30 } } ] [
<gadget> { 0 1 } >>orientation
{ { 10 20 } }
{ { 100 30 } }
orient
] unit-test
\ <gadget> must-infer
\ unparent must-infer
\ add-gadget must-infer

20
basis/ui/gadgets/gadgets.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
concurrency.flags math.order math.geometry.rect ;
concurrency.flags math.order math.geometry.rect fry ;
IN: ui.gadgets
SYMBOL: ui-notify-flag
@ -56,9 +56,7 @@ M: gadget model-changed 2drop ;
2dup eq? [
2drop { 0 0 }
] [
over rect-loc >r
>r parent>> r> relative-loc
r> v+
over rect-loc [ [ parent>> ] dip relative-loc ] dip v+
] if ;
GENERIC: user-input* ( str gadget -- ? )
@ -73,7 +71,7 @@ M: gadget children-on nip children>> ;
[ swap loc>> v- ] dip v. 0 <=> ;
: (fast-children-on) ( dim axis children -- i )
-rot [ ((fast-children-on)) ] 2curry search drop ;
-rot '[ _ _ ((fast-children-on)) ] search drop ;
: fast-children-on ( rect axis children -- from to )
[ [ rect-loc ] 2dip (fast-children-on) 0 or ]
@ -95,10 +93,10 @@ M: gadget children-on nip children>> ;
: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
: orient ( gadget seq1 seq2 -- seq )
>r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
rot orientation>> '[ _ set-axis ] 2map ;
: each-child ( gadget quot -- )
>r children>> r> each ; inline
[ children>> ] dip each ; inline
! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? )
@ -310,18 +308,18 @@ SYMBOL: in-layout?
[ parent>> ] follow ;
: each-parent ( gadget quot -- ? )
>r parents r> all? ; inline
[ parents ] dip all? ; inline
: find-parent ( gadget quot -- parent )
>r parents r> find nip ; inline
[ parents ] dip find nip ; inline
: screen-loc ( gadget -- loc )
parents { 0 0 } [ rect-loc v+ ] reduce ;
: (screen-rect) ( gadget -- loc ext )
dup parent>> [
>r rect-extent r> (screen-rect)
>r tuck v+ r> vmin >r v+ r>
[ rect-extent ] dip (screen-rect)
[ tuck v+ ] dip vmin [ v+ ] dip
] [
rect-extent
] if* ;

11
basis/ui/gadgets/grid-lines/grid-lines.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math namespaces opengl opengl.gl sequences
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
USING: kernel accessors math namespaces opengl opengl.gl
sequences math.vectors ui.gadgets ui.gadgets.grids ui.render
math.geometry.rect fry ;
IN: ui.gadgets.grid-lines
TUPLE: grid-lines color ;
@ -19,8 +20,8 @@ SYMBOL: grid-dim
: draw-grid-lines ( gaps orientation -- )
[ grid get swap grid-positions grid get rect-dim suffix ] dip
[ [ v- ] curry map ] keep
[ swap grid-line-from/to gl-line ] curry each ;
[ '[ _ v- ] map ] keep
'[ _ swap grid-line-from/to gl-line ] each ;
M: grid-lines draw-boundary
color>> gl-color [

17
basis/ui/gadgets/grids/grids.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
io.streams.string math.vectors ui.gadgets columns accessors
math.geometry.rect locals ;
math.geometry.rect locals fry ;
IN: ui.gadgets.grids
TUPLE: grid < gadget
@ -48,21 +48,18 @@ grid
dupd add-gaps dim-sum v+ ;
M: grid pref-dim*
dup gap>> swap compute-grid >r over r>
gap-sum >r gap-sum r> (pair-up) ;
dup gap>> swap compute-grid [ over ] dip
[ gap-sum ] 2bi@ (pair-up) ;
: do-grid ( dims grid quot -- )
-rot grid>>
[ [ pick call ] 2each ] 2each
drop ; inline
[ grid>> ] dip '[ _ 2each ] 2each ; inline
: grid-positions ( grid dims -- locs )
>r gap>> dup r> add-gaps swap [ v+ ] accumulate nip ;
[ gap>> dup ] dip add-gaps swap [ v+ ] accumulate nip ;
: position-grid ( grid horiz vert -- )
pick >r
>r over r> grid-positions >r grid-positions r>
pair-up r> [ (>>loc) ] do-grid ;
pick [ [ over ] dip [ grid-positions ] 2bi@ pair-up ] dip
[ (>>loc) ] do-grid ;
: resize-grid ( grid horiz vert -- )
pick fill?>> [

6
basis/ui/gadgets/labelled/labelled.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets.buttons ui.gadgets.borders
ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
@ -19,10 +19,10 @@ TUPLE: labelled-gadget < track content ;
M: labelled-gadget focusable-child* content>> ;
: <labelled-scroller> ( gadget title -- gadget )
>r <scroller> r> <labelled-gadget> ;
[ <scroller> ] dip <labelled-gadget> ;
: <labelled-pane> ( model quot scrolls? title -- gadget )
>r >r <pane-control> r> >>scrolls? r>
[ [ <pane-control> ] dip >>scrolls? ] dip
<labelled-scroller> ;
: <close-box> ( quot -- button/f )

2
basis/ui/gadgets/labels/labels.factor
View File

@ -13,7 +13,7 @@ TUPLE: label < gadget text font color ;
: set-label-string ( string label -- )
CHAR: \n pick memq? [
>r string-lines r> (>>text)
[ string-lines ] dip (>>text)
] [
(>>text)
] if ; inline

8
basis/ui/gadgets/lists/lists.factor
View File

@ -33,7 +33,7 @@ TUPLE: list < pack index presenter color hook ;
hook>> [ [ list? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
keep >r >label text-theme r>
keep [ >label text-theme ] dip
<presentation>
swap >>hook ; inline
@ -42,7 +42,7 @@ TUPLE: list < pack index presenter color hook ;
[ presenter>> ]
[ control-value ]
tri [
>r 2dup r> swap <list-presentation>
[ 2dup ] dip swap <list-presentation>
] map 2nip ;
M: list model-changed
@ -113,8 +113,8 @@ M: list focusable-child* drop t ;
select-gadget ;
: list-page ( list vec -- )
>r dup selected-rect rect-bounds 2 v/n v+
over visible-dim r> v* v+ swap select-at ;
[ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
v* v+ swap select-at ;
: list-page-up ( list -- ) { 0 -1 } list-page ;

4
basis/ui/gadgets/menus/menus.factor
View File

@ -8,13 +8,13 @@ math.geometry.rect ;
IN: ui.gadgets.menus
: menu-loc ( world menu -- loc )
>r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
[ rect-dim ] [ pref-dim ] bi* [v-] hand-loc get-global vmin ;
TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass )
menu-glass new-gadget
>r over menu-loc >>loc r>
[ over menu-loc >>loc ] dip
swap add-gadget ;
M: menu-glass layout* gadget-child prefer ;

11
basis/ui/gadgets/packs/packs.factor
View File

@ -19,10 +19,10 @@ TUPLE: pack < gadget
{ 0 0 } [ v+ over v+ ] accumulate 2nip ;
: aligned-locs ( gadget sizes -- seq )
[ >r dup align>> swap rect-dim r> v- n*v ] with map ;
[ [ dup align>> swap rect-dim ] dip v- n*v ] with map ;
: packed-locs ( gadget sizes -- seq )
over gap>> over gap-locs >r dupd aligned-locs r> orient ;
over gap>> over gap-locs [ dupd aligned-locs ] dip orient ;
: round-dims ( seq -- newseq )
{ 0 0 } swap
@ -31,8 +31,9 @@ TUPLE: pack < gadget
: pack-layout ( pack sizes -- )
round-dims over children>>
>r dupd packed-dims r> 2dup [ (>>dim) ] 2each
>r packed-locs r> [ (>>loc) ] 2each ;
[ dupd packed-dims ] dip
[ [ (>>dim) ] 2each ]
[ [ packed-locs ] dip [ (>>loc) ] 2each ] 2bi ;
: <pack> ( orientation -- pack )
pack new-gadget
@ -48,7 +49,7 @@ TUPLE: pack < gadget
[ dim-sum ] keep length 1 [-] rot n*v v+ ;
: pack-pref-dim ( gadget sizes -- dim )
over gap>> over gap-dims >r max-dim r>
over gap>> over gap-dims [ max-dim ] dip
rot orientation>> set-axis ;
M: pack pref-dim*

24
basis/ui/gadgets/panes/panes.factor
View File

@ -9,7 +9,7 @@ opengl combinators math.vectors sorting splitting
io.streams.nested assocs ui.gadgets.presentations
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect ;
math.geometry.rect fry ;
IN: ui.gadgets.panes
TUPLE: pane < pack
@ -59,7 +59,7 @@ M: pane gadget-selection ( pane -- string/f )
GENERIC: draw-selection ( loc obj -- )
: if-fits ( rect quot -- )
>r clip get over intersects? r> [ drop ] if ; inline
[ clip get over intersects? ] dip [ drop ] if ; inline
M: gadget draw-selection ( loc gadget -- )
swap offset-rect [
@ -135,8 +135,8 @@ M: style-stream write-gadget
: with-pane ( pane quot -- )
over scroll>top
over pane-clear >r <pane-stream> r>
over >r with-output-stream* r> ?nl ; inline
over pane-clear [ <pane-stream> ] dip
over [ with-output-stream* ] dip ?nl ; inline
: make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline
@ -154,7 +154,7 @@ M: pane-control model-changed ( model pane-control -- )
swap >>model ;
: do-pane-stream ( pane-stream quot -- )
>r pane>> r> keep scroll-pane ; inline
[ pane>> ] dip keep scroll-pane ; inline
M: pane-stream stream-nl
[ pane-nl drop ] do-pane-stream ;
@ -178,7 +178,7 @@ M: pane-stream make-span-stream
! Character styles
: apply-style ( style gadget key quot -- style gadget )
>r pick at r> when* ; inline
[ pick at ] dip when* ; inline
: apply-foreground-style ( style gadget -- style gadget )
foreground [ >>color ] apply-style ;
@ -228,7 +228,7 @@ M: pane-stream make-span-stream
border-width [ <border> ] apply-style ;
: apply-printer-style ( style gadget -- style gadget )
presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
presented-printer [ '[ _ make-pane ] >>printer ] apply-style ;
: style-pane ( style pane -- pane )
apply-border-width-style
@ -284,10 +284,10 @@ M: pane-stream make-cell-stream
pane-cell-stream new-nested-pane-stream ;
M: pane-stream stream-write-table
>r
swap [ [ pane>> smash-pane ] map ] map
styled-grid
r> print-gadget ;
[
swap [ [ pane>> smash-pane ] map ] map
styled-grid
] dip print-gadget ;
! Stream utilities
M: pack dispose drop ;
@ -309,7 +309,7 @@ M: paragraph stream-write
drop ;
: gadget-write1 ( char gadget -- )
>r 1string r> stream-write ;
[ 1string ] dip stream-write ;
M: pack stream-write1 gadget-write1 ;

2
basis/ui/gadgets/presentations/presentations.factor
View File

@ -12,7 +12,7 @@ TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- )
over dup hook>> call
>r object>> r> invoke-command ;
[ object>> ] dip invoke-command ;
: invoke-primary ( presentation -- )
dup object>> primary-operation

19
basis/ui/gadgets/sliders/sliders.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models models.range math.vectors math.functions
quotations colors math.geometry.rect ;
quotations colors math.geometry.rect fry ;
IN: ui.gadgets.sliders
TUPLE: elevator < gadget direction ;
@ -104,13 +104,14 @@ elevator H{
: layout-thumb-loc ( slider -- )
dup thumb-loc (layout-thumb)
>r [ floor ] map r> (>>loc) ;
[ [ floor ] map ] dip (>>loc) ;
: layout-thumb-dim ( slider -- )
dup dup thumb-dim (layout-thumb) >r
>r dup rect-dim r>
rot orientation>> set-axis [ ceiling ] map
r> (>>dim) ;
dup dup thumb-dim (layout-thumb)
[
[ dup rect-dim ] dip
rot orientation>> set-axis [ ceiling ] map
] dip (>>dim) ;
: layout-thumb ( slider -- )
dup layout-thumb-loc layout-thumb-dim ;
@ -121,13 +122,13 @@ M: elevator layout*
: slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
: <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r>
[ swap find-slider slide-by-line ] curry <repeat-button>
[ gray swap <polygon-gadget> ] dip
'[ _ swap find-slider slide-by-line ] <repeat-button>
swap >>orientation ;
: elevator, ( gadget orientation -- gadget )
tuck <elevator> >>elevator
swap <thumb> >>thumb
swap <thumb> >>thumb
dup elevator>> over thumb>> add-gadget
@center grid-add ;

2
basis/ui/gadgets/status-bar/status-bar.factor
View File

@ -16,4 +16,4 @@ IN: ui.gadgets.status-bar
open-world-window ;
: show-summary ( object gadget -- )
>r [ summary ] [ "" ] if* r> show-status ;
[ [ summary ] [ "" ] if* ] dip show-status ;

17
basis/ui/gadgets/worlds/worlds-docs.factor
View File

@ -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" } ;

2
basis/ui/gadgets/worlds/worlds.factor
View File

@ -52,7 +52,7 @@ M: world request-focus-on ( child gadget -- )
M: world layout*
dup call-next-method
dup glass>> [
>r dup rect-dim r> (>>dim)
[ dup rect-dim ] dip (>>dim)
] when* drop ;
M: world focusable-child* gadget-child ;

52
basis/ui/gestures/gestures-docs.factor
View File

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

2
basis/ui/operations/operations.factor
View File

@ -38,7 +38,7 @@ SYMBOL: operations
operations get [ predicate>> call ] with filter ;
: find-operation ( obj quot -- command )
>r object-operations r> find-last nip ; inline
[ object-operations ] dip find-last nip ; inline
: primary-operation ( obj -- operation )
[ command>> +primary+ word-prop ] find-operation ;

19
basis/ui/render/render-docs.factor
View File

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

10
basis/ui/render/render.factor
View File

@ -12,7 +12,7 @@ SYMBOL: viewport-translation
: flip-rect ( rect -- loc dim )
rect-bounds [
>r { 1 -1 } v* r> { 0 -1 } v* v+
[ { 1 -1 } v* ] dip { 0 -1 } v* v+
viewport-translation get v+
] keep ;
@ -79,9 +79,7 @@ DEFER: draw-gadget
>absolute clip [ rect-intersect ] change ;
: with-clipping ( gadget quot -- )
clip get >r
over change-clip do-clip call
r> clip set do-clip ; inline
clip get [ over change-clip do-clip call ] dip clip set do-clip ; inline
: draw-gadget ( gadget -- )
{
@ -200,7 +198,7 @@ M: polygon draw-interior
: <polygon-gadget> ( color points -- gadget )
dup max-dim
>r <polygon> <gadget> r> >>dim
[ <polygon> <gadget> ] dip >>dim
swap >>interior ;
! Font rendering
@ -242,7 +240,7 @@ HOOK: free-fonts font-renderer ( world -- )
[
[
2dup { 0 0 } draw-string
>r open-font r> string-height
[ open-font ] dip string-height
0.0 swap 0.0 glTranslated
] with each
] with-translation

15
basis/ui/tools/deploy/deploy.factor
View File

@ -1,12 +1,11 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.gadgets colors kernel ui.render namespaces
models models.mapping sequences ui.gadgets.buttons
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
tools.deploy vocabs ui.tools.workspace system accessors ;
USING: ui.gadgets colors kernel ui.render namespaces models
models.mapping sequences ui.gadgets.buttons ui.gadgets.packs
ui.gadgets.labels tools.deploy.config namespaces
ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands
assocs ui.gadgets.tracks ui ui.tools.listener tools.deploy
vocabs ui.tools.workspace system accessors fry ;
IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ;
@ -83,7 +82,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
: com-deploy ( gadget -- )
dup com-save
dup find-deploy-vocab [ deploy ] curry call-listener
dup find-deploy-vocab '[ _ deploy ] call-listener
close-window ;
: com-help ( -- )

6
basis/ui/tools/interactor/interactor.factor
View File

@ -7,7 +7,7 @@ quotations sequences strings threads listener classes.tuple
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions calendar concurrency.flags concurrency.mailboxes
ui.tools.workspace accessors sets destructors ;
ui.tools.workspace accessors sets destructors fry ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
@ -88,7 +88,7 @@ M: interactor model-changed
[ editor-string ] keep
[ interactor-input. ] 2keep
[ add-interactor-history ] keep
[ clear-input ] curry "Clearing input" spawn drop ;
'[ _ clear-input ] "Clearing input" spawn drop ;
: interactor-eof ( interactor -- )
dup interactor-busy? [
@ -126,7 +126,7 @@ M: interactor stream-read
swap dup zero? [
2drop ""
] [
>r interactor-read dup [ "\n" join ] when r> short head
[ interactor-read dup [ "\n" join ] when ] dip short head
] if ;
M: interactor stream-read-partial

6
basis/ui/tools/listener/listener.factor
View File

@ -28,7 +28,7 @@ M: listener-gadget focusable-child*
input>> ;
M: listener-gadget call-tool* ( input listener -- )
>r string>> r> input>> set-editor-string ;
[ string>> ] dip input>> set-editor-string ;
M: listener-gadget tool-scroller
output>> find-scroller ;
@ -95,13 +95,13 @@ M: engine-word word-completion-string
: use-if-necessary ( word seq -- )
over vocabulary>> over and [
2dup [ assoc-stack ] keep = [ 2drop ] [
>r vocabulary>> vocab-words r> push
[ vocabulary>> vocab-words ] dip push
] if
] [ 2drop ] if ;
: insert-word ( word -- )
get-workspace listener>> input>>
[ >r word-completion-string r> user-input* drop ]
[ [ word-completion-string ] dip user-input* drop ]
[ interactor-use use-if-necessary ]
2bi ;

8
basis/ui/tools/profiler/profiler.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: ui.tools.workspace kernel quotations tools.profiler
ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors fry ;
IN: ui.tools.profiler
TUPLE: profiler-gadget < track pane ;
@ -14,7 +14,7 @@ TUPLE: profiler-gadget < track pane ;
dup pane>> <scroller> 1 track-add ;
: with-profiler-pane ( gadget quot -- )
>r pane>> r> with-pane ;
[ pane>> ] dip with-pane ;
: com-full-profile ( gadget -- )
[ profile. ] with-profiler-pane ;
@ -39,10 +39,10 @@ profiler-gadget "toolbar" f {
GENERIC: profiler-presentation ( obj -- quot )
M: usage-profile profiler-presentation
word>> [ usage-profile. ] curry ;
word>> '[ _ usage-profile. ] ;
M: vocab-profile profiler-presentation
vocab>> [ vocab-profile. ] curry ;
vocab>> '[ _ vocab-profile. ] ;
M: f profiler-presentation
drop [ vocabs-profile. ] ;

2
basis/ui/tools/search/search-tests.factor
View File

@ -19,7 +19,7 @@ IN: ui.tools.search.tests
] with-grafted-gadget ;
: test-live-search ( gadget quot -- ? )
>r update-live-search dup assert-non-empty r> all? ;
[ update-live-search dup assert-non-empty ] dip all? ;
[ t ] [
"swp" all-words f <definition-search>

17
basis/ui/tools/tools-docs.factor
View File

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

4
basis/ui/tools/tools.factor
View File

@ -9,7 +9,7 @@ ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.gadgets.presentations ui.gestures words vocabs.loader
tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
mirrors ;
mirrors fry ;
IN: ui.tools
: <workspace-tabs> ( workspace -- tabs )
@ -93,7 +93,7 @@ workspace "workflow" f {
] workspace-window-hook set-global
: inspect-continuation ( traceback -- )
control-value [ inspect ] curry call-listener ;
control-value '[ _ inspect ] call-listener ;
traceback-gadget "toolbar" f {
{ T{ key-down f f "v" } variables }

6
basis/ui/tools/walker/walker.factor
View File

@ -5,7 +5,7 @@ ui.tools.listener ui.tools.traceback ui.gadgets.buttons
ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
models models.filter ui.tools.workspace ui.gestures
ui.gadgets.labels ui threads namespaces make tools.walker assocs
combinators ;
combinators fry ;
IN: ui.tools.walker
TUPLE: walker-gadget < track
@ -53,7 +53,7 @@ M: walker-gadget focusable-child*
] "" make ;
: <thread-status> ( model thread -- gadget )
[ walker-state-string ] curry <filter> <label-control> ;
'[ _ walker-state-string ] <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
{ 0 1 } walker-gadget new-track
@ -89,7 +89,7 @@ walker-gadget "toolbar" f {
} cond ;
: find-walker-window ( thread -- world/f )
[ swap walker-for-thread? ] curry find-window ;
'[ _ swap walker-for-thread? ] find-window ;
: walker-window ( status continuation thread -- )
[ <walker-gadget> ] [ name>> ] bi open-status-window ;

4
basis/ui/tools/workspace/workspace.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes continuations help help.topics kernel models
sequences assocs arrays namespaces accessors math.vectors ui
sequences assocs arrays namespaces accessors math.vectors fry ui
ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
@ -33,7 +33,7 @@ M: gadget tool-scroller drop f ;
set-model ;
: get-workspace* ( quot -- workspace )
[ >r dup workspace? r> [ drop f ] if ] curry find-window
'[ dup workspace? _ [ drop f ] if ] find-window
[ dup raise-window gadget-child ]
[ workspace-window* ] if* ; inline

47
basis/ui/ui-docs.factor
View File

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

30
basis/ui/windows/windows.factor
View File

@ -285,10 +285,10 @@ 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 )
>r >lo-hi r>
[ >lo-hi ] dip
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
get-RECT-top-left 2array v- ;
@ -297,7 +297,7 @@ SYMBOL: nc-buttons
[ <button-down> ] [ <button-up> ] if ;
: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
nip >r mouse-event>gesture r> >lo-hi rot window ;
[ drop mouse-event>gesture ] dip >lo-hi rot window ;
: set-capture ( hwnd -- )
mouse-captured get [
@ -312,10 +312,10 @@ SYMBOL: nc-buttons
mouse-captured off ;
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
>r >r
over set-capture
dup message>button drop nc-buttons get delete
r> r> prepare-mouse send-button-down ;
[
over set-capture
dup message>button drop nc-buttons get delete
] 2dip prepare-mouse send-button-down ;
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
mouse-captured get [ release-capture ] when
@ -337,9 +337,10 @@ SYMBOL: nc-buttons
TrackMouseEvent drop
>lo-hi swap window move-hand fire-motion ;
: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
>r nip r>
pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
wParam mouse-wheel
lParam hWnd mouse-absolute>relative
hWnd window send-wheel ;
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging
@ -456,10 +457,11 @@ M: windows-ui-backend do-events
: create-window ( rect -- hwnd )
make-adjusted-RECT
>r class-name-ptr get-global f r>
>r >r >r ex-style r> r>
[ class-name-ptr get-global f ] dip
[
[ ex-style ] 2dip
{ WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
r> get-RECT-dimensions
] dip get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
: show-window ( hWnd -- )
@ -515,7 +517,7 @@ M: windows-ui-backend raise-window* ( world -- )
M: windows-ui-backend set-title ( string world -- )
handle>>
dup title>> [ free ] when*
>r utf16n malloc-string r>
[ utf16n malloc-string ] dip
2dup (>>title)
hWnd>> WM_SETTEXT 0 roll alien-address SendMessage drop ;

Some files were not shown because too many files have changed in this diff Show More