Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
c9c2be7500
|
|
@ -60,7 +60,7 @@ nl
|
|||
"." write flush
|
||||
|
||||
{
|
||||
new-sequence nth push pop peek
|
||||
new-sequence nth push pop peek flip
|
||||
} compile-uncompiled
|
||||
|
||||
"." write flush
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces assocs hashtables sequences
|
||||
USING: kernel math namespaces assocs hashtables sequences arrays
|
||||
accessors vectors combinators sets classes compiler.cfg
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.copy-prop ;
|
||||
|
|
@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ;
|
|||
M: ##slot-imm insn-slot# slot>> ;
|
||||
M: ##set-slot insn-slot# slot>> constant ;
|
||||
M: ##set-slot-imm insn-slot# slot>> ;
|
||||
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
|
||||
|
||||
M: ##peek insn-object loc>> class ;
|
||||
M: ##replace insn-object loc>> class ;
|
||||
|
|
@ -201,6 +202,7 @@ M: ##slot insn-object obj>> resolve ;
|
|||
M: ##slot-imm insn-object obj>> resolve ;
|
||||
M: ##set-slot insn-object obj>> resolve ;
|
||||
M: ##set-slot-imm insn-object obj>> resolve ;
|
||||
M: ##alien-global insn-object drop \ ##alien-global ;
|
||||
|
||||
: init-alias-analysis ( -- )
|
||||
H{ } clone histories set
|
||||
|
|
@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases*
|
|||
M: ##load-indirect analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##alien-global analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##allot analyze-aliases*
|
||||
#! A freshly allocated object is distinct from any other
|
||||
#! object.
|
||||
|
|
|
|||
|
|
@ -65,6 +65,7 @@ IN: compiler.cfg.hats
|
|||
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
|
||||
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
|
||||
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
|
||||
: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
|
||||
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
|
||||
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
|
||||
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
|
||||
|
|
|
|||
|
|
@ -161,6 +161,8 @@ INSN: ##set-alien-double < ##alien-setter ;
|
|||
INSN: ##allot < ##flushable size class { temp vreg } ;
|
||||
INSN: ##write-barrier < ##effect card# table ;
|
||||
|
||||
INSN: ##alien-global < ##read symbol library ;
|
||||
|
||||
! FFI
|
||||
INSN: ##alien-invoke params ;
|
||||
INSN: ##alien-indirect params ;
|
||||
|
|
|
|||
|
|
@ -12,8 +12,7 @@ compiler.cfg.registers ;
|
|||
IN: compiler.cfg.intrinsics.fixnum
|
||||
|
||||
: emit-both-fixnums? ( -- )
|
||||
D 0 ^^peek
|
||||
D 1 ^^peek
|
||||
2inputs
|
||||
^^or
|
||||
tag-mask get ^^and-imm
|
||||
0 cc= ^^compare-imm
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ compiler.cfg.intrinsics.allot
|
|||
compiler.cfg.intrinsics.fixnum
|
||||
compiler.cfg.intrinsics.float
|
||||
compiler.cfg.intrinsics.slots
|
||||
compiler.cfg.intrinsics.misc
|
||||
compiler.cfg.iterator ;
|
||||
QUALIFIED: kernel
|
||||
QUALIFIED: arrays
|
||||
|
|
@ -23,6 +24,7 @@ IN: compiler.cfg.intrinsics
|
|||
|
||||
{
|
||||
kernel.private:tag
|
||||
kernel.private:getenv
|
||||
math.private:both-fixnums?
|
||||
math.private:fixnum+
|
||||
math.private:fixnum-
|
||||
|
|
@ -94,6 +96,7 @@ IN: compiler.cfg.intrinsics
|
|||
: emit-intrinsic ( node word -- node/f )
|
||||
{
|
||||
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
|
||||
{ \ kernel.private:getenv [ emit-getenv 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 ] }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces layouts sequences kernel
|
||||
accessors compiler.tree.propagation.info
|
||||
compiler.cfg.stacks compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.intrinsics.misc
|
||||
|
||||
: emit-tag ( -- )
|
||||
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
||||
|
||||
: emit-getenv ( node -- )
|
||||
"userenv" f ^^alien-global
|
||||
swap node-input-infos first literal>>
|
||||
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
|
||||
ds-push ;
|
||||
|
|
@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
|
|||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.intrinsics.slots
|
||||
|
||||
: emit-tag ( -- )
|
||||
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
|
||||
|
||||
: value-tag ( info -- n ) class>> class-tag ; inline
|
||||
|
||||
: (emit-slot) ( infos -- dst )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel sequences sequences.deep
|
||||
USING: accessors arrays kernel sequences compiler.utilities
|
||||
compiler.cfg.instructions cpu.architecture ;
|
||||
IN: compiler.cfg.two-operand
|
||||
|
||||
|
|
@ -55,6 +55,6 @@ M: insn convert-two-operand* ;
|
|||
: convert-two-operand ( mr -- mr' )
|
||||
[
|
||||
two-operand? [
|
||||
[ convert-two-operand* ] map flatten
|
||||
[ convert-two-operand* ] map-flat
|
||||
] when
|
||||
] change-instructions ;
|
||||
|
|
|
|||
|
|
@ -236,6 +236,10 @@ M: _gc generate-insn drop %gc ;
|
|||
|
||||
M: ##loop-entry generate-insn drop %loop-entry ;
|
||||
|
||||
M: ##alien-global generate-insn
|
||||
[ dst>> register ] [ symbol>> ] [ library>> ] tri
|
||||
%alien-global ;
|
||||
|
||||
! ##alien-invoke
|
||||
GENERIC: reg-size ( register-class -- n )
|
||||
|
||||
|
|
@ -451,7 +455,7 @@ M: ##alien-indirect generate-insn
|
|||
|
||||
TUPLE: callback-context ;
|
||||
|
||||
: current-callback 2 getenv ;
|
||||
: current-callback ( -- id ) 2 getenv ;
|
||||
|
||||
: wait-to-return ( token -- )
|
||||
dup current-callback eq? [
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences sequences.deep combinators fry
|
||||
USING: kernel accessors sequences combinators fry
|
||||
classes.algebra namespaces assocs words math math.private
|
||||
math.partial-dispatch math.intervals classes classes.tuple
|
||||
classes.tuple.private layouts definitions stack-checker.state
|
||||
stack-checker.branches
|
||||
compiler.utilities
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -33,7 +34,7 @@ GENERIC: cleanup* ( node -- node/nodes )
|
|||
: cleanup ( nodes -- nodes' )
|
||||
#! We don't recurse into children here, instead the methods
|
||||
#! do it since the logic is a bit more involved
|
||||
[ cleanup* ] map flatten ;
|
||||
[ cleanup* ] map-flat ;
|
||||
|
||||
: cleanup-folding? ( #call -- ? )
|
||||
node-output-infos
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs fry kernel accessors sequences sequences.deep arrays
|
||||
stack-checker.inlining namespaces compiler.tree ;
|
||||
USING: assocs fry kernel accessors sequences compiler.utilities
|
||||
arrays stack-checker.inlining namespaces compiler.tree
|
||||
math.order ;
|
||||
IN: compiler.tree.combinators
|
||||
|
||||
: each-node ( nodes quot: ( node -- ) -- )
|
||||
|
|
@ -27,7 +28,7 @@ IN: compiler.tree.combinators
|
|||
[ _ map-nodes ] change-child
|
||||
] when
|
||||
] if
|
||||
] map flatten ; inline recursive
|
||||
] map-flat ; inline recursive
|
||||
|
||||
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
|
||||
dup dup '[
|
||||
|
|
@ -48,12 +49,6 @@ IN: compiler.tree.combinators
|
|||
: sift-children ( seq flags -- seq' )
|
||||
zip [ nip ] assoc-filter keys ;
|
||||
|
||||
: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
|
||||
|
||||
: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
|
||||
|
||||
: until-fixed-point ( #recursive quot: ( node -- ) -- )
|
||||
over label>> t >>fixed-point drop
|
||||
[ with-scope ] 2keep
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors namespaces assocs deques search-deques
|
||||
dlists kernel sequences sequences.deep words sets
|
||||
dlists kernel sequences compiler.utilities words sets
|
||||
stack-checker.branches compiler.tree compiler.tree.def-use
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.dead-code.liveness
|
||||
|
|
@ -49,4 +49,4 @@ GENERIC: remove-dead-code* ( node -- node' )
|
|||
M: node remove-dead-code* ;
|
||||
|
||||
: (remove-dead-code) ( nodes -- nodes' )
|
||||
[ remove-dead-code* ] map flatten ;
|
||||
[ remove-dead-code* ] map-flat ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences sequences.deep kernel
|
||||
USING: sequences kernel fry vectors
|
||||
compiler.tree compiler.tree.def-use ;
|
||||
IN: compiler.tree.def-use.simplified
|
||||
|
||||
|
|
@ -9,8 +9,6 @@ IN: compiler.tree.def-use.simplified
|
|||
! A 'real' usage is a usage of a value that is not a #renaming.
|
||||
TUPLE: real-usage value node ;
|
||||
|
||||
GENERIC: actually-used-by* ( value node -- real-usages )
|
||||
|
||||
! Def
|
||||
GENERIC: actually-defined-by* ( value node -- real-usage )
|
||||
|
||||
|
|
@ -25,16 +23,18 @@ M: #return-recursive actually-defined-by* real-usage boa ;
|
|||
M: node actually-defined-by* real-usage boa ;
|
||||
|
||||
! Use
|
||||
: (actually-used-by) ( value -- real-usages )
|
||||
dup used-by [ actually-used-by* ] with map ;
|
||||
GENERIC# actually-used-by* 1 ( value node accum -- )
|
||||
|
||||
: (actually-used-by) ( value accum -- )
|
||||
[ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
|
||||
|
||||
M: #renaming actually-used-by*
|
||||
inputs/outputs [ indices ] dip nths
|
||||
[ (actually-used-by) ] map ;
|
||||
[ inputs/outputs [ indices ] dip nths ] dip
|
||||
'[ _ (actually-used-by) ] each ;
|
||||
|
||||
M: #return-recursive actually-used-by* real-usage boa ;
|
||||
M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
|
||||
|
||||
M: node actually-used-by* real-usage boa ;
|
||||
M: node actually-used-by* [ real-usage boa ] dip push ;
|
||||
|
||||
: actually-used-by ( value -- real-usages )
|
||||
(actually-used-by) flatten ;
|
||||
10 <vector> [ (actually-used-by) ] keep ;
|
||||
|
|
|
|||
|
|
@ -33,4 +33,4 @@ M: #branch escape-analysis*
|
|||
2bi ;
|
||||
|
||||
M: #phi escape-analysis*
|
||||
[ phi-in-d>> <flipped> ] [ out-d>> ] bi merge-allocations ;
|
||||
[ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,23 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.tuple math math.private accessors
|
||||
combinators kernel compiler.tree compiler.tree.combinators
|
||||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.escape-analysis.check
|
||||
|
||||
GENERIC: run-escape-analysis* ( node -- ? )
|
||||
|
||||
M: #push run-escape-analysis*
|
||||
literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ;
|
||||
|
||||
M: #call run-escape-analysis*
|
||||
{
|
||||
{ [ dup word>> \ <complex> eq? ] [ t ] }
|
||||
{ [ dup immutable-tuple-boa? ] [ t ] }
|
||||
[ f ]
|
||||
} cond nip ;
|
||||
|
||||
M: node run-escape-analysis* drop f ;
|
||||
|
||||
: run-escape-analysis? ( nodes -- ? )
|
||||
[ run-escape-analysis* ] contains-node? ;
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences words memoize classes.builtin
|
||||
USING: kernel accessors sequences words memoize combinators
|
||||
classes classes.builtin classes.tuple math.partial-dispatch
|
||||
fry assocs
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
|
|
@ -12,7 +13,7 @@ IN: compiler.tree.finalization
|
|||
! See the comment in compiler.tree.late-optimizations.
|
||||
|
||||
! This pass runs after propagation, so that it can expand
|
||||
! built-in type predicates; these cannot be expanded before
|
||||
! type predicates; these cannot be expanded before
|
||||
! propagation since we need to see 'fixnum?' instead of
|
||||
! 'tag 0 eq?' and so on, for semantic reasoning.
|
||||
|
||||
|
|
@ -33,16 +34,24 @@ M: #shuffle finalize*
|
|||
[ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
|
||||
bi and [ drop f ] when ;
|
||||
|
||||
: builtin-predicate? ( #call -- ? )
|
||||
word>> "predicating" word-prop builtin-class? ;
|
||||
|
||||
MEMO: builtin-predicate-expansion ( word -- nodes )
|
||||
MEMO: cached-expansion ( word -- nodes )
|
||||
def>> splice-final ;
|
||||
|
||||
: expand-builtin-predicate ( #call -- nodes )
|
||||
word>> builtin-predicate-expansion ;
|
||||
GENERIC: finalize-word ( #call word -- nodes )
|
||||
|
||||
M: predicate finalize-word
|
||||
"predicating" word-prop {
|
||||
{ [ dup builtin-class? ] [ drop word>> cached-expansion ] }
|
||||
{ [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
! M: math-partial finalize-word
|
||||
! dup primitive? [ drop ] [ nip cached-expansion ] if ;
|
||||
|
||||
M: word finalize-word drop ;
|
||||
|
||||
M: #call finalize*
|
||||
dup builtin-predicate? [ expand-builtin-predicate ] when ;
|
||||
dup word>> finalize-word ;
|
||||
|
||||
M: node finalize* ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry namespaces sequences math accessors kernel arrays
|
||||
combinators sequences.deep assocs
|
||||
combinators compiler.utilities assocs
|
||||
stack-checker.backend
|
||||
stack-checker.branches
|
||||
stack-checker.inlining
|
||||
compiler.utilities
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.normalization.introductions
|
||||
|
|
@ -46,7 +47,7 @@ M: #branch normalize*
|
|||
[
|
||||
[
|
||||
[
|
||||
[ normalize* ] map flatten
|
||||
[ normalize* ] map-flat
|
||||
introduction-stack get
|
||||
2array
|
||||
] with-scope
|
||||
|
|
@ -70,7 +71,7 @@ M: #phi normalize*
|
|||
|
||||
: (normalize) ( nodes introductions -- nodes )
|
||||
introduction-stack [
|
||||
[ normalize* ] map flatten
|
||||
[ normalize* ] map-flat
|
||||
] with-variable ;
|
||||
|
||||
M: #recursive normalize*
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ compiler.tree.normalization
|
|||
compiler.tree.propagation
|
||||
compiler.tree.cleanup
|
||||
compiler.tree.escape-analysis
|
||||
compiler.tree.escape-analysis.check
|
||||
compiler.tree.tuple-unboxing
|
||||
compiler.tree.identities
|
||||
compiler.tree.def-use
|
||||
|
|
@ -22,8 +23,10 @@ SYMBOL: check-optimizer?
|
|||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
dup run-escape-analysis? [
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
] when
|
||||
apply-identities
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
USING: fry kernel sequences assocs accessors namespaces
|
||||
math.intervals arrays classes.algebra combinators columns
|
||||
stack-checker.branches
|
||||
compiler.utilities
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -78,7 +79,7 @@ SYMBOL: condition-value
|
|||
|
||||
M: #phi propagate-before ( #phi -- )
|
||||
[ annotate-phi-inputs ]
|
||||
[ [ phi-info-d>> <flipped> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
|
||||
bi ;
|
||||
|
||||
: branch-phi-constraints ( output values booleans -- )
|
||||
|
|
@ -137,8 +138,8 @@ M: #phi propagate-before ( #phi -- )
|
|||
M: #phi propagate-after ( #phi -- )
|
||||
condition-value get [
|
||||
[ out-d>> ]
|
||||
[ phi-in-d>> <flipped> ]
|
||||
[ phi-info-d>> <flipped> ] tri
|
||||
[ phi-in-d>> flip ]
|
||||
[ phi-info-d>> flip ] tri
|
||||
[
|
||||
[ possible-boolean-values ] map
|
||||
branch-phi-constraints
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
|
|||
] 2each ;
|
||||
|
||||
M: #phi compute-copy-equiv*
|
||||
[ phi-in-d>> <flipped> ] [ out-d>> ] bi compute-phi-equiv ;
|
||||
[ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ;
|
||||
|
||||
M: node compute-copy-equiv* drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -184,7 +184,7 @@ SYMBOL: history
|
|||
over in-d>> second value-info literal>> dup class?
|
||||
[ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
|
||||
|
||||
: do-inlining ( #call word -- ? )
|
||||
: (do-inlining) ( #call word -- ? )
|
||||
#! If the generic was defined in an outer compilation unit,
|
||||
#! then it doesn't have a definition yet; the definition
|
||||
#! is built at the end of the compilation unit. We do not
|
||||
|
|
@ -195,7 +195,6 @@ SYMBOL: history
|
|||
#! discouraged, but it should still work.)
|
||||
{
|
||||
{ [ dup deferred? ] [ 2drop f ] }
|
||||
{ [ dup custom-inlining? ] [ inline-custom ] }
|
||||
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
|
||||
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
|
|
@ -203,3 +202,10 @@ SYMBOL: history
|
|||
{ [ dup method-body? ] [ inline-method-body ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
: do-inlining ( #call word -- ? )
|
||||
#! Note the logic here: if there's a custom inlining hook,
|
||||
#! it is permitted to return f, which means that we try the
|
||||
#! normal inlining heuristic.
|
||||
dup custom-inlining? [ 2dup inline-custom ] [ f ] if
|
||||
[ 2drop t ] [ (do-inlining) ] if ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ math.partial-dispatch math.intervals math.parser math.order
|
|||
layouts words sequences sequences.private arrays assocs classes
|
||||
classes.algebra combinators generic.math splitting fry locals
|
||||
classes.tuple alien.accessors classes.tuple.private slots.private
|
||||
definitions
|
||||
definitions strings.private vectors hashtables
|
||||
stack-checker.state
|
||||
compiler.tree.comparisons
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -194,6 +194,11 @@ generic-comparison-ops [
|
|||
2bi and maybe-or-never
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ both-fixnums? [
|
||||
[ class>> fixnum classes-intersect? not ] either?
|
||||
f <literal-info> object-info ?
|
||||
] "outputs" set-word-prop
|
||||
|
||||
{
|
||||
{ >fixnum fixnum }
|
||||
{ bignum>fixnum fixnum }
|
||||
|
|
@ -242,6 +247,10 @@ generic-comparison-ops [
|
|||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
\ string-nth [
|
||||
2drop fixnum 0 23 2^ [a,b] <class/interval-info>
|
||||
] "outputs" set-word-prop
|
||||
|
||||
{
|
||||
alien-signed-1
|
||||
alien-unsigned-1
|
||||
|
|
@ -283,6 +292,15 @@ generic-comparison-ops [
|
|||
"outputs" set-word-prop
|
||||
] each
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
||||
{ H{ } [ [ drop hashtable new ] ] }
|
||||
[ drop f ]
|
||||
} case
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
\ slot [
|
||||
dup literal?>>
|
||||
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@ 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
|
||||
specialized-arrays.double system sorting math.libm ;
|
||||
specialized-arrays.double system sorting math.libm
|
||||
math.intervals ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
\ propagate must-infer
|
||||
|
|
@ -599,6 +600,10 @@ MIXIN: empty-mixin
|
|||
|
||||
[ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
|
||||
|
||||
[ T{ interval f { 0 t } { 127 t } } ] [
|
||||
[ { integer } declare 127 bitand ] final-info first interval>>
|
||||
] unit-test
|
||||
|
||||
! [ V{ string } ] [
|
||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
! ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs accessors kernel combinators
|
||||
classes.algebra sequences sequences.deep slots.private
|
||||
classes.algebra sequences slots.private fry vectors
|
||||
classes.tuple.private math math.private arrays
|
||||
stack-checker.branches
|
||||
compiler.utilities
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -21,7 +22,7 @@ GENERIC: unbox-tuples* ( node -- node/nodes )
|
|||
: (expand-#push) ( object value -- nodes )
|
||||
dup unboxed-allocation dup [
|
||||
[ object-slots ] [ drop ] [ ] tri*
|
||||
[ (expand-#push) ] 2map
|
||||
[ (expand-#push) ] 2map-flat
|
||||
] [
|
||||
drop #push
|
||||
] if ;
|
||||
|
|
@ -38,11 +39,16 @@ M: #push unbox-tuples* ( #push -- nodes )
|
|||
: unbox-<complex> ( #call -- nodes )
|
||||
dup unbox-output? [ drop { } ] when ;
|
||||
|
||||
: (flatten-values) ( values -- values' )
|
||||
[ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
|
||||
: (flatten-values) ( values accum -- )
|
||||
dup '[
|
||||
dup unboxed-allocation
|
||||
[ _ (flatten-values) ] [ _ push ] ?if
|
||||
] each ;
|
||||
|
||||
: flatten-values ( values -- values' )
|
||||
dup empty? [ (flatten-values) flatten ] unless ;
|
||||
dup empty? [
|
||||
10 <vector> [ (flatten-values) ] keep
|
||||
] unless ;
|
||||
|
||||
: prepare-slot-access ( #call -- tuple-values outputs slot-values )
|
||||
[ in-d>> flatten-values ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private arrays vectors fry
|
||||
math.order ;
|
||||
IN: compiler.utilities
|
||||
|
||||
: flattener ( seq quot -- seq vector quot' )
|
||||
over length <vector> [
|
||||
dup
|
||||
'[
|
||||
@ [
|
||||
dup array?
|
||||
[ _ push-all ] [ _ push ] if
|
||||
] when*
|
||||
]
|
||||
] keep ; inline
|
||||
|
||||
: flattening ( seq quot combinator -- seq' )
|
||||
[ flattener ] dip dip { } like ; inline
|
||||
|
||||
: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
|
||||
|
||||
: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
|
||||
|
||||
: (3each) ( seq1 seq2 seq3 quot -- n quot' )
|
||||
[ [ [ length ] tri@ min min ] 3keep ] dip
|
||||
'[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline
|
||||
|
||||
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
|
||||
|
||||
: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
|
||||
|
|
@ -120,6 +120,8 @@ HOOK: %set-alien-cell cpu ( ptr value -- )
|
|||
HOOK: %set-alien-float cpu ( ptr value -- )
|
||||
HOOK: %set-alien-double cpu ( ptr value -- )
|
||||
|
||||
HOOK: %alien-global cpu ( dst symbol library -- )
|
||||
|
||||
HOOK: %allot cpu ( dst size class temp -- )
|
||||
HOOK: %write-barrier cpu ( src card# table -- )
|
||||
HOOK: %gc cpu ( -- )
|
||||
|
|
|
|||
|
|
@ -139,9 +139,9 @@ M:: ppc %string-nth ( dst src index temp -- )
|
|||
"end" define-label
|
||||
temp src index ADD
|
||||
dst temp string-offset LBZ
|
||||
0 dst HEX: 80 CMPI
|
||||
"end" get BLT
|
||||
temp src string-aux-offset LWZ
|
||||
0 temp \ f tag-number CMPI
|
||||
"end" get BEQ
|
||||
temp temp index ADD
|
||||
temp temp index ADD
|
||||
temp temp byte-array-offset LHZ
|
||||
|
|
@ -150,6 +150,10 @@ M:: ppc %string-nth ( dst src index temp -- )
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M:: ppc %set-string-nth-fast ( ch obj index temp -- )
|
||||
temp obj index ADD
|
||||
ch temp string-offset STB ;
|
||||
|
||||
M: ppc %add ADD ;
|
||||
M: ppc %add-imm ADDI ;
|
||||
M: ppc %sub swap SUBF ;
|
||||
|
|
|
|||
|
|
@ -44,8 +44,6 @@ 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 ;
|
||||
|
|
|
|||
|
|
@ -158,9 +158,6 @@ M: x86.64 %prepare-box-struct ( -- )
|
|||
|
||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||
|
||||
M: x86.64 %alien-global
|
||||
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
|
||||
|
||||
M: x86.64 %alien-invoke
|
||||
R11 0 MOV
|
||||
rc-absolute-cell rel-dlsym
|
||||
|
|
|
|||
|
|
@ -381,8 +381,8 @@ big-endian off
|
|||
|
||||
[
|
||||
arg0 ds-reg [] MOV
|
||||
arg0 ds-reg bootstrap-cell neg [+] OR
|
||||
ds-reg bootstrap-cell ADD
|
||||
ds-reg bootstrap-cell SUB
|
||||
arg0 ds-reg [] OR
|
||||
arg0 tag-mask get AND
|
||||
arg0 \ f tag-number MOV
|
||||
arg1 1 tag-fixnum MOV
|
||||
|
|
|
|||
|
|
@ -391,7 +391,7 @@ M:: x86 %string-nth ( dst src index temp -- )
|
|||
] with-small-register ;
|
||||
|
||||
M:: x86 %set-string-nth-fast ( ch str index temp -- )
|
||||
ch { index str } [| new-ch |
|
||||
ch { index str temp } [| new-ch |
|
||||
new-ch ch ?MOV
|
||||
temp str index [+] LEA
|
||||
temp string-offset [+] new-ch 1 small-reg MOV
|
||||
|
|
@ -458,19 +458,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
|
|||
dst class store-tagged
|
||||
nursery-ptr size inc-allot-ptr ;
|
||||
|
||||
HOOK: %alien-global cpu ( symbol dll register -- )
|
||||
|
||||
M:: x86 %write-barrier ( src card# table -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
! Mark the card
|
||||
card# src MOV
|
||||
card# card-bits SHR
|
||||
"cards_offset" f table %alien-global
|
||||
table "cards_offset" f %alien-global
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV
|
||||
|
||||
! Mark the card deck
|
||||
card# deck-bits card-bits - SHR
|
||||
"decks_offset" f table %alien-global
|
||||
table "decks_offset" f %alien-global
|
||||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV ;
|
||||
|
||||
M: x86 %gc ( -- )
|
||||
|
|
@ -485,6 +485,9 @@ M: x86 %gc ( -- )
|
|||
"minor_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
|
||||
M: x86 %alien-global
|
||||
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
||||
|
||||
HOOK: stack-reg cpu ( -- reg )
|
||||
|
||||
: decr-stack-reg ( n -- )
|
||||
|
|
@ -595,7 +598,8 @@ M: x86 %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 temp-reg-1 %alien-global
|
||||
temp-reg-1 "stack_chain" f %alien-global
|
||||
temp-reg-1 temp-reg-1 [] MOV
|
||||
temp-reg-1 [] stack-reg MOV
|
||||
temp-reg-1 [] cell SUB
|
||||
temp-reg-1 2 cells [+] ds-reg MOV
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel kernel.private math math.private words
|
||||
sequences parser namespaces make assocs quotations arrays locals
|
||||
sequences parser namespaces make assocs quotations arrays
|
||||
generic generic.math hashtables effects compiler.units
|
||||
classes.algebra ;
|
||||
classes.algebra fry combinators ;
|
||||
IN: math.partial-dispatch
|
||||
|
||||
PREDICATE: math-partial < word
|
||||
|
|
@ -45,60 +45,62 @@ M: word integer-op-input-classes
|
|||
{ bitnot fixnum-bitnot }
|
||||
} at swap or ;
|
||||
|
||||
:: fixnum-integer-op ( a b fix-word big-word -- c )
|
||||
b tag 0 eq? [
|
||||
a b fix-word execute
|
||||
] [
|
||||
a fixnum>bignum b big-word execute
|
||||
] if ; inline
|
||||
|
||||
:: integer-fixnum-op ( a b fix-word big-word -- c )
|
||||
a tag 0 eq? [
|
||||
a b fix-word execute
|
||||
] [
|
||||
a b fixnum>bignum big-word execute
|
||||
] if ; inline
|
||||
|
||||
:: integer-integer-op ( a b fix-word big-word -- c )
|
||||
b tag 0 eq? [
|
||||
a b fix-word big-word integer-fixnum-op
|
||||
] [
|
||||
a dup tag 0 eq? [ fixnum>bignum ] when
|
||||
b big-word execute
|
||||
] if ; inline
|
||||
|
||||
: integer-op-combinator ( triple -- word )
|
||||
: integer-fixnum-op-quot ( fix-word big-word -- quot )
|
||||
[
|
||||
[ second name>> % "-" % ]
|
||||
[ third name>> % "-op" % ]
|
||||
bi
|
||||
] "" make "math.partial-dispatch" lookup ;
|
||||
[ over fixnum? ] %
|
||||
[ '[ _ execute ] , ]
|
||||
[ '[ fixnum>bignum _ execute ] , ] bi*
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: fixnum-integer-op-quot ( fix-word big-word -- quot )
|
||||
[
|
||||
[ dup fixnum? ] %
|
||||
[ '[ _ execute ] , ]
|
||||
[ '[ [ fixnum>bignum ] dip _ execute ] , ] bi*
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: integer-integer-op-quot ( fix-word big-word -- quot )
|
||||
[
|
||||
[ dup fixnum? ] %
|
||||
2dup integer-fixnum-op-quot ,
|
||||
[
|
||||
[ over fixnum? [ [ fixnum>bignum ] dip ] when ] %
|
||||
nip ,
|
||||
] [ ] make ,
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: integer-op-word ( triple -- word )
|
||||
[ name>> ] map "-" join "math.partial-dispatch" create ;
|
||||
|
||||
: integer-op-quot ( triple fix-word big-word -- quot )
|
||||
rot integer-op-combinator 1quotation 2curry ;
|
||||
: integer-op-quot ( fix-word big-word triple -- quot )
|
||||
[ second ] [ third ] bi 2array {
|
||||
{ { fixnum integer } [ fixnum-integer-op-quot ] }
|
||||
{ { integer fixnum } [ integer-fixnum-op-quot ] }
|
||||
{ { integer integer } [ integer-integer-op-quot ] }
|
||||
} case ;
|
||||
|
||||
: define-integer-op-word ( triple fix-word big-word -- )
|
||||
: define-integer-op-word ( fix-word big-word triple -- )
|
||||
[
|
||||
[ 2drop integer-op-word ] [ integer-op-quot ] 3bi
|
||||
[ 2nip integer-op-word ] [ integer-op-quot ] 3bi
|
||||
(( x y -- z )) define-declared
|
||||
] [
|
||||
2drop
|
||||
2nip
|
||||
[ integer-op-word ] keep
|
||||
"derived-from" set-word-prop
|
||||
] 3bi ;
|
||||
|
||||
: define-integer-op-words ( triples fix-word big-word -- )
|
||||
[ define-integer-op-word ] 2curry each ;
|
||||
'[ [ _ _ ] dip define-integer-op-word ] each ;
|
||||
|
||||
: integer-op-triples ( word -- triples )
|
||||
{
|
||||
{ fixnum integer }
|
||||
{ integer fixnum }
|
||||
{ integer integer }
|
||||
} swap [ prefix ] curry map ;
|
||||
} swap '[ _ prefix ] map ;
|
||||
|
||||
: define-integer-ops ( word fix-word big-word -- )
|
||||
[
|
||||
|
|
@ -138,7 +140,7 @@ SYMBOL: fast-math-ops
|
|||
[ drop math-class-max swap specific-method >boolean ] if ;
|
||||
|
||||
: (derived-ops) ( word assoc -- words )
|
||||
swap [ rot first eq? nip ] curry assoc-filter ;
|
||||
swap '[ swap first _ eq? nip ] assoc-filter ;
|
||||
|
||||
: derived-ops ( word -- words )
|
||||
[ 1array ] [ math-ops get (derived-ops) values ] bi append ;
|
||||
|
|
|
|||
|
|
@ -4,8 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs
|
|||
debugger io vectors arrays math.parser math.order
|
||||
vectors combinators classes sets unicode.categories
|
||||
compiler.units parser words quotations effects memoize accessors
|
||||
locals effects splitting combinators.short-circuit
|
||||
combinators.short-circuit.smart generalizations ;
|
||||
locals effects splitting combinators.short-circuit generalizations ;
|
||||
IN: peg
|
||||
|
||||
USE: prettyprint
|
||||
|
|
@ -278,7 +277,8 @@ GENERIC: (compile) ( peg -- quot )
|
|||
: parser-body ( parser -- quot )
|
||||
#! Return the body of the word that is the compiled version
|
||||
#! of the parser.
|
||||
gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
|
||||
gensym 2dup swap peg>> (compile) (( -- result )) define-declared
|
||||
swap dupd id>> "peg-id" set-word-prop
|
||||
[ execute-parser ] curry ;
|
||||
|
||||
: preset-parser-word ( parser -- parser word )
|
||||
|
|
@ -306,7 +306,7 @@ SYMBOL: delayed
|
|||
#! Work through all delayed parsers and recompile their
|
||||
#! words to have the correct bodies.
|
||||
delayed get [
|
||||
call compile-parser 1quotation 0 1 <effect> define-declared
|
||||
call compile-parser 1quotation (( -- result )) define-declared
|
||||
] assoc-each ;
|
||||
|
||||
: compile ( parser -- word )
|
||||
|
|
@ -421,7 +421,7 @@ M: seq-parser (compile) ( peg -- quot )
|
|||
[
|
||||
parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
|
||||
[ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each
|
||||
] { } make , \ && ,
|
||||
] { } make , \ 1&& ,
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: choice-parser parsers ;
|
||||
|
|
@ -431,7 +431,7 @@ M: choice-parser (compile) ( peg -- quot )
|
|||
[
|
||||
parsers>> [ compile-parser ] map
|
||||
unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
|
||||
] { } make , \ || ,
|
||||
] { } make , \ 0|| ,
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: repeat0-parser p1 ;
|
||||
|
|
|
|||
|
|
@ -307,7 +307,7 @@ M: object infer-call*
|
|||
\ <complex> { real real } { complex } define-primitive
|
||||
\ <complex> make-foldable
|
||||
|
||||
\ both-fixnums? { object object } { object object object } define-primitive
|
||||
\ both-fixnums? { object object } { object } define-primitive
|
||||
|
||||
\ fixnum+ { fixnum fixnum } { integer } define-primitive
|
||||
\ fixnum+ make-foldable
|
||||
|
|
|
|||
|
|
@ -4,9 +4,17 @@ IN: tools.annotations
|
|||
|
||||
ARTICLE: "tools.annotations" "Word annotations"
|
||||
"The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question."
|
||||
$nl
|
||||
"Printing messages when a word is called or returns:"
|
||||
{ $subsection watch }
|
||||
{ $subsection watch-vars }
|
||||
"Starting the walker when a word is called:"
|
||||
{ $subsection breakpoint }
|
||||
{ $subsection breakpoint-if }
|
||||
"Timing words:"
|
||||
{ $subsection reset-word-timing }
|
||||
{ $subsection add-timing }
|
||||
{ $subsection word-timing. }
|
||||
"All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:"
|
||||
{ $subsection annotate } ;
|
||||
|
||||
|
|
@ -63,3 +71,13 @@ HELP: word-inputs
|
|||
{ "seq" sequence } }
|
||||
{ $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ;
|
||||
|
||||
HELP: add-timing
|
||||
{ $values { "word" word } }
|
||||
{ $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." }
|
||||
{ $see-also "timing" "profiling" } ;
|
||||
|
||||
HELP: reset-word-timing
|
||||
{ $description "Resets the word timing table." } ;
|
||||
|
||||
HELP: word-timing.
|
||||
{ $description "Prints the word timing table." } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.test tools.annotations math parser eval
|
||||
USING: tools.test tools.annotations tools.time math parser eval
|
||||
io.streams.string kernel ;
|
||||
IN: tools.annotations.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel words parser io summary quotations
|
||||
sequences prettyprint continuations effects definitions
|
||||
compiler.units namespaces assocs tools.walker generic
|
||||
inspector fry ;
|
||||
USING: accessors kernel math sorting words parser io summary
|
||||
quotations sequences prettyprint continuations effects
|
||||
definitions compiler.units namespaces assocs tools.walker
|
||||
tools.time generic inspector fry ;
|
||||
IN: tools.annotations
|
||||
|
||||
GENERIC: reset ( word -- )
|
||||
|
|
@ -20,9 +20,11 @@ M: word reset
|
|||
f "unannotated-def" set-word-prop
|
||||
] [ drop ] if ;
|
||||
|
||||
ERROR: cannot-annotate-twice word ;
|
||||
|
||||
: annotate ( word quot -- )
|
||||
over "unannotated-def" word-prop [
|
||||
"Cannot annotate a word twice" throw
|
||||
over cannot-annotate-twice
|
||||
] when
|
||||
[
|
||||
over dup def>> "unannotated-def" set-word-prop
|
||||
|
|
@ -82,3 +84,21 @@ M: word annotate-methods
|
|||
|
||||
: breakpoint-if ( word quot -- )
|
||||
'[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ;
|
||||
|
||||
SYMBOL: word-timing
|
||||
|
||||
word-timing global [ H{ } clone or ] change-at
|
||||
|
||||
: reset-word-timing ( -- )
|
||||
word-timing get clear-assoc ;
|
||||
|
||||
: (add-timing) ( def word -- def' )
|
||||
'[ _ benchmark _ word-timing get at+ ] ;
|
||||
|
||||
: add-timing ( word -- )
|
||||
dup '[ _ (add-timing) ] annotate ;
|
||||
|
||||
: word-timing. ( -- )
|
||||
word-timing get
|
||||
>alist [ 1000000 /f ] assoc-map sort-values
|
||||
simple-table. ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,25 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays strings sequences sequences.private
|
||||
fry kernel words parser lexer assocs math.order ;
|
||||
fry kernel words parser lexer assocs math math.order summary ;
|
||||
IN: tr
|
||||
|
||||
ERROR: bad-tr ;
|
||||
|
||||
M: bad-tr summary
|
||||
drop "TR: can only be used with ASCII characters" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ascii? ( ch -- ? ) 0 127 between? ; inline
|
||||
|
||||
: tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline
|
||||
|
||||
: check-tr ( from to -- )
|
||||
[ [ ascii? ] all? ] both? [ bad-tr ] unless ;
|
||||
|
||||
: compute-tr ( quot from to -- mapping )
|
||||
zip [ 256 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline
|
||||
zip [ 128 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline
|
||||
|
||||
: tr-hints ( word -- )
|
||||
{ { byte-array } { string } } "specializer" set-word-prop ;
|
||||
|
|
@ -16,13 +28,13 @@ IN: tr
|
|||
create-in dup tr-hints ;
|
||||
|
||||
: tr-quot ( mapping -- quot )
|
||||
'[ [ dup 0 255 between? [ _ nth-unsafe ] when ] map ] ;
|
||||
'[ [ dup ascii? [ _ tr-nth ] when ] map ] ;
|
||||
|
||||
: define-tr ( word mapping -- )
|
||||
tr-quot (( seq -- translated )) define-declared ;
|
||||
|
||||
: fast-tr-quot ( mapping -- quot )
|
||||
'[ [ _ nth-unsafe ] change-each ] ;
|
||||
'[ [ _ tr-nth ] change-each ] ;
|
||||
|
||||
: define-fast-tr ( word mapping -- )
|
||||
fast-tr-quot (( seq -- )) define-declared ;
|
||||
|
|
@ -32,6 +44,7 @@ PRIVATE>
|
|||
: TR:
|
||||
scan parse-definition
|
||||
unclip-last [ unclip-last ] dip compute-tr
|
||||
[ check-tr ]
|
||||
[ [ create-tr ] dip define-tr ]
|
||||
[ [ "-fast" append create-tr ] dip define-fast-tr ] 2bi ;
|
||||
[ [ "-fast" append create-tr ] dip define-fast-tr ] 2tri ;
|
||||
parsing
|
||||
|
|
|
|||
|
|
@ -109,9 +109,6 @@ bootstrapping? on
|
|||
} [ create-vocab drop ] each
|
||||
|
||||
! Builtin classes
|
||||
: define-builtin-predicate ( class -- )
|
||||
dup class>type [ builtin-instance? ] curry define-predicate ;
|
||||
|
||||
: lookup-type-number ( word -- n )
|
||||
global [ target-word ] bind type-number ;
|
||||
|
||||
|
|
@ -192,6 +189,10 @@ define-union-class
|
|||
] [ ] make
|
||||
define-predicate-class
|
||||
|
||||
"array-capacity" "sequences.private" lookup
|
||||
[ >fixnum ] bootstrap-max-array-capacity [ fixnum-bitand ] curry append
|
||||
"coercer" set-word-prop
|
||||
|
||||
! Catch-all class for providing a default method.
|
||||
"object" "kernel" create
|
||||
[ f f { } intersection-class define-class ]
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors classes classes.algebra words kernel
|
||||
kernel.private namespaces sequences math math.private
|
||||
combinators assocs ;
|
||||
combinators assocs quotations ;
|
||||
IN: classes.builtin
|
||||
|
||||
SYMBOL: builtins
|
||||
|
|
@ -10,10 +10,14 @@ SYMBOL: builtins
|
|||
PREDICATE: builtin-class < class
|
||||
"metaclass" word-prop builtin-class eq? ;
|
||||
|
||||
: type>class ( n -- class ) builtins get-global nth ;
|
||||
|
||||
: class>type ( class -- n ) "type" word-prop ; foldable
|
||||
|
||||
PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
|
||||
|
||||
PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
|
||||
|
||||
: type>class ( n -- class ) builtins get-global nth ;
|
||||
|
||||
: bootstrap-type>class ( n -- class ) builtins get nth ;
|
||||
|
||||
M: hi-tag class hi-tag type>class ;
|
||||
|
|
@ -22,16 +26,20 @@ M: object class tag type>class ;
|
|||
|
||||
M: builtin-class rank-class drop 0 ;
|
||||
|
||||
: builtin-instance? ( object n -- ? )
|
||||
#! 7 == tag-mask get
|
||||
#! 3 == hi-tag tag-number
|
||||
dup 7 fixnum<= [ swap tag eq? ] [
|
||||
swap dup tag 3 eq?
|
||||
[ hi-tag eq? ] [ 2drop f ] if
|
||||
] if ; inline
|
||||
GENERIC: define-builtin-predicate ( class -- )
|
||||
|
||||
M: builtin-class instance?
|
||||
class>type builtin-instance? ;
|
||||
M: lo-tag-class define-builtin-predicate
|
||||
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
|
||||
|
||||
M: hi-tag-class define-builtin-predicate
|
||||
dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
|
||||
[ dup tag 3 eq? ] [ [ drop f ] if ] surround
|
||||
define-predicate ;
|
||||
|
||||
M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
|
||||
|
||||
M: hi-tag-class instance?
|
||||
over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
|
||||
|
||||
M: builtin-class (flatten-class) dup set ;
|
||||
|
||||
|
|
|
|||
|
|
@ -90,10 +90,10 @@ ERROR: bad-superclass class ;
|
|||
2drop f
|
||||
] if ; inline
|
||||
|
||||
: tuple-instance-1? ( object class -- ? )
|
||||
swap dup tuple? [
|
||||
layout-of 7 slot eq?
|
||||
] [ 2drop f ] if ; inline
|
||||
: tuple-predicate-quot/1 ( class -- quot )
|
||||
#! Fast path for tuples with no superclass
|
||||
[ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
|
||||
[ dup tuple? ] [ [ drop f ] if ] surround ;
|
||||
|
||||
: tuple-instance? ( object class offset -- ? )
|
||||
rot dup tuple? [
|
||||
|
|
@ -105,13 +105,16 @@ ERROR: bad-superclass class ;
|
|||
: layout-class-offset ( echelon -- n )
|
||||
2 * 5 + ;
|
||||
|
||||
: tuple-predicate-quot ( class echelon -- quot )
|
||||
layout-class-offset [ tuple-instance? ] 2curry ;
|
||||
|
||||
: echelon-of ( class -- n )
|
||||
tuple-layout third ;
|
||||
|
||||
: define-tuple-predicate ( class -- )
|
||||
dup dup echelon-of {
|
||||
{ 1 [ [ tuple-instance-1? ] curry ] }
|
||||
[ layout-class-offset [ tuple-instance? ] 2curry ]
|
||||
{ 1 [ tuple-predicate-quot/1 ] }
|
||||
[ tuple-predicate-quot ]
|
||||
} case define-predicate ;
|
||||
|
||||
: class-size ( class -- n )
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ M: math-combination perform-combination
|
|||
drop
|
||||
dup
|
||||
[
|
||||
\ both-fixnums? ,
|
||||
[ 2dup both-fixnums? ] %
|
||||
dup fixnum bootstrap-word dup math-method ,
|
||||
\ over [
|
||||
dup math-class? [
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: classes.private generic.standard.engines namespaces make
|
||||
arrays assocs sequences.private quotations kernel.private
|
||||
math slots.private math.private kernel accessors words
|
||||
layouts sorting sequences ;
|
||||
layouts sorting sequences combinators ;
|
||||
IN: generic.standard.engines.tag
|
||||
|
||||
TUPLE: lo-tag-dispatch-engine methods ;
|
||||
|
|
@ -24,15 +24,21 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
|
|||
|
||||
: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
|
||||
|
||||
: tag-dispatch-test ( tag# -- quot )
|
||||
picker [ tag ] append swap [ eq? ] curry append ;
|
||||
|
||||
: tag-dispatch-quot ( alist -- quot )
|
||||
[ default get ] dip
|
||||
[ [ tag-dispatch-test ] dip ] assoc-map
|
||||
alist>quot ;
|
||||
|
||||
M: lo-tag-dispatch-engine engine>quot
|
||||
methods>> engines>quots*
|
||||
[ [ lo-tag-number ] dip ] assoc-map
|
||||
[
|
||||
picker % [ tag ] % [
|
||||
sort-tags linear-dispatch-quot
|
||||
] [
|
||||
num-tags get direct-dispatch-quot
|
||||
] if-small? %
|
||||
[ sort-tags tag-dispatch-quot ]
|
||||
[ picker % [ tag ] % num-tags get direct-dispatch-quot ]
|
||||
if-small? %
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: hi-tag-dispatch-engine methods ;
|
||||
|
|
|
|||
|
|
@ -133,7 +133,7 @@ M: hashtable set-at ( value key hash -- )
|
|||
: push-unsafe ( elt seq -- )
|
||||
[ length ] keep
|
||||
[ underlying>> set-array-nth ]
|
||||
[ [ 1+ ] dip (>>length) ]
|
||||
[ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ]
|
||||
2bi ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -154,8 +154,11 @@ TUPLE: identity-tuple ;
|
|||
|
||||
M: identity-tuple equal? 2drop f ;
|
||||
|
||||
USE: math.private
|
||||
: = ( obj1 obj2 -- ? )
|
||||
2dup eq? [ 2drop t ] [ equal? ] if ; inline
|
||||
2dup eq? [ 2drop t ] [
|
||||
2dup both-fixnums? [ 2drop f ] [ equal? ] if
|
||||
] if ; inline
|
||||
|
||||
GENERIC: clone ( obj -- cloned )
|
||||
|
||||
|
|
|
|||
|
|
@ -835,12 +835,35 @@ PRIVATE>
|
|||
|
||||
: supremum ( seq -- n ) dup first [ max ] reduce ;
|
||||
|
||||
: flip ( matrix -- newmatrix )
|
||||
dup empty? [
|
||||
dup [ length ] map infimum
|
||||
swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
|
||||
] unless ;
|
||||
|
||||
: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
|
||||
|
||||
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
|
||||
|
||||
! We hand-optimize flip to such a degree because type hints
|
||||
! cannot express that an array is an array of arrays yet, and
|
||||
! this word happens to be performance-critical since the compiler
|
||||
! itself uses it. Optimizing it like this reduced compile time.
|
||||
<PRIVATE
|
||||
|
||||
: generic-flip ( matrix -- newmatrix )
|
||||
[ dup first length [ length min ] reduce ] keep
|
||||
[ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
|
||||
|
||||
USE: arrays
|
||||
|
||||
: array-length ( array -- len )
|
||||
{ array } declare length>> ;
|
||||
|
||||
: array-flip ( matrix -- newmatrix )
|
||||
[ dup first array-length [ array-length min ] reduce ] keep
|
||||
[ [ array-nth ] with { } map-as ] curry { } map-as ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: flip ( matrix -- newmatrix )
|
||||
dup empty? [
|
||||
dup array? [
|
||||
dup [ array? ] all?
|
||||
[ array-flip ] [ generic-flip ] if
|
||||
] [ generic-flip ] if
|
||||
] unless ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
Jose Antonio Ortega Ruiz
|
||||
Eduardo Cavazos
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2008 Your name.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test fuel ;
|
||||
IN: fuel.tests
|
||||
|
|
@ -0,0 +1,121 @@
|
|||
! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays classes.tuple compiler.units continuations debugger
|
||||
definitions eval io io.files io.streams.string kernel listener listener.private
|
||||
make math namespaces parser prettyprint quotations sequences strings
|
||||
vectors vocabs.loader ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
! <PRIVATE
|
||||
|
||||
TUPLE: fuel-status in use ds? ;
|
||||
|
||||
SYMBOL: fuel-status-stack
|
||||
V{ } clone fuel-status-stack set-global
|
||||
|
||||
: push-fuel-status ( -- )
|
||||
in get use get clone display-stacks? get
|
||||
fuel-status boa
|
||||
fuel-status-stack get push ;
|
||||
|
||||
: pop-fuel-status ( -- )
|
||||
fuel-status-stack get empty? [
|
||||
fuel-status-stack get pop
|
||||
[ in>> in set ]
|
||||
[ use>> clone use set ]
|
||||
[ ds?>> display-stacks? swap [ on ] [ off ] if ] tri
|
||||
] unless ;
|
||||
|
||||
SYMBOL: fuel-eval-result
|
||||
f clone fuel-eval-result set-global
|
||||
|
||||
SYMBOL: fuel-eval-output
|
||||
f clone fuel-eval-result set-global
|
||||
|
||||
! PRIVATE>
|
||||
|
||||
GENERIC: fuel-pprint ( obj -- )
|
||||
|
||||
M: object fuel-pprint pprint ;
|
||||
|
||||
M: f fuel-pprint drop "nil" write ;
|
||||
|
||||
M: integer fuel-pprint pprint ;
|
||||
|
||||
M: string fuel-pprint pprint ;
|
||||
|
||||
M: sequence fuel-pprint
|
||||
dup empty? [ drop f fuel-pprint ] [
|
||||
"(" write
|
||||
[ " " write ] [ fuel-pprint ] interleave
|
||||
")" write
|
||||
] if ;
|
||||
|
||||
M: tuple fuel-pprint tuple>array fuel-pprint ;
|
||||
|
||||
M: continuation fuel-pprint drop "~continuation~" write ;
|
||||
|
||||
: fuel-eval-set-result ( obj -- )
|
||||
clone fuel-eval-result set-global ;
|
||||
|
||||
: fuel-retort ( -- )
|
||||
error get
|
||||
fuel-eval-result get-global
|
||||
fuel-eval-output get-global
|
||||
3array fuel-pprint ;
|
||||
|
||||
: fuel-forget-error ( -- )
|
||||
f error set-global ;
|
||||
|
||||
: (fuel-begin-eval) ( -- )
|
||||
push-fuel-status
|
||||
display-stacks? off
|
||||
fuel-forget-error
|
||||
f fuel-eval-result set-global
|
||||
f fuel-eval-output set-global ;
|
||||
|
||||
: (fuel-end-eval) ( quot -- )
|
||||
with-string-writer fuel-eval-output set-global
|
||||
fuel-retort
|
||||
pop-fuel-status ;
|
||||
|
||||
: (fuel-eval) ( lines -- )
|
||||
[ [ parse-lines ] with-compilation-unit call ] curry [ drop ] recover ;
|
||||
|
||||
: (fuel-eval-each) ( lines -- )
|
||||
[ 1vector (fuel-eval) ] each ;
|
||||
|
||||
: (fuel-eval-usings) ( usings -- )
|
||||
[ "USING: " prepend " ;" append ] map
|
||||
(fuel-eval-each) fuel-forget-error ;
|
||||
|
||||
: (fuel-eval-in) ( in -- )
|
||||
[ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ;
|
||||
|
||||
: fuel-eval-in-context ( lines in usings -- )
|
||||
(fuel-begin-eval) [
|
||||
(fuel-eval-usings)
|
||||
(fuel-eval-in)
|
||||
(fuel-eval)
|
||||
] (fuel-end-eval) ;
|
||||
|
||||
: fuel-begin-eval ( in -- )
|
||||
(fuel-begin-eval)
|
||||
(fuel-eval-in)
|
||||
fuel-retort ;
|
||||
|
||||
: fuel-eval ( lines -- )
|
||||
(fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ;
|
||||
|
||||
: fuel-end-eval ( -- )
|
||||
[ ] (fuel-end-eval) ;
|
||||
|
||||
: fuel-get-edit-location ( defspec -- )
|
||||
where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ;
|
||||
|
||||
: fuel-startup ( -- )
|
||||
"listener" run ;
|
||||
|
||||
MAIN: fuel-startup
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
FUEL, Factor's Ultimate Emacs Library
|
||||
-------------------------------------
|
||||
|
||||
FUEL provides a complete environment for your Factor coding pleasure
|
||||
inside Emacs, including source code edition and interaction with a
|
||||
Factor listener instance running within Emacs.
|
||||
|
||||
FUEL was started by Jose A Ortega as an extension to Ed Cavazos'
|
||||
original factor.el code.
|
||||
|
||||
Installation
|
||||
------------
|
||||
|
||||
FUEL comes bundled with Factor's distribution. The folder misc/fuel
|
||||
contains Elisp code, and there's a fuel vocabulary in extras/fuel.
|
||||
|
||||
To install FUEL, either add this line to your Emacs initialisation:
|
||||
|
||||
(load-file "<path/to/factor/installation>/misc/fuel/fu.el")
|
||||
|
||||
or
|
||||
|
||||
(add-to-list load-path "<path/to/factor/installation>/fuel")
|
||||
(require 'fuel)
|
||||
|
||||
If all you want is a major mode for editing Factor code with pretty
|
||||
font colors and indentation, without running the factor listener
|
||||
inside Emacs, you can use instead:
|
||||
|
||||
(add-to-list load-path "<path/to/factor/installation>/fuel")
|
||||
(setq factor-mode-use-fuel nil)
|
||||
(require 'factor-mode)
|
||||
|
||||
Basic usage
|
||||
-----------
|
||||
|
||||
If you're using the default factor binary and images locations inside
|
||||
the Factor's source tree, that should be enough to start using FUEL.
|
||||
Editing any file with the extension .factor will put you in
|
||||
factor-mode; try C-hm for a summary of available commands.
|
||||
|
||||
To start the listener, try M-x run-factor.
|
||||
|
||||
Many aspects of the environment can be customized:
|
||||
M-x customize-group fuel will show you how many.
|
||||
|
||||
Quick key reference
|
||||
-------------------
|
||||
|
||||
- C-cz : switch to listener
|
||||
- C-co : cycle between code, tests and docs factor files
|
||||
|
||||
- M-. : edit word at point in Emacs
|
||||
|
||||
- C-cr, C-cC-er : eval region
|
||||
- C-M-r, C-cC-ee : eval region, extending it to definition boundaries
|
||||
- C-M-x, C-cC-ex : eval definition around point
|
||||
|
||||
- C-cC-da : toggle autodoc mode
|
||||
- C-cC-dd : help for word at point
|
||||
- C-cC-ds : short help word at point
|
||||
|
||||
Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
|
||||
the same as C-cz).
|
||||
|
|
@ -0,0 +1,239 @@
|
|||
;;; factor-mode.el -- mode for editing Factor source
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Tue Dec 02, 2008 21:32
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; Definition of factor-mode, a major Emacs for editing Factor source
|
||||
;; code.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-base)
|
||||
(require 'fuel-syntax)
|
||||
(require 'fuel-font-lock)
|
||||
|
||||
(require 'ring)
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
(defgroup factor-mode nil
|
||||
"Major mode for Factor source code"
|
||||
:group 'fuel)
|
||||
|
||||
(defcustom factor-mode-use-fuel t
|
||||
"Whether to use the full FUEL facilities in factor mode.
|
||||
|
||||
Set this variable to nil if you just want to use Emacs as the
|
||||
external editor of your Factor environment, e.g., by putting
|
||||
these lines in your .emacs:
|
||||
|
||||
(add-to-list 'load-path \"/path/to/factor/misc/fuel\")
|
||||
(setq factor-mode-use-fuel nil)
|
||||
(require 'factor-mode)
|
||||
"
|
||||
:type 'boolean
|
||||
:group 'factor-mode)
|
||||
|
||||
(defcustom factor-mode-default-indent-width 4
|
||||
"Default indentation width for factor-mode.
|
||||
|
||||
This value will be used for the local variable
|
||||
`factor-mode-indent-width' in new factor buffers. For existing
|
||||
code, we first check if `factor-mode-indent-width' is set
|
||||
explicitly in a local variable section or line (e.g.
|
||||
'! -*- factor-mode-indent-witdth: 2 -*-'). If that's not the case,
|
||||
`factor-mode' tries to infer its correct value from the existing
|
||||
code in the buffer."
|
||||
:type 'integer
|
||||
:group 'fuel)
|
||||
|
||||
(defcustom factor-mode-hook nil
|
||||
"Hook run when entering Factor mode."
|
||||
:type 'hook
|
||||
:group 'factor-mode)
|
||||
|
||||
|
||||
;;; Syntax table:
|
||||
|
||||
(defun factor-mode--syntax-setup ()
|
||||
(set-syntax-table fuel-syntax--syntax-table)
|
||||
(set (make-local-variable 'beginning-of-defun-function)
|
||||
'fuel-syntax--beginning-of-defun)
|
||||
(set (make-local-variable 'end-of-defun-function) 'fuel-syntax--end-of-defun)
|
||||
(set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
|
||||
(fuel-syntax--enable-usings))
|
||||
|
||||
|
||||
;;; Indentation:
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar factor-mode-indent-width factor-mode-default-indent-width
|
||||
"Indentation width in factor buffers. A local variable."))
|
||||
|
||||
(defun factor-mode--guess-indent-width ()
|
||||
"Chooses an indentation value from existing code."
|
||||
(let ((word-cont "^ +[^ ]")
|
||||
(iw))
|
||||
(save-excursion
|
||||
(beginning-of-buffer)
|
||||
(while (not iw)
|
||||
(if (not (re-search-forward fuel-syntax--definition-start-regex nil t))
|
||||
(setq iw factor-mode-default-indent-width)
|
||||
(forward-line)
|
||||
(when (looking-at word-cont)
|
||||
(setq iw (current-indentation))))))
|
||||
iw))
|
||||
|
||||
(defun factor-mode--indent-in-brackets ()
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(when (> (fuel-syntax--brackets-depth) 0)
|
||||
(let ((op (fuel-syntax--brackets-start))
|
||||
(cl (fuel-syntax--brackets-end))
|
||||
(ln (line-number-at-pos)))
|
||||
(when (> ln (line-number-at-pos op))
|
||||
(if (and (> cl 0) (= ln (line-number-at-pos cl)))
|
||||
(fuel-syntax--indentation-at op)
|
||||
(fuel-syntax--increased-indentation (fuel-syntax--indentation-at op))))))))
|
||||
|
||||
(defun factor-mode--indent-definition ()
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(when (fuel-syntax--at-begin-of-def) 0)))
|
||||
|
||||
(defun factor-mode--indent-setter-line ()
|
||||
(when (fuel-syntax--at-setter-line)
|
||||
(save-excursion
|
||||
(let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation))))
|
||||
(while (not (or indent
|
||||
(bobp)
|
||||
(fuel-syntax--at-begin-of-def)
|
||||
(fuel-syntax--at-end-of-def)))
|
||||
(if (fuel-syntax--at-constructor-line)
|
||||
(setq indent (fuel-syntax--increased-indentation))
|
||||
(forward-line -1)))
|
||||
indent))))
|
||||
|
||||
(defun factor-mode--indent-continuation ()
|
||||
(save-excursion
|
||||
(forward-line -1)
|
||||
(while (and (not (bobp))
|
||||
(fuel-syntax--looking-at-emptiness))
|
||||
(forward-line -1))
|
||||
(cond ((or (fuel-syntax--at-end-of-def)
|
||||
(fuel-syntax--at-setter-line))
|
||||
(fuel-syntax--decreased-indentation))
|
||||
((and (fuel-syntax--at-begin-of-def)
|
||||
(not (fuel-syntax--at-using)))
|
||||
(fuel-syntax--increased-indentation))
|
||||
(t (current-indentation)))))
|
||||
|
||||
(defun factor-mode--calculate-indentation ()
|
||||
"Calculate Factor indentation for line at point."
|
||||
(or (and (bobp) 0)
|
||||
(factor-mode--indent-definition)
|
||||
(factor-mode--indent-in-brackets)
|
||||
(factor-mode--indent-setter-line)
|
||||
(factor-mode--indent-continuation)
|
||||
0))
|
||||
|
||||
(defun factor-mode--indent-line ()
|
||||
"Indent current line as Factor code"
|
||||
(let ((target (factor-mode--calculate-indentation))
|
||||
(pos (- (point-max) (point))))
|
||||
(if (= target (current-indentation))
|
||||
(if (< (current-column) (current-indentation))
|
||||
(back-to-indentation))
|
||||
(beginning-of-line)
|
||||
(delete-horizontal-space)
|
||||
(indent-to target)
|
||||
(if (> (- (point-max) pos) (point))
|
||||
(goto-char (- (point-max) pos))))))
|
||||
|
||||
(defun factor-mode--indentation-setup ()
|
||||
(set (make-local-variable 'indent-line-function) 'factor-mode--indent-line)
|
||||
(setq factor-indent-width (factor-mode--guess-indent-width))
|
||||
(setq indent-tabs-mode nil))
|
||||
|
||||
|
||||
;;; Buffer cycling:
|
||||
|
||||
(defconst factor-mode--cycle-endings
|
||||
'(".factor" "-tests.factor" "-docs.factor"))
|
||||
|
||||
(defconst factor-mode--regex-cycle-endings
|
||||
(format "\\(.*?\\)\\(%s\\)$"
|
||||
(regexp-opt factor-mode--cycle-endings)))
|
||||
|
||||
(defconst factor-mode--cycle-endings-ring
|
||||
(let ((ring (make-ring (length factor-mode--cycle-endings))))
|
||||
(dolist (e factor-mode--cycle-endings ring)
|
||||
(ring-insert ring e))))
|
||||
|
||||
(defun factor-mode--cycle-next (file)
|
||||
(let* ((match (string-match factor-mode--regex-cycle-endings file))
|
||||
(base (and match (match-string-no-properties 1 file)))
|
||||
(ending (and match (match-string-no-properties 2 file)))
|
||||
(idx (and ending (ring-member factor-mode--cycle-endings-ring ending)))
|
||||
(gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i)))))
|
||||
(if (not idx) file
|
||||
(let ((l (length factor-mode--cycle-endings)) (i 1) next)
|
||||
(while (and (not next) (< i l))
|
||||
(when (file-exists-p (funcall gfl (+ idx i)))
|
||||
(setq next (+ idx i)))
|
||||
(setq i (1+ i)))
|
||||
(funcall gfl (or next idx))))))
|
||||
|
||||
(defun factor-mode-visit-other-file (&optional file)
|
||||
"Cycle between code, tests and docs factor files."
|
||||
(interactive)
|
||||
(find-file (factor-mode--cycle-next (or file (buffer-file-name)))))
|
||||
|
||||
|
||||
;;; Keymap:
|
||||
|
||||
(defun factor-mode-insert-and-indent (n)
|
||||
(interactive "p")
|
||||
(self-insert-command n)
|
||||
(indent-for-tab-command))
|
||||
|
||||
(defvar factor-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [?\]] 'factor-mode-insert-and-indent)
|
||||
(define-key map [?}] 'factor-mode-insert-and-indent)
|
||||
(define-key map "\C-m" 'newline-and-indent)
|
||||
(define-key map "\C-co" 'factor-mode-visit-other-file)
|
||||
(define-key map "\C-c\C-o" 'factor-mode-visit-other-file)
|
||||
map))
|
||||
|
||||
(defun factor-mode--keymap-setup ()
|
||||
(use-local-map factor-mode-map))
|
||||
|
||||
|
||||
;;; Factor mode:
|
||||
|
||||
;;;###autoload
|
||||
(defun factor-mode ()
|
||||
"A mode for editing programs written in the Factor programming language.
|
||||
\\{factor-mode-map}"
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(setq major-mode 'factor-mode)
|
||||
(setq mode-name "Factor")
|
||||
(fuel-font-lock--font-lock-setup)
|
||||
(factor-mode--keymap-setup)
|
||||
(factor-mode--indentation-setup)
|
||||
(factor-mode--syntax-setup)
|
||||
(when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode))
|
||||
(run-hooks 'factor-mode-hook))
|
||||
|
||||
|
||||
(provide 'factor-mode)
|
||||
;;; factor-mode.el ends here
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
;;; fu.el --- Startup file for FUEL
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages
|
||||
|
||||
;;; Code:
|
||||
|
||||
(add-to-list 'load-path (file-name-directory load-file-name))
|
||||
|
||||
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
|
||||
(autoload 'factor-mode "factor-mode.el"
|
||||
"Major mode for editing Factor source." t)
|
||||
|
||||
(autoload 'run-factor "fuel-listener.el"
|
||||
"Start a Factor listener, or switch to a running one." t)
|
||||
|
||||
(autoload 'fuel-autodoc-mode "fuel-help.el"
|
||||
"Minor mode showing in the minibuffer a synopsis of Factor word at point."
|
||||
t)
|
||||
|
||||
|
||||
|
||||
;;; fu.el ends here
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
;;; fuel-base.el --- Basic FUEL support code
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Basic definitions likely to be used by all FUEL modules.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defconst fuel-version "1.0")
|
||||
|
||||
;;;###autoload
|
||||
(defsubst fuel-version ()
|
||||
"Echoes FUEL's version."
|
||||
(interactive)
|
||||
(message "FUEL %s" fuel-version))
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
;;;###autoload
|
||||
(defgroup fuel nil
|
||||
"Factor's Ultimate Emacs Library"
|
||||
:group 'language)
|
||||
|
||||
|
||||
;;; Emacs compatibility:
|
||||
|
||||
(eval-after-load "ring"
|
||||
'(when (not (fboundp 'ring-member))
|
||||
(defun ring-member (ring item)
|
||||
(catch 'found
|
||||
(dotimes (ind (ring-length ring) nil)
|
||||
(when (equal item (ring-ref ring ind))
|
||||
(throw 'found ind)))))))
|
||||
|
||||
|
||||
;;; Utilities
|
||||
|
||||
(defun fuel--shorten-str (str len)
|
||||
(let ((sl (length str)))
|
||||
(if (<= sl len) str
|
||||
(let* ((sep " ... ")
|
||||
(sepl (length sep))
|
||||
(segl (/ (- len sepl) 2)))
|
||||
(format "%s%s%s"
|
||||
(substring str 0 segl)
|
||||
sep
|
||||
(substring str (- sl segl)))))))
|
||||
|
||||
(defun fuel--shorten-region (begin end len)
|
||||
(fuel--shorten-str (mapconcat 'identity
|
||||
(split-string (buffer-substring begin end) nil t)
|
||||
" ")
|
||||
len))
|
||||
|
||||
(provide 'fuel-base)
|
||||
;;; fuel-base.el ends here
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
;;; fuel-eval.el --- utilities for communication with fuel-listener
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages
|
||||
;; Start date: Tue Dec 02, 2008
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Protocols for handling communications via a comint buffer running a
|
||||
;; factor listener.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-base)
|
||||
(require 'fuel-syntax)
|
||||
|
||||
|
||||
;;; Syncronous string sending:
|
||||
|
||||
(defvar fuel-eval-log-max-length 16000)
|
||||
|
||||
(defvar fuel-eval--default-proc-function nil)
|
||||
(defsubst fuel-eval--default-proc ()
|
||||
(and fuel-eval--default-proc-function
|
||||
(funcall fuel-eval--default-proc-function)))
|
||||
|
||||
(defvar fuel-eval--proc nil)
|
||||
(defvar fuel-eval--log t)
|
||||
|
||||
(defun fuel-eval--send-string (str)
|
||||
(let ((proc (or fuel-eval--proc (fuel-eval--default-proc))))
|
||||
(when proc
|
||||
(with-current-buffer (get-buffer-create "*factor messages*")
|
||||
(goto-char (point-max))
|
||||
(when (and (> fuel-eval-log-max-length 0)
|
||||
(> (point) fuel-eval-log-max-length))
|
||||
(erase-buffer))
|
||||
(when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256) "\n"))
|
||||
(let ((beg (point)))
|
||||
(comint-redirect-send-command-to-process str (current-buffer) proc nil t)
|
||||
(with-current-buffer (process-buffer proc)
|
||||
(while (not comint-redirect-completed) (sleep-for 0 1)))
|
||||
(goto-char beg)
|
||||
(current-buffer))))))
|
||||
|
||||
|
||||
;;; Evaluation protocol
|
||||
|
||||
(defsubst fuel-eval--retort-make (err result &optional output)
|
||||
(list err result output))
|
||||
|
||||
(defsubst fuel-eval--retort-error (ret) (nth 0 ret))
|
||||
(defsubst fuel-eval--retort-result (ret) (nth 1 ret))
|
||||
(defsubst fuel-eval--retort-output (ret) (nth 2 ret))
|
||||
|
||||
(defsubst fuel-eval--retort-p (ret) (listp ret))
|
||||
|
||||
(defsubst fuel-eval--error-name (err) (car err))
|
||||
|
||||
(defsubst fuel-eval--make-parse-error-retort (str)
|
||||
(fuel-eval--retort-make 'parse-retort-error nil str))
|
||||
|
||||
(defun fuel-eval--parse-retort (buffer)
|
||||
(save-current-buffer
|
||||
(set-buffer buffer)
|
||||
(condition-case nil
|
||||
(read (current-buffer))
|
||||
(error (fuel-eval--make-parse-error-retort
|
||||
(buffer-substring-no-properties (point) (point-max)))))))
|
||||
|
||||
(defsubst fuel-eval--send/retort (str)
|
||||
(fuel-eval--parse-retort (fuel-eval--send-string str)))
|
||||
|
||||
(defsubst fuel-eval--eval-begin ()
|
||||
(fuel-eval--send/retort "fuel-begin-eval"))
|
||||
|
||||
(defsubst fuel-eval--eval-end ()
|
||||
(fuel-eval--send/retort "fuel-begin-eval"))
|
||||
|
||||
(defsubst fuel-eval--factor-array (strs)
|
||||
(format "V{ %S }" (mapconcat 'identity strs " ")))
|
||||
|
||||
(defsubst fuel-eval--eval-strings (strs)
|
||||
(let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs))))
|
||||
(fuel-eval--send/retort str)))
|
||||
|
||||
(defsubst fuel-eval--eval-string (str)
|
||||
(fuel-eval--eval-strings (list str)))
|
||||
|
||||
(defun fuel-eval--eval-strings/context (strs)
|
||||
(let ((usings (fuel-syntax--usings-update)))
|
||||
(fuel-eval--send/retort
|
||||
(format "%s %S %s fuel-eval-in-context"
|
||||
(fuel-eval--factor-array strs)
|
||||
(or fuel-syntax--current-vocab "f")
|
||||
(if usings (fuel-eval--factor-array usings) "f")))))
|
||||
|
||||
(defsubst fuel-eval--eval-string/context (str)
|
||||
(fuel-eval--eval-strings/context (list str)))
|
||||
|
||||
(defun fuel-eval--eval-region/context (begin end)
|
||||
(let ((lines (split-string (buffer-substring-no-properties begin end)
|
||||
"[\f\n\r\v]+" t)))
|
||||
(when (> (length lines) 0)
|
||||
(fuel-eval--eval-strings/context lines))))
|
||||
|
||||
|
||||
(provide 'fuel-eval)
|
||||
;;; fuel-eval.el ends here
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
;;; fuel-font-lock.el -- font lock for factor code
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Wed Dec 03, 2008 21:40
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; Font lock setup for highlighting Factor code.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-base)
|
||||
(require 'fuel-syntax)
|
||||
|
||||
(require 'font-lock)
|
||||
|
||||
|
||||
;;; Faces:
|
||||
|
||||
(defmacro fuel-font-lock--face (face def doc)
|
||||
(let ((face (intern (format "factor-font-lock-%s" (symbol-name face))))
|
||||
(def (intern (format "font-lock-%s-face" (symbol-name def)))))
|
||||
`(defface ,face (face-default-spec ,def)
|
||||
,(format "Face for %s." doc)
|
||||
:group 'factor-mode
|
||||
:group 'faces)))
|
||||
|
||||
(defmacro fuel-font-lock--faces-setup ()
|
||||
(cons 'progn
|
||||
(mapcar (lambda (f) (cons 'fuel-font-lock--face f))
|
||||
'((comment comment "comments")
|
||||
(constructor type "constructors (<foo>)")
|
||||
(declaration keyword "declaration words")
|
||||
(parsing-word keyword "parsing words")
|
||||
(setter-word function-name "setter words (>>foo)")
|
||||
(stack-effect comment "stack effect specifications")
|
||||
(string string "strings")
|
||||
(symbol variable-name "name of symbol being defined")
|
||||
(type-name type "type names")
|
||||
(vocabulary-name constant "vocabulary names")
|
||||
(word function-name "word, generic or method being defined")))))
|
||||
|
||||
(fuel-font-lock--faces-setup)
|
||||
|
||||
|
||||
;;; Font lock:
|
||||
|
||||
(defconst fuel-font-lock--parsing-lock-keywords
|
||||
(cons '("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
|
||||
(mapcar (lambda (w) `(,(format "\\(^\\| \\)\\(%s\\)\\($\\| \\)" w)
|
||||
2 'factor-font-lock-parsing-word))
|
||||
fuel-syntax--parsing-words)))
|
||||
|
||||
(defconst fuel-font-lock--font-lock-keywords
|
||||
`(,@fuel-font-lock--parsing-lock-keywords
|
||||
(,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
|
||||
(,fuel-syntax--parsing-words-ext-regex . 'factor-font-lock-parsing-word)
|
||||
(,fuel-syntax--declaration-words-regex 1 'factor-font-lock-declaration)
|
||||
(,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
|
||||
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
|
||||
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
|
||||
(2 'factor-font-lock-word))
|
||||
(,fuel-syntax--parent-type-regex 1 'factor-font-lock-type)
|
||||
(,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
|
||||
(,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
|
||||
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
|
||||
(,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name))
|
||||
"Font lock keywords definition for Factor mode.")
|
||||
|
||||
(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
|
||||
(set (make-local-variable 'comment-start) "! ")
|
||||
(set (make-local-variable 'parse-sexp-lookup-properties) t)
|
||||
(set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
|
||||
(set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
|
||||
(set (make-local-variable 'font-lock-defaults)
|
||||
`(,(or keywords 'fuel-font-lock--font-lock-keywords)
|
||||
nil nil nil nil
|
||||
,@(if no-syntax nil
|
||||
(list (cons 'font-lock-syntactic-keywords
|
||||
fuel-syntax--syntactic-keywords))))))
|
||||
|
||||
|
||||
(provide 'fuel-font-lock)
|
||||
;;; fuel-font-lock.el ends here
|
||||
|
|
@ -0,0 +1,208 @@
|
|||
;;; fuel-help.el -- accessing Factor's help system
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Wed Dec 03, 2008 21:41
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; Modes and functions interfacing Factor's 'see' and 'help'
|
||||
;; utilities, as well as an ElDoc-based autodoc mode.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-base)
|
||||
(require 'fuel-font-lock)
|
||||
(require 'fuel-eval)
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
(defgroup fuel-help nil
|
||||
"Options controlling FUEL's help system"
|
||||
:group 'fuel)
|
||||
|
||||
(defcustom fuel-help-minibuffer-font-lock t
|
||||
"Whether to use font lock for info messages in the minibuffer."
|
||||
:group 'fuel-help
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom fuel-help-always-ask t
|
||||
"When enabled, always ask for confirmation in help prompts."
|
||||
:type 'boolean
|
||||
:group 'fuel-help)
|
||||
|
||||
(defcustom fuel-help-use-minibuffer t
|
||||
"When enabled, use the minibuffer for short help messages."
|
||||
:type 'boolean
|
||||
:group 'fuel-help)
|
||||
|
||||
(defcustom fuel-help-mode-hook nil
|
||||
"Hook run by `factor-help-mode'."
|
||||
:type 'hook
|
||||
:group 'fuel-help)
|
||||
|
||||
(defface fuel-help-font-lock-headlines '((t (:bold t :weight bold)))
|
||||
"Face for headlines in help buffers."
|
||||
:group 'fuel-help
|
||||
:group 'faces)
|
||||
|
||||
|
||||
;;; Autodoc mode:
|
||||
|
||||
(defvar fuel-help--font-lock-buffer
|
||||
(let ((buffer (get-buffer-create " *fuel help minibuffer messages*")))
|
||||
(set-buffer buffer)
|
||||
(fuel-font-lock--font-lock-setup)
|
||||
buffer))
|
||||
|
||||
(defun fuel-help--font-lock-str (str)
|
||||
(set-buffer fuel-help--font-lock-buffer)
|
||||
(erase-buffer)
|
||||
(insert str)
|
||||
(let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
|
||||
(buffer-string))
|
||||
|
||||
(defun fuel-help--word-synopsis (&optional word)
|
||||
(let ((word (or word (fuel-syntax-symbol-at-point)))
|
||||
(fuel-eval--log nil))
|
||||
(when word
|
||||
(let ((ret (fuel-eval--eval-string/context
|
||||
(format "\\ %s synopsis fuel-eval-set-result" word))))
|
||||
(when (not (fuel-eval--retort-error ret))
|
||||
(if fuel-help-minibuffer-font-lock
|
||||
(fuel-help--font-lock-str (fuel-eval--retort-result ret))
|
||||
(fuel-eval--retort-result ret)))))))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-autodoc-mode-string " A"
|
||||
"Modeline indicator for fuel-autodoc-mode"))
|
||||
|
||||
(define-minor-mode fuel-autodoc-mode
|
||||
"Toggle Fuel's Autodoc mode.
|
||||
With no argument, this command toggles the mode.
|
||||
Non-null prefix argument turns on the mode.
|
||||
Null prefix argument turns off the mode.
|
||||
|
||||
When Autodoc mode is enabled, a synopsis of the word at point is
|
||||
displayed in the minibuffer."
|
||||
:init-value nil
|
||||
:lighter fuel-autodoc-mode-string
|
||||
:group 'fuel
|
||||
|
||||
(set (make-local-variable 'eldoc-documentation-function)
|
||||
(when fuel-autodoc-mode 'fuel-help--word-synopsis))
|
||||
(set (make-local-variable 'eldoc-minor-mode-string) nil)
|
||||
(eldoc-mode fuel-autodoc-mode)
|
||||
(message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled")))
|
||||
|
||||
|
||||
;;;; Factor help mode:
|
||||
|
||||
(defvar fuel-help-mode-map (make-sparse-keymap)
|
||||
"Keymap for Factor help mode.")
|
||||
|
||||
(define-key fuel-help-mode-map [(return)] 'fuel-help)
|
||||
|
||||
(defconst fuel-help--headlines
|
||||
(regexp-opt '("Class description"
|
||||
"Definition"
|
||||
"Examples"
|
||||
"Generic word contract"
|
||||
"Inputs and outputs"
|
||||
"Methods"
|
||||
"Notes"
|
||||
"Parent topics:"
|
||||
"See also"
|
||||
"Syntax"
|
||||
"Vocabulary"
|
||||
"Warning"
|
||||
"Word description")
|
||||
t))
|
||||
|
||||
(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
|
||||
|
||||
(defconst fuel-help--font-lock-keywords
|
||||
`(,@fuel-font-lock--font-lock-keywords
|
||||
(,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines)))
|
||||
|
||||
(defun fuel-help-mode ()
|
||||
"Major mode for displaying Factor documentation.
|
||||
\\{fuel-help-mode-map}"
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(use-local-map fuel-help-mode-map)
|
||||
(setq mode-name "Factor Help")
|
||||
(setq major-mode 'fuel-help-mode)
|
||||
|
||||
(fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
|
||||
|
||||
(set (make-local-variable 'view-no-disable-on-exit) t)
|
||||
(view-mode)
|
||||
(setq view-exit-action
|
||||
(lambda (buffer)
|
||||
;; Use `with-current-buffer' to make sure that `bury-buffer'
|
||||
;; also removes BUFFER from the selected window.
|
||||
(with-current-buffer buffer
|
||||
(bury-buffer))))
|
||||
|
||||
(setq fuel-autodoc-mode-string "")
|
||||
(fuel-autodoc-mode)
|
||||
(run-mode-hooks 'fuel-help-mode-hook))
|
||||
|
||||
(defun fuel-help--help-buffer ()
|
||||
(with-current-buffer (get-buffer-create "*fuel-help*")
|
||||
(fuel-help-mode)
|
||||
(current-buffer)))
|
||||
|
||||
(defvar fuel-help--history nil)
|
||||
|
||||
(defun fuel-help--show-help (&optional see)
|
||||
(let* ((def (fuel-syntax-symbol-at-point))
|
||||
(prompt (format "See%s help on%s: " (if see " short" "")
|
||||
(if def (format " (%s)" def) "")))
|
||||
(ask (or (not (memq major-mode '(factor-mode fuel-help-mode)))
|
||||
(not def)
|
||||
fuel-help-always-ask))
|
||||
(def (if ask (read-string prompt nil 'fuel-help--history def) def))
|
||||
(cmd (format "\\ %s %s" def (if see "see" "help")))
|
||||
(fuel-eval--log nil)
|
||||
(ret (fuel-eval--eval-string/context cmd))
|
||||
(out (fuel-eval--retort-output ret)))
|
||||
(if (or (fuel-eval--retort-error ret) (empty-string-p out))
|
||||
(message "No help for '%s'" def)
|
||||
(let ((hb (fuel-help--help-buffer))
|
||||
(inhibit-read-only t)
|
||||
(font-lock-verbose nil))
|
||||
(set-buffer hb)
|
||||
(erase-buffer)
|
||||
(insert out)
|
||||
(set-buffer-modified-p nil)
|
||||
(pop-to-buffer hb)
|
||||
(goto-char (point-min))))))
|
||||
|
||||
|
||||
;;; Interface: see/help commands
|
||||
|
||||
(defun fuel-help-short (&optional arg)
|
||||
"See a help summary of symbol at point.
|
||||
By default, the information is shown in the minibuffer. When
|
||||
called with a prefix argument, the information is displayed in a
|
||||
separate help buffer."
|
||||
(interactive "P")
|
||||
(if (if fuel-help-use-minibuffer (not arg) arg)
|
||||
(fuel-help--word-synopsis)
|
||||
(fuel-help--show-help t)))
|
||||
|
||||
(defun fuel-help ()
|
||||
"Show extended help about the symbol at point, using a help
|
||||
buffer."
|
||||
(interactive)
|
||||
(fuel-help--show-help))
|
||||
|
||||
|
||||
(provide 'fuel-help)
|
||||
;;; fuel-help.el ends here
|
||||
|
|
@ -0,0 +1,124 @@
|
|||
;;; fuel-listener.el --- starting the fuel listener
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Utilities to maintain and switch to a factor listener comint
|
||||
;; buffer, with an accompanying major fuel-listener-mode.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-base)
|
||||
(require 'comint)
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
(defgroup fuel-listener nil
|
||||
"Interacting with a Factor listener inside Emacs"
|
||||
:group 'fuel)
|
||||
|
||||
(defcustom fuel-listener-factor-binary "~/factor/factor"
|
||||
"Full path to the factor executable to use when starting a listener."
|
||||
:type '(file :must-match t)
|
||||
:group 'fuel-listener)
|
||||
|
||||
(defcustom fuel-listener-factor-image "~/factor/factor.image"
|
||||
"Full path to the factor image to use when starting a listener."
|
||||
:type '(file :must-match t)
|
||||
:group 'fuel-listener)
|
||||
|
||||
(defcustom fuel-listener-use-other-window t
|
||||
"Use a window other than the current buffer's when switching to
|
||||
the factor-listener buffer."
|
||||
:type 'boolean
|
||||
:group 'fuel-listener)
|
||||
|
||||
(defcustom fuel-listener-window-allow-split t
|
||||
"Allow window splitting when switching to the fuel listener
|
||||
buffer."
|
||||
:type 'boolean
|
||||
:group 'fuel-listener)
|
||||
|
||||
|
||||
;;; Fuel listener buffer/process:
|
||||
|
||||
(defvar fuel-listener-buffer nil
|
||||
"The buffer in which the Factor listener is running.")
|
||||
|
||||
(defun fuel-listener--start-process ()
|
||||
(let ((factor (expand-file-name fuel-listener-factor-binary))
|
||||
(image (expand-file-name fuel-listener-factor-image)))
|
||||
(unless (file-executable-p factor)
|
||||
(error "Could not run factor: %s is not executable" factor))
|
||||
(unless (file-readable-p image)
|
||||
(error "Could not run factor: image file %s not readable" image))
|
||||
(setq fuel-listener-buffer
|
||||
(make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image)))
|
||||
(with-current-buffer fuel-listener-buffer
|
||||
(fuel-listener-mode))))
|
||||
|
||||
(defun fuel-listener--process (&optional start)
|
||||
(or (and (buffer-live-p fuel-listener-buffer)
|
||||
(get-buffer-process fuel-listener-buffer))
|
||||
(if (not start)
|
||||
(error "No running factor listener (try M-x run-factor)")
|
||||
(fuel-listener--start-process)
|
||||
(fuel-listener--process))))
|
||||
|
||||
(setq fuel-eval--default-proc-function 'fuel-listener--process)
|
||||
|
||||
|
||||
;;; Interface: starting fuel listener
|
||||
|
||||
(defalias 'switch-to-factor 'run-factor)
|
||||
(defalias 'switch-to-fuel-listener 'run-factor)
|
||||
;;;###autoload
|
||||
(defun run-factor (&optional arg)
|
||||
"Show the fuel-listener buffer, starting the process if needed."
|
||||
(interactive)
|
||||
(let ((buf (process-buffer (fuel-listener--process t)))
|
||||
(pop-up-windows fuel-listener-window-allow-split))
|
||||
(if fuel-listener-use-other-window
|
||||
(pop-to-buffer buf)
|
||||
(switch-to-buffer buf))))
|
||||
|
||||
|
||||
;;; Fuel listener mode:
|
||||
|
||||
(defconst fuel-listener--prompt-regex "( [^)]* ) ")
|
||||
|
||||
(defun fuel-listener--wait-for-prompt (&optional timeout)
|
||||
(let ((proc (fuel-listener--process)))
|
||||
(with-current-buffer fuel-listener-buffer
|
||||
(goto-char comint-last-input-end)
|
||||
(while (not (or (re-search-forward comint-prompt-regexp nil t)
|
||||
(not (accept-process-output proc timeout))))
|
||||
(goto-char comint-last-input-end))
|
||||
(goto-char (point-max)))))
|
||||
|
||||
(defun fuel-listener--startup ()
|
||||
(fuel-listener--wait-for-prompt)
|
||||
(fuel-eval--send-string "USE: fuel")
|
||||
(message "FUEL listener up and running!"))
|
||||
|
||||
(define-derived-mode fuel-listener-mode comint-mode "Fuel Listener"
|
||||
"Major mode for interacting with an inferior Factor listener process.
|
||||
\\{fuel-listener-mode-map}"
|
||||
(set (make-local-variable 'comint-prompt-regexp)
|
||||
fuel-listener--prompt-regex)
|
||||
(set (make-local-variable 'comint-prompt-read-only) t)
|
||||
(fuel-listener--startup))
|
||||
|
||||
;; (define-key fuel-listener-mode-map "\C-w" 'comint-kill-region)
|
||||
;; (define-key fuel-listener-mode-map "\C-k" 'comint-kill-whole-line)
|
||||
|
||||
|
||||
(provide 'fuel-listener)
|
||||
;;; fuel-listener.el ends here
|
||||
|
|
@ -0,0 +1,148 @@
|
|||
;;; fuel-mode.el -- Minor mode enabling FUEL niceties
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Sat Dec 06, 2008 00:52
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; Enhancements to vanilla factor-mode (notably, listener interaction)
|
||||
;; enabled by means of a minor mode.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'factor-mode)
|
||||
(require 'fuel-base)
|
||||
(require 'fuel-syntax)
|
||||
(require 'fuel-font-lock)
|
||||
(require 'fuel-help)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-listener)
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
(defgroup fuel-mode nil
|
||||
"Mode enabling FUEL's ultimate abilities."
|
||||
:group 'fuel)
|
||||
|
||||
(defcustom fuel-mode-autodoc-p t
|
||||
"Whether `fuel-autodoc-mode' gets enable by default in fuel buffers."
|
||||
:group 'fuel-mode
|
||||
:type 'boolean)
|
||||
|
||||
|
||||
;;; User commands
|
||||
|
||||
(defun fuel-eval-region (begin end &optional arg)
|
||||
"Sends region to Fuel's listener for evaluation.
|
||||
With prefix, switchs to the listener's buffer afterwards."
|
||||
(interactive "r\nP")
|
||||
(let* ((ret (fuel-eval--eval-region/context begin end))
|
||||
(err (fuel-eval--retort-error ret)))
|
||||
(message "%s" (or err (fuel--shorten-region begin end 70))))
|
||||
(when arg (pop-to-buffer fuel-listener-buffer)))
|
||||
|
||||
(defun fuel-eval-extended-region (begin end &optional arg)
|
||||
"Sends region extended outwards to nearest definitions,
|
||||
to Fuel's listener for evaluation. With prefix, switchs to the
|
||||
listener's buffer afterwards."
|
||||
(interactive "r\nP")
|
||||
(fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point))
|
||||
(save-excursion (goto-char end) (mark-defun) (mark))))
|
||||
|
||||
(defun fuel-eval-definition (&optional arg)
|
||||
"Sends definition around point to Fuel's listener for evaluation.
|
||||
With prefix, switchs to the listener's buffer afterwards."
|
||||
(interactive "P")
|
||||
(save-excursion
|
||||
(mark-defun)
|
||||
(let* ((begin (point))
|
||||
(end (mark)))
|
||||
(unless (< begin end) (error "No evaluable definition around point"))
|
||||
(fuel-eval-region begin end))))
|
||||
|
||||
(defun fuel-edit-word-at-point (&optional arg)
|
||||
"Opens a new window visiting the definition of the word at point.
|
||||
With prefix, asks for the word to edit."
|
||||
(interactive "P")
|
||||
(let* ((word (fuel-syntax-symbol-at-point))
|
||||
(ask (or arg (not word)))
|
||||
(word (if ask
|
||||
(read-string nil
|
||||
(format "Edit word%s: "
|
||||
(if word (format " (%s)" word) ""))
|
||||
word)
|
||||
word)))
|
||||
(let* ((ret (fuel-eval--eval-string/context
|
||||
(format "\\ %s fuel-get-edit-location" word)))
|
||||
(err (fuel-eval--retort-error ret))
|
||||
(loc (fuel-eval--retort-result ret)))
|
||||
(when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
|
||||
(error "Couldn't find edit location for '%s'" word))
|
||||
(unless (file-readable-p (car loc))
|
||||
(error "Couldn't open '%s' for read" (car loc)))
|
||||
(find-file-other-window (car loc))
|
||||
(goto-line (if (numberp (cadr loc)) (cadr loc) 1)))))
|
||||
|
||||
|
||||
;;; Minor mode definition:
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-mode-string " F"
|
||||
"Modeline indicator for fuel-mode"))
|
||||
|
||||
(defvar fuel-mode-map (make-sparse-keymap)
|
||||
"Key map for fuel-mode")
|
||||
|
||||
(define-minor-mode fuel-mode
|
||||
"Toggle Fuel's mode.
|
||||
With no argument, this command toggles the mode.
|
||||
Non-null prefix argument turns on the mode.
|
||||
Null prefix argument turns off the mode.
|
||||
|
||||
When Fuel mode is enabled, a host of nice utilities for
|
||||
interacting with a factor listener is at your disposal.
|
||||
\\{fuel-mode-map}"
|
||||
:init-value nil
|
||||
:lighter fuel-mode-string
|
||||
:group 'fuel
|
||||
:keymap fuel-mode-map
|
||||
|
||||
(setq fuel-autodoc-mode-string "/A")
|
||||
(when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode)))
|
||||
|
||||
|
||||
;;; Keys:
|
||||
|
||||
(defun fuel-mode--key-1 (k c)
|
||||
(define-key fuel-mode-map (vector '(control ?c) k) c)
|
||||
(define-key fuel-mode-map (vector '(control ?c) `(control ,k)) c))
|
||||
|
||||
(defun fuel-mode--key (p k c)
|
||||
(define-key fuel-mode-map (vector '(control ?c) `(control ,p) k) c)
|
||||
(define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c))
|
||||
|
||||
(fuel-mode--key-1 ?z 'run-factor)
|
||||
|
||||
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
|
||||
(fuel-mode--key ?e ?x 'fuel-eval-definition)
|
||||
|
||||
(fuel-mode--key-1 ?r 'fuel-eval-region)
|
||||
(fuel-mode--key ?e ?r 'fuel-eval-region)
|
||||
|
||||
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
|
||||
(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
|
||||
|
||||
(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
|
||||
|
||||
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
|
||||
(fuel-mode--key ?d ?d 'fuel-help)
|
||||
(fuel-mode--key ?d ?s 'fuel-help-short)
|
||||
|
||||
|
||||
(provide 'fuel-mode)
|
||||
;;; fuel-mode.el ends here
|
||||
|
|
@ -0,0 +1,281 @@
|
|||
;;; fuel-syntax.el --- auxiliar definitions for factor code navigation.
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Auxiliar constants and functions to parse factor code.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'thingatpt)
|
||||
|
||||
|
||||
;;; Thing-at-point support for factor symbols:
|
||||
|
||||
(defun fuel-syntax--beginning-of-symbol ()
|
||||
"Move point to the beginning of the current symbol."
|
||||
(while (eq (char-before) ?:) (backward-char))
|
||||
(skip-syntax-backward "w_"))
|
||||
|
||||
(defun fuel-syntax--end-of-symbol ()
|
||||
"Move point to the end of the current symbol."
|
||||
(skip-syntax-forward "w_")
|
||||
(while (looking-at ":") (forward-char)))
|
||||
|
||||
(put 'factor-symbol 'end-op 'fuel-syntax--end-of-symbol)
|
||||
(put 'factor-symbol 'beginning-op 'fuel-syntax--beginning-of-symbol)
|
||||
|
||||
(defsubst fuel-syntax-symbol-at-point ()
|
||||
(let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
|
||||
(and (> (length s) 0) s)))
|
||||
|
||||
|
||||
;;; Regexps galore:
|
||||
|
||||
(defconst fuel-syntax--parsing-words
|
||||
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
|
||||
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
|
||||
"DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
|
||||
"GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
|
||||
"IN:" "INSTANCE:" "INTERSECTION:"
|
||||
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
|
||||
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
|
||||
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
|
||||
"TUPLE:" "T{" "t\\??" "TYPEDEF:"
|
||||
"UNION:" "USE:" "USING:" "V{" "VARS:" "W{"))
|
||||
|
||||
(defconst fuel-syntax--parsing-words-ext-regex
|
||||
(regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
|
||||
'words))
|
||||
|
||||
(defconst fuel-syntax--declaration-words
|
||||
'("flushable" "foldable" "inline" "parsing" "recursive"))
|
||||
|
||||
(defconst fuel-syntax--declaration-words-regex
|
||||
(regexp-opt fuel-syntax--declaration-words 'words))
|
||||
|
||||
(defsubst fuel-syntax--second-word-regex (prefixes)
|
||||
(format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
|
||||
|
||||
(defconst fuel-syntax--method-definition-regex
|
||||
"^M: +\\([^ ]+\\) +\\([^ ]+\\)")
|
||||
|
||||
(defconst fuel-syntax--word-definition-regex
|
||||
(fuel-syntax--second-word-regex '(":" "::" "GENERIC:")))
|
||||
|
||||
(defconst fuel-syntax--type-definition-regex
|
||||
(fuel-syntax--second-word-regex '("TUPLE:" "SINGLETON:")))
|
||||
|
||||
(defconst fuel-syntax--parent-type-regex "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
|
||||
|
||||
(defconst fuel-syntax--constructor-regex "<[^ >]+>")
|
||||
|
||||
(defconst fuel-syntax--setter-regex "\\W>>[^ ]+\\b")
|
||||
|
||||
(defconst fuel-syntax--symbol-definition-regex
|
||||
(fuel-syntax--second-word-regex '("SYMBOL:" "VAR:")))
|
||||
|
||||
(defconst fuel-syntax--stack-effect-regex " ( .* )")
|
||||
|
||||
(defconst fuel-syntax--using-lines-regex "^USING: +\\([^;]+\\);")
|
||||
|
||||
(defconst fuel-syntax--use-line-regex "^USE: +\\(.*\\)$")
|
||||
|
||||
(defconst fuel-syntax--current-vocab-regex "^IN: +\\([^ \r\n\f]+\\)")
|
||||
|
||||
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
|
||||
|
||||
(defconst fuel-syntax--definition-starters-regex
|
||||
(regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" "")))
|
||||
|
||||
(defconst fuel-syntax--definition-start-regex
|
||||
(format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
|
||||
|
||||
(defconst fuel-syntax--definition-end-regex
|
||||
(format "\\(\\(^\\| +\\);\\( +%s\\)*\\($\\| +\\)\\)"
|
||||
fuel-syntax--declaration-words-regex))
|
||||
|
||||
(defconst fuel-syntax--single-liner-regex
|
||||
(format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
|
||||
"PRIVATE>" "<PRIVATE"
|
||||
"SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
|
||||
|
||||
(defconst fuel-syntax--begin-of-def-regex
|
||||
(format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
|
||||
fuel-syntax--definition-start-regex
|
||||
fuel-syntax--single-liner-regex))
|
||||
|
||||
(defconst fuel-syntax--end-of-def-line-regex
|
||||
(format "^.*%s" fuel-syntax--definition-end-regex))
|
||||
|
||||
(defconst fuel-syntax--end-of-def-regex
|
||||
(format "\\(%s\\)\\|\\(%s .*\\)"
|
||||
fuel-syntax--end-of-def-line-regex
|
||||
fuel-syntax--single-liner-regex))
|
||||
|
||||
;;; Factor syntax table
|
||||
|
||||
(defvar fuel-syntax--syntax-table
|
||||
(let ((i 0)
|
||||
(table (make-syntax-table)))
|
||||
;; Default is atom-constituent
|
||||
(while (< i 256)
|
||||
(modify-syntax-entry i "_ " table)
|
||||
(setq i (1+ i)))
|
||||
|
||||
;; Word components.
|
||||
(setq i ?0)
|
||||
(while (<= i ?9)
|
||||
(modify-syntax-entry i "w " table)
|
||||
(setq i (1+ i)))
|
||||
(setq i ?A)
|
||||
(while (<= i ?Z)
|
||||
(modify-syntax-entry i "w " table)
|
||||
(setq i (1+ i)))
|
||||
(setq i ?a)
|
||||
(while (<= i ?z)
|
||||
(modify-syntax-entry i "w " table)
|
||||
(setq i (1+ i)))
|
||||
|
||||
;; Whitespace
|
||||
(modify-syntax-entry ?\t " " table)
|
||||
(modify-syntax-entry ?\f " " table)
|
||||
(modify-syntax-entry ?\r " " table)
|
||||
(modify-syntax-entry ? " " table)
|
||||
|
||||
;; (end of) Comments
|
||||
(modify-syntax-entry ?\n ">" table)
|
||||
|
||||
;; Parenthesis
|
||||
(modify-syntax-entry ?\[ "(] " table)
|
||||
(modify-syntax-entry ?\] ")[ " table)
|
||||
(modify-syntax-entry ?{ "(} " table)
|
||||
(modify-syntax-entry ?} "){ " table)
|
||||
|
||||
(modify-syntax-entry ?\( "()" table)
|
||||
(modify-syntax-entry ?\) ")(" table)
|
||||
|
||||
;; Strings
|
||||
(modify-syntax-entry ?\" "\"" table)
|
||||
(modify-syntax-entry ?\\ "/" table)
|
||||
table)
|
||||
"Syntax table used while in Factor mode.")
|
||||
|
||||
(defconst fuel-syntax--syntactic-keywords
|
||||
`(("\\(#!\\)" (1 "<"))
|
||||
(" \\(!\\)" (1 "<"))
|
||||
("^\\(!\\)" (1 "<"))
|
||||
("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
|
||||
("\\([[({]\\)\\([^ \"\n]\\)" (1 "_") (2 "_"))
|
||||
("\\([^ \"\n]\\)\\([])}]\\)" (1 "_") (2 "_"))))
|
||||
|
||||
|
||||
;;; Source code analysis:
|
||||
|
||||
(defsubst fuel-syntax--brackets-depth ()
|
||||
(nth 0 (syntax-ppss)))
|
||||
|
||||
(defsubst fuel-syntax--brackets-start ()
|
||||
(nth 1 (syntax-ppss)))
|
||||
|
||||
(defun fuel-syntax--brackets-end ()
|
||||
(save-excursion
|
||||
(goto-char (fuel-syntax--brackets-start))
|
||||
(condition-case nil
|
||||
(progn (forward-sexp)
|
||||
(1- (point)))
|
||||
(error -1))))
|
||||
|
||||
(defsubst fuel-syntax--indentation-at (pos)
|
||||
(save-excursion (goto-char pos) (current-indentation)))
|
||||
|
||||
(defsubst fuel-syntax--increased-indentation (&optional i)
|
||||
(+ (or i (current-indentation)) factor-indent-width))
|
||||
(defsubst fuel-syntax--decreased-indentation (&optional i)
|
||||
(- (or i (current-indentation)) factor-indent-width))
|
||||
|
||||
(defsubst fuel-syntax--at-begin-of-def ()
|
||||
(looking-at fuel-syntax--begin-of-def-regex))
|
||||
|
||||
(defsubst fuel-syntax--at-end-of-def ()
|
||||
(looking-at fuel-syntax--end-of-def-regex))
|
||||
|
||||
(defsubst fuel-syntax--looking-at-emptiness ()
|
||||
(looking-at "^[ \t]*$"))
|
||||
|
||||
(defun fuel-syntax--at-setter-line ()
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(if (not (fuel-syntax--looking-at-emptiness))
|
||||
(re-search-forward fuel-syntax--setter-regex (line-end-position) t)
|
||||
(forward-line -1)
|
||||
(or (fuel-syntax--at-constructor-line)
|
||||
(fuel-syntax--at-setter-line)))))
|
||||
|
||||
(defun fuel-syntax--at-constructor-line ()
|
||||
(save-excursion
|
||||
(beginning-of-line)
|
||||
(re-search-forward fuel-syntax--constructor-regex (line-end-position) t)))
|
||||
|
||||
(defsubst fuel-syntax--at-using ()
|
||||
(looking-at fuel-syntax--using-lines-regex))
|
||||
|
||||
(defsubst fuel-syntax--beginning-of-defun (&optional times)
|
||||
(re-search-backward fuel-syntax--begin-of-def-regex nil t times))
|
||||
|
||||
(defsubst fuel-syntax--end-of-defun ()
|
||||
(re-search-forward fuel-syntax--end-of-def-regex nil t))
|
||||
|
||||
|
||||
;;; USING/IN:
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-syntax--current-vocab nil))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-syntax--usings nil))
|
||||
|
||||
(defun fuel-syntax--current-vocab ()
|
||||
(let ((ip
|
||||
(save-excursion
|
||||
(when (re-search-backward fuel-syntax--current-vocab-regex nil t)
|
||||
(setq fuel-syntax--current-vocab (match-string-no-properties 1))
|
||||
(point)))))
|
||||
(when ip
|
||||
(let ((pp (save-excursion
|
||||
(when (re-search-backward fuel-syntax--sub-vocab-regex ip t)
|
||||
(point)))))
|
||||
(when (and pp (> pp ip))
|
||||
(let ((sub (match-string-no-properties 1)))
|
||||
(unless (save-excursion (search-backward (format "%s>" sub) pp t))
|
||||
(setq fuel-syntax--current-vocab
|
||||
(format "%s.%s" fuel-syntax--current-vocab (downcase sub)))))))))
|
||||
fuel-syntax--current-vocab)
|
||||
|
||||
(defun fuel-syntax--usings-update ()
|
||||
(save-excursion
|
||||
(setq fuel-syntax--usings (list (fuel-syntax--current-vocab)))
|
||||
(while (re-search-backward fuel-syntax--using-lines-regex nil t)
|
||||
(dolist (u (split-string (match-string-no-properties 1) nil t))
|
||||
(push u fuel-syntax--usings)))
|
||||
fuel-syntax--usings))
|
||||
|
||||
(defsubst fuel-syntax--usings-update-hook ()
|
||||
(fuel-syntax--usings-update)
|
||||
nil)
|
||||
|
||||
(defun fuel-syntax--enable-usings ()
|
||||
(add-hook 'before-save-hook 'fuel-syntax--usings-update-hook nil t)
|
||||
(fuel-syntax--usings-update))
|
||||
|
||||
(defsubst fuel-syntax--usings ()
|
||||
(or fuel-syntax--usings (fuel-syntax--usings-update)))
|
||||
|
||||
|
||||
(provide 'fuel-syntax)
|
||||
;;; fuel-syntax.el ends here
|
||||
Loading…
Reference in New Issue