Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
82d8d769b2
basis
delegate
float-arrays
math
points
vectors
stack-checker
backend
inlining
ui/gestures
core
math/floats
sequences
extra
benchmark/nbody
jamshred/tunnel
misc
|
|
@ -28,21 +28,21 @@ HELP: group-words
|
|||
{ $values { "group" "a group" } { "words" "an array of words" } }
|
||||
{ $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ;
|
||||
|
||||
ARTICLE: { "delegate" "intro" } "Delegation"
|
||||
ARTICLE: "delegate" "Delegation"
|
||||
"The " { $vocab-link "delegate" } " vocabulary implements run-time consultation for method dispatch."
|
||||
$nl
|
||||
"Fundamental to the concept of " { $emphasis "protocols" } ", which are groups of tuple slot accessors, or groups of arbtirary generic words."
|
||||
"A " { $emphasis "protocol" } " is a collection of related generic words. An object is said to " { $emphasis "consult" } " another object if it implements a protocol by forwarding all methods onto the other object."
|
||||
$nl
|
||||
"This allows an object to implement a certain protocol by passing the method calls to another object."
|
||||
"Using this vocabulary, protocols can be defined and consulation can be set up without any repetitive boilerplate."
|
||||
$nl
|
||||
"Unlike " { $link "tuple-subclassing" } ", which expresses " { $emphasis "is-a" } " relationships by statically including the methods and slots of the superclass in all subclasses, consultation forwards generic word calls to another distinct object."
|
||||
$nl
|
||||
"Fundamentally, a protocol is a word which has a method for " { $link group-words } ". One type of protocol is a tuple, which consists of the slot accessors. To define a protocol as a set of words, use"
|
||||
"Defining new protocols:"
|
||||
{ $subsection POSTPONE: PROTOCOL: }
|
||||
{ $subsection define-protocol }
|
||||
"The literal syntax and defining word are:"
|
||||
"Defining consultation:"
|
||||
{ $subsection POSTPONE: CONSULT: }
|
||||
{ $subsection define-consult }
|
||||
"The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ;
|
||||
"Every tuple class has an associated protocol consisting of all of its slot accessor methods. The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ;
|
||||
|
||||
ABOUT: { "delegate" "intro" }
|
||||
ABOUT: "delegate"
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private alien.accessors sequences
|
||||
sequences.private math math.private byte-arrays accessors
|
||||
alien.c-types parser prettyprint.backend ;
|
||||
alien.c-types parser prettyprint.backend combinators ;
|
||||
IN: float-arrays
|
||||
|
||||
TUPLE: float-array
|
||||
|
|
@ -64,29 +64,31 @@ M: float-array pprint-delims drop \ F{ \ } ;
|
|||
M: float-array >pprint-sequence ;
|
||||
M: float-array pprint* pprint-object ;
|
||||
|
||||
! Rice
|
||||
! Specializer hints
|
||||
USING: hints math.vectors arrays ;
|
||||
|
||||
HINTS: vneg { float-array } { array } ;
|
||||
HINTS: v*n { float-array float } { array object } ;
|
||||
HINTS: n*v { float float-array } { array object } ;
|
||||
HINTS: v/n { float-array float } { array object } ;
|
||||
HINTS: n/v { float float-array } { object array } ;
|
||||
HINTS: v+ { float-array float-array } { array array } ;
|
||||
HINTS: v- { float-array float-array } { array array } ;
|
||||
HINTS: v* { float-array float-array } { array array } ;
|
||||
HINTS: v/ { float-array float-array } { array array } ;
|
||||
HINTS: vmax { float-array float-array } { array array } ;
|
||||
HINTS: vmin { float-array float-array } { array array } ;
|
||||
HINTS: v. { float-array float-array } { array array } ;
|
||||
HINTS: norm-sq { float-array } { array } ;
|
||||
HINTS: norm { float-array } { array } ;
|
||||
HINTS: normalize { float-array } { array } ;
|
||||
HINTS: <float-array> { 2 } { 3 } ;
|
||||
|
||||
! More rice. Experimental, currently causes a slowdown in raytracer
|
||||
! for some odd reason.
|
||||
HINTS: vneg { array } { float-array } ;
|
||||
HINTS: v*n { array object } { float-array float } ;
|
||||
HINTS: n*v { array object } { float float-array } ;
|
||||
HINTS: v/n { array object } { float-array float } ;
|
||||
HINTS: n/v { object array } { float float-array } ;
|
||||
HINTS: v+ { array array } { float-array float-array } ;
|
||||
HINTS: v- { array array } { float-array float-array } ;
|
||||
HINTS: v* { array array } { float-array float-array } ;
|
||||
HINTS: v/ { array array } { float-array float-array } ;
|
||||
HINTS: vmax { array array } { float-array float-array } ;
|
||||
HINTS: vmin { array array } { float-array float-array } ;
|
||||
HINTS: v. { array array } { float-array float-array } ;
|
||||
HINTS: norm-sq { array } { float-array } ;
|
||||
HINTS: norm { array } { float-array } ;
|
||||
HINTS: normalize { array } { float-array } ;
|
||||
HINTS: distance { array array } { float-array float-array } ;
|
||||
|
||||
USING: words classes.algebra compiler.tree.propagation.info ;
|
||||
! Type functions
|
||||
USING: words classes.algebra compiler.tree.propagation.info
|
||||
math.intervals ;
|
||||
|
||||
{ v+ v- v* v/ vmax vmin } [
|
||||
[
|
||||
|
|
@ -114,10 +116,15 @@ USING: words classes.algebra compiler.tree.propagation.info ;
|
|||
] each
|
||||
|
||||
\ norm-sq [
|
||||
class>> float-array class<= float object ? <class-info>
|
||||
class>> float-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ v. [
|
||||
[ class>> float-array class<= ] both?
|
||||
float object ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ distance [
|
||||
[ class>> float-array class<= ] both?
|
||||
[ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
|
||||
] "outputs" set-word-prop
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
IN: hints
|
||||
USING: help.markup help.syntax words quotations sequences ;
|
||||
USING: help.markup help.syntax words quotations sequences kernel ;
|
||||
|
||||
ARTICLE: "hints" "Compiler specialization hints"
|
||||
"Specialization hints help the compiler generate efficient code."
|
||||
$nl
|
||||
"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
|
||||
"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class, or even " { $link eq? } " to some literal. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class or value, and inlining of generic methods can take place."
|
||||
$nl
|
||||
"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
|
||||
$nl
|
||||
|
|
@ -20,10 +20,10 @@ HELP: specialized-def
|
|||
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
|
||||
|
||||
HELP: HINTS:
|
||||
{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes" } }
|
||||
{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } }
|
||||
{ $description "Defines specialization hints for a word or a method."
|
||||
$nl
|
||||
"Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
|
||||
"Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." }
|
||||
{ $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
|
||||
{ $code "HINTS: append { string string } { array array } ;" }
|
||||
"Specializers can also be defined on methods:"
|
||||
|
|
|
|||
|
|
@ -3,25 +3,34 @@
|
|||
USING: parser words definitions kernel sequences assocs arrays
|
||||
kernel.private fry combinators accessors vectors strings sbufs
|
||||
byte-arrays byte-vectors io.binary io.streams.string splitting
|
||||
math generic generic.standard generic.standard.engines ;
|
||||
math generic generic.standard generic.standard.engines classes ;
|
||||
IN: hints
|
||||
|
||||
: (make-specializer) ( class picker -- quot )
|
||||
swap "predicate" word-prop append ;
|
||||
GENERIC: specializer-predicate ( spec -- quot )
|
||||
|
||||
: make-specializer ( classes -- quot )
|
||||
M: class specializer-predicate "predicate" word-prop ;
|
||||
|
||||
M: object specializer-predicate '[ _ eq? ] ;
|
||||
|
||||
GENERIC: specializer-declaration ( spec -- class )
|
||||
|
||||
M: class specializer-declaration ;
|
||||
|
||||
M: object specializer-declaration class ;
|
||||
|
||||
: make-specializer ( specs -- quot )
|
||||
dup length <reversed>
|
||||
[ (picker) 2array ] 2map
|
||||
[ drop object eq? not ] assoc-filter
|
||||
[ [ t ] ] [
|
||||
[ (make-specializer) ] { } assoc>map
|
||||
[ swap specializer-predicate append ] { } assoc>map
|
||||
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
|
||||
] if-empty ;
|
||||
|
||||
: specializer-cases ( quot word -- default alist )
|
||||
dup [ array? ] all? [ 1array ] unless [
|
||||
[ make-specializer ] keep
|
||||
'[ _ declare ] pick append
|
||||
[ specializer-declaration ] map '[ _ declare ] pick append
|
||||
] { } map>assoc ;
|
||||
|
||||
: method-declaration ( method -- quot )
|
||||
|
|
|
|||
|
|
@ -22,6 +22,5 @@ PRIVATE>
|
|||
: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
|
||||
: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
|
||||
: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
|
||||
: distance ( point point -- float ) v- norm ;
|
||||
: midpoint ( point point -- point ) v+ 2 v/n ;
|
||||
: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
|
||||
|
|
@ -24,6 +24,8 @@ IN: math.vectors
|
|||
: norm ( v -- x ) norm-sq sqrt ;
|
||||
: normalize ( u -- v ) dup norm v/n ;
|
||||
|
||||
: distance ( u v -- x ) [ - absq ] [ + ] 2map-reduce sqrt ;
|
||||
|
||||
: set-axis ( u v axis -- w )
|
||||
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
|
||||
|
||||
|
|
@ -31,6 +33,7 @@ HINTS: vneg { array } ;
|
|||
HINTS: norm-sq { array } ;
|
||||
HINTS: norm { array } ;
|
||||
HINTS: normalize { array } ;
|
||||
HINTS: distance { array array } ;
|
||||
|
||||
HINTS: n*v { object array } ;
|
||||
HINTS: v*n { array object } ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: fry arrays generic io io.streams.string kernel math
|
|||
namespaces parser prettyprint sequences strings vectors words
|
||||
quotations effects classes continuations debugger assocs
|
||||
combinators compiler.errors accessors math.order definitions
|
||||
sets generic.standard.engines.tuple stack-checker.state
|
||||
sets generic.standard.engines.tuple hints stack-checker.state
|
||||
stack-checker.visitor stack-checker.errors
|
||||
stack-checker.values stack-checker.recursive-state ;
|
||||
IN: stack-checker.backend
|
||||
|
|
@ -125,7 +125,7 @@ M: object apply-object push-literal ;
|
|||
] 2bi ; inline
|
||||
|
||||
: infer-word-def ( word -- )
|
||||
[ def>> ] [ add-recursive-state ] bi infer-quot ;
|
||||
[ specialized-def ] [ add-recursive-state ] bi infer-quot ;
|
||||
|
||||
: check->r ( -- )
|
||||
meta-r get empty? terminated? get or
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry namespaces assocs kernel sequences words accessors
|
||||
definitions math math.order effects classes arrays combinators
|
||||
vectors arrays
|
||||
vectors arrays hints
|
||||
stack-checker.state
|
||||
stack-checker.errors
|
||||
stack-checker.values
|
||||
|
|
@ -17,7 +17,7 @@ IN: stack-checker.inlining
|
|||
! having to handle recursive inline words.
|
||||
|
||||
: infer-inline-word-def ( word label -- )
|
||||
[ drop def>> ] [ add-inline-word ] 2bi infer-quot ;
|
||||
[ drop specialized-def ] [ add-inline-word ] 2bi infer-quot ;
|
||||
|
||||
TUPLE: inline-recursive < identity-tuple
|
||||
id
|
||||
|
|
|
|||
|
|
@ -205,7 +205,7 @@ SYMBOL: drag-timer
|
|||
dup hand-last-button get = ;
|
||||
|
||||
: multi-click-position? ( -- ? )
|
||||
hand-loc get hand-click-loc get v- norm-sq 100 <= ;
|
||||
hand-loc get hand-click-loc get distance 10 <= ;
|
||||
|
||||
: multi-click? ( button -- ? )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -60,3 +60,5 @@ unit-test
|
|||
[ 0 ] [ 1/0. >bignum ] unit-test
|
||||
|
||||
[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
|
||||
|
||||
[ 5 ] [ 10.5 1.9 /i ] unit-test
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ M: float - float- ;
|
|||
M: float * float* ;
|
||||
M: float / float/f ;
|
||||
M: float /f float/f ;
|
||||
M: float /i float/f >integer ;
|
||||
M: float mod float-mod ;
|
||||
|
||||
M: real abs dup 0 < [ neg ] when ;
|
||||
|
|
|
|||
|
|
@ -101,14 +101,17 @@ M: integer nth-unsafe drop ;
|
|||
|
||||
INSTANCE: integer immutable-sequence
|
||||
|
||||
: first-unsafe
|
||||
0 swap nth-unsafe ; inline
|
||||
|
||||
: first2-unsafe
|
||||
[ 0 swap nth-unsafe 1 ] [ nth-unsafe ] bi ; inline
|
||||
[ first-unsafe ] [ 1 swap nth-unsafe ] bi ; inline
|
||||
|
||||
: first3-unsafe
|
||||
[ first2-unsafe 2 ] [ nth-unsafe ] bi ; inline
|
||||
[ first2-unsafe ] [ 2 swap nth-unsafe ] bi ; inline
|
||||
|
||||
: first4-unsafe
|
||||
[ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline
|
||||
[ first3-unsafe ] [ 3 swap nth-unsafe ] bi ; inline
|
||||
|
||||
: exchange-unsafe ( m n seq -- )
|
||||
[ tuck [ nth-unsafe ] 2bi@ ]
|
||||
|
|
@ -774,13 +777,13 @@ PRIVATE>
|
|||
tuck [ tail-slice ] 2bi@ ;
|
||||
|
||||
: unclip ( seq -- rest first )
|
||||
[ rest ] [ first ] bi ;
|
||||
[ rest ] [ first-unsafe ] bi ;
|
||||
|
||||
: unclip-last ( seq -- butlast last )
|
||||
[ but-last ] [ peek ] bi ;
|
||||
|
||||
: unclip-slice ( seq -- rest-slice first )
|
||||
[ rest-slice ] [ first ] bi ; inline
|
||||
[ rest-slice ] [ first-unsafe ] bi ; inline
|
||||
|
||||
: 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
|
||||
[ unclip-slice ] bi@ swapd ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,105 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors float-arrays fry kernel locals make math
|
||||
math.constants math.functions math.vectors prettyprint
|
||||
sequences hints arrays ;
|
||||
IN: benchmark.nbody
|
||||
|
||||
: solar-mass 4 pi sq * ; inline
|
||||
: days-per-year 365.24 ; inline
|
||||
|
||||
TUPLE: body
|
||||
{ location float-array }
|
||||
{ velocity float-array }
|
||||
{ mass float read-only } ;
|
||||
|
||||
: <body> ( location velocity mass -- body )
|
||||
[ days-per-year v*n ] [ solar-mass * ] bi* body boa ; inline
|
||||
|
||||
: <jupiter> ( -- body )
|
||||
F{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 }
|
||||
F{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 }
|
||||
9.54791938424326609e-04
|
||||
<body> ;
|
||||
|
||||
: <saturn> ( -- body )
|
||||
F{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 }
|
||||
F{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 }
|
||||
2.85885980666130812e-04
|
||||
<body> ;
|
||||
|
||||
: <uranus> ( -- body )
|
||||
F{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 }
|
||||
F{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 }
|
||||
4.36624404335156298e-05
|
||||
<body> ;
|
||||
|
||||
: <neptune> ( -- body )
|
||||
F{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 }
|
||||
F{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 }
|
||||
5.15138902046611451e-05
|
||||
<body> ;
|
||||
|
||||
: <sun> ( -- body )
|
||||
F{ 0 0 0 } F{ 0 0 0 } 1 <body> ;
|
||||
|
||||
: offset-momentum ( body offset -- body )
|
||||
vneg solar-mass v/n >>velocity ; inline
|
||||
|
||||
TUPLE: nbody-system { bodies array read-only } ;
|
||||
|
||||
: init-bodies ( bodies -- )
|
||||
[ first ] [ F{ 0 0 0 } [ [ velocity>> ] [ mass>> ] bi v*n v+ ] reduce ] bi
|
||||
offset-momentum drop ; inline
|
||||
|
||||
: <nbody-system> ( -- system )
|
||||
[ <sun> , <jupiter> , <saturn> , <uranus> , <neptune> , ] { } make nbody-system boa
|
||||
dup bodies>> init-bodies ; inline
|
||||
|
||||
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
|
||||
bodies [| body i |
|
||||
body each-quot call
|
||||
bodies i 1+ tail-slice [
|
||||
body pair-quot call
|
||||
] each
|
||||
] each-index ; inline
|
||||
|
||||
: update-position ( body dt -- )
|
||||
[ dup velocity>> ] dip '[ _ _ v*n v+ ] change-location drop ;
|
||||
|
||||
: mag ( dt body other-body -- mag d )
|
||||
[ location>> ] bi@ v- [ norm-sq dup sqrt * / ] keep ; inline
|
||||
|
||||
:: update-velocity ( other-body body dt -- )
|
||||
dt body other-body mag
|
||||
[ [ body ] 2dip '[ other-body mass>> _ * _ n*v v- ] change-velocity drop ]
|
||||
[ [ other-body ] 2dip '[ body mass>> _ * _ n*v v+ ] change-velocity drop ] 2bi ;
|
||||
|
||||
: advance ( system dt -- )
|
||||
[ bodies>> ] dip
|
||||
[ '[ _ update-velocity ] [ drop ] each-pair ]
|
||||
[ '[ _ update-position ] each ]
|
||||
2bi ; inline
|
||||
|
||||
: inertia ( body -- e )
|
||||
[ mass>> ] [ velocity>> norm-sq ] bi * 0.5 * ;
|
||||
|
||||
: newton's-law ( other-body body -- e )
|
||||
[ [ mass>> ] bi@ * ] [ [ location>> ] bi@ distance ] 2bi / ;
|
||||
|
||||
: energy ( system -- x )
|
||||
[ 0.0 ] dip bodies>> [ newton's-law - ] [ inertia + ] each-pair ; inline
|
||||
|
||||
: nbody ( n -- )
|
||||
<nbody-system>
|
||||
[ energy . ] [ '[ _ 0.01 advance ] times ] [ energy . ] tri ;
|
||||
|
||||
HINTS: update-position body float ;
|
||||
HINTS: update-velocity body body float ;
|
||||
HINTS: inertia body ;
|
||||
HINTS: newton's-law body body ;
|
||||
HINTS: nbody fixnum ;
|
||||
|
||||
: nbody-main ( -- ) 1000000 nbody ;
|
||||
|
||||
MAIN: nbody-main
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays colors combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
|
||||
USE: tools.walker
|
||||
USING: accessors arrays colors combinators float-arrays kernel
|
||||
locals math math.constants math.matrices math.order math.ranges
|
||||
math.vectors math.quadratic random sequences vectors jamshred.oint ;
|
||||
IN: jamshred.tunnel
|
||||
|
||||
: n-segments ( -- n ) 5000 ; inline
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@
|
|||
(require 'font-lock)
|
||||
(require 'comint)
|
||||
(require 'view)
|
||||
(require 'ring)
|
||||
|
||||
;;; Customization:
|
||||
|
||||
|
|
@ -166,6 +167,15 @@ buffer."
|
|||
"Face for headlines in help buffers."
|
||||
:group 'factor-faces)
|
||||
|
||||
|
||||
;;; Compatibility
|
||||
(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))))))
|
||||
|
||||
|
||||
;;; Factor mode font lock:
|
||||
|
||||
|
|
@ -625,7 +635,43 @@ buffer."
|
|||
(factor--with-vocab vocab
|
||||
(factor--listener-send-cmd cmd)))
|
||||
|
||||
;;;;; Interface: see
|
||||
|
||||
;;;;; Buffer cycling and docs
|
||||
|
||||
|
||||
(defconst factor--cycle-endings
|
||||
'(".factor" "-tests.factor" "-docs.factor"))
|
||||
|
||||
(defconst factor--regex-cycle-endings
|
||||
(format "\\(.*?\\)\\(%s\\)$"
|
||||
(regexp-opt factor--cycle-endings)))
|
||||
|
||||
(defconst factor--cycle-endings-ring
|
||||
(let ((ring (make-ring (length factor--cycle-endings))))
|
||||
(dolist (e factor--cycle-endings ring)
|
||||
(ring-insert ring e))))
|
||||
|
||||
(defun factor--cycle-next (file)
|
||||
(let* ((match (string-match factor--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--cycle-endings-ring ending)))
|
||||
(gfl (lambda (i) (concat base (ring-ref factor--cycle-endings-ring i)))))
|
||||
(if (not idx) file
|
||||
(let ((l (length factor--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-visit-other-file (&optional file)
|
||||
"Cycle between code, tests and docs factor files."
|
||||
(interactive)
|
||||
(find-file (factor--cycle-next (or file (buffer-file-name)))))
|
||||
|
||||
|
||||
;;;;; Interface: See
|
||||
|
||||
(defconst factor--regex-error-marker "^Type :help for debugging")
|
||||
(defconst factor--regex-data-stack "^--- Data stack:")
|
||||
|
|
@ -848,6 +894,7 @@ vocabularies which have been modified on disk."
|
|||
(factor--define-key ?s 'factor-see t)
|
||||
(factor--define-key ?e 'factor-edit)
|
||||
(factor--define-key ?z 'switch-to-factor t)
|
||||
(factor--define-key ?o 'factor-visit-other-file)
|
||||
(factor--define-key ?c 'comment-region)
|
||||
|
||||
(factor--define-auto-indent-key ?\])
|
||||
|
|
|
|||
Loading…
Reference in New Issue