Merge branch 'master' of git://factorcode.org/git/factor
Daniel Ehrenberg
commit
494b0cfea9
|
|
@ -8,7 +8,7 @@ SINGLETON: gvim
|
|||
HOOK: gvim-path io-backend ( -- path )
|
||||
|
||||
M: gvim vim-command ( file line -- string )
|
||||
[ gvim-path , swap , "+" swap number>string append , ] { } make ;
|
||||
[ gvim-path , "+" swap number>string append , , ] { } make ;
|
||||
|
||||
gvim vim-editor set-global
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
! Generate a new factor.vim file for syntax highlighting
|
||||
USING: http.server.templating http.server.templating.fhtml
|
||||
io.files ;
|
||||
USING: html.templates html.templates.fhtml io.files io.pathnames ;
|
||||
IN: editors.vim.generate-syntax
|
||||
|
||||
: generate-vim-syntax ( -- )
|
||||
|
|
|
|||
|
|
@ -267,8 +267,8 @@ $nl
|
|||
{ $heading "Example: ls" }
|
||||
"Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
|
||||
{ $code
|
||||
<" USING: command-line namespaces io io.files tools.files
|
||||
sequences kernel ;
|
||||
<" USING: command-line namespaces io io.files
|
||||
io.pathnames tools.files sequences kernel ;
|
||||
|
||||
command-line get [
|
||||
current-directory get directory.
|
||||
|
|
|
|||
|
|
@ -209,7 +209,8 @@ ARTICLE: "tools" "Developer tools"
|
|||
{ $subsection "timing" }
|
||||
{ $subsection "tools.disassembler" }
|
||||
"Deployment tools:"
|
||||
{ $subsection "tools.deploy" } ;
|
||||
{ $subsection "tools.deploy" }
|
||||
{ $see-also "ui-tools" } ;
|
||||
|
||||
ARTICLE: "article-index" "Article index"
|
||||
{ $index [ articles get keys ] } ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io io.ports kernel math
|
||||
io.pathnames io.directories math.parser io.files ;
|
||||
io.pathnames io.directories math.parser io.files strings ;
|
||||
IN: io.files.unique
|
||||
|
||||
HELP: temporary-path
|
||||
|
|
@ -30,7 +30,7 @@ HELP: make-unique-file ( prefix suffix -- path )
|
|||
|
||||
HELP: make-unique-file*
|
||||
{ $values
|
||||
{ "prefix" null } { "suffix" null }
|
||||
{ "prefix" string } { "suffix" string }
|
||||
{ "path" "a pathname string" }
|
||||
}
|
||||
{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ;
|
||||
|
|
@ -55,11 +55,11 @@ HELP: with-unique-directory ( quot -- )
|
|||
|
||||
ARTICLE: "io.files.unique" "Temporary files"
|
||||
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
|
||||
"Files:"
|
||||
"Creating temporary files:"
|
||||
{ $subsection make-unique-file }
|
||||
{ $subsection make-unique-file* }
|
||||
{ $subsection with-unique-file }
|
||||
"Directories:"
|
||||
"Creating temporary directories:"
|
||||
{ $subsection make-unique-directory }
|
||||
{ $subsection with-unique-directory } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -117,12 +117,12 @@ prepare-test-file
|
|||
[ ] [ test-file f f 2array set-file-times ] unit-test
|
||||
|
||||
|
||||
[ ] [ test-file real-username set-file-user ] unit-test
|
||||
[ ] [ test-file real-user-name set-file-user ] unit-test
|
||||
[ ] [ test-file real-user-id set-file-user ] unit-test
|
||||
[ ] [ test-file real-group-name set-file-group ] unit-test
|
||||
[ ] [ test-file real-group-id set-file-group ] unit-test
|
||||
|
||||
[ t ] [ test-file file-username real-username = ] unit-test
|
||||
[ t ] [ test-file file-user-name real-user-name = ] unit-test
|
||||
[ t ] [ test-file file-group-name real-group-name = ] unit-test
|
||||
|
||||
[ ]
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@ USING: tools.test math arrays kernel sequences ;
|
|||
[ { { 1 } } ]
|
||||
[ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
|
||||
|
||||
[ { 1 } [ = ] slice monotonic-slice ] must-infer
|
||||
|
||||
[ t ]
|
||||
[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -24,13 +24,15 @@ PRIVATE>
|
|||
<PRIVATE
|
||||
|
||||
: (monotonic-slice) ( seq quot class -- slices )
|
||||
-rot
|
||||
[
|
||||
dupd '[
|
||||
[ length ] [ ] [ <circular> 1 over change-circular-start ] tri
|
||||
[ @ not [ , ] [ drop ] if ] 3each
|
||||
] { } make
|
||||
dup empty? [ over length 1- prefix ] when -1 prefix 2 clump
|
||||
[ first2 [ 1+ ] bi@ rot roll boa ] with with map ; inline
|
||||
swap
|
||||
] dip
|
||||
'[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -39,7 +41,7 @@ PRIVATE>
|
|||
{ 0 [ 2drop ] }
|
||||
{ 1 [ nip [ 0 1 rot ] dip boa 1array ] }
|
||||
[ drop (monotonic-slice) ]
|
||||
} case ;
|
||||
} case ; inline
|
||||
|
||||
TUPLE: downward-slice < slice ;
|
||||
TUPLE: stable-slice < slice ;
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ percent-used percent-free ;
|
|||
[ [ unparse ] map ] bi prefix simple-table. ;
|
||||
|
||||
: file-systems. ( -- )
|
||||
{ device-name free-space used-space total-space percent-used mount-point }
|
||||
{ device-name available-space free-space used-space total-space percent-used mount-point }
|
||||
print-file-systems ;
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ HELP: scaffold-undocumented
|
|||
HELP: scaffold-vocab
|
||||
{ $values
|
||||
{ "vocab-root" "a vocabulary root string" } { "string" string } }
|
||||
{ $description "Creates a direcory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
|
||||
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
|
||||
|
||||
HELP: using
|
||||
{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays hashtables io kernel math namespaces
|
||||
make opengl sequences strings splitting ui.gadgets
|
||||
|
|
@ -12,11 +12,7 @@ TUPLE: label < gadget text font color ;
|
|||
text>> dup string? [ "\n" join ] unless ; inline
|
||||
|
||||
: set-label-string ( string label -- )
|
||||
CHAR: \n pick memq? [
|
||||
[ string-lines ] dip (>>text)
|
||||
] [
|
||||
(>>text)
|
||||
] if ; inline
|
||||
[ CHAR: \n over memq? [ string-lines ] when ] dip (>>text) ; inline
|
||||
|
||||
: label-theme ( gadget -- gadget )
|
||||
sans-serif-font >>font
|
||||
|
|
|
|||
|
|
@ -24,8 +24,8 @@ HELP: group-cache
|
|||
HELP: group-id
|
||||
{ $values
|
||||
{ "string" string }
|
||||
{ "id" integer } }
|
||||
{ $description "Returns the group id given a group name." } ;
|
||||
{ "id/f" "an integer or f" } }
|
||||
{ $description "Returns the group id given a group name. Returns " { $link f } " if the group does not exist." } ;
|
||||
|
||||
HELP: group-name
|
||||
{ $values
|
||||
|
|
@ -36,7 +36,7 @@ HELP: group-name
|
|||
HELP: group-struct
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "group" "a group struct" } }
|
||||
{ "group/f" "a group struct or f" } }
|
||||
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
|
||||
|
||||
HELP: real-group-id
|
||||
|
|
|
|||
|
|
@ -27,3 +27,5 @@ IN: unix.groups.tests
|
|||
[ ] [ real-group-id group-name drop ] unit-test
|
||||
|
||||
[ "888888888888888" ] [ 888888888888888 group-name ] unit-test
|
||||
[ f ]
|
||||
[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ TUPLE: group id name passwd members ;
|
|||
|
||||
SYMBOL: group-cache
|
||||
|
||||
GENERIC: group-struct ( obj -- group )
|
||||
GENERIC: group-struct ( obj -- group/f )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -24,11 +24,14 @@ GENERIC: group-struct ( obj -- group )
|
|||
"group" <c-object> tuck 4096
|
||||
[ <byte-array> ] keep f <void*> ;
|
||||
|
||||
M: integer group-struct ( id -- group )
|
||||
(group-struct) getgrgid_r io-error ;
|
||||
: check-group-struct ( group-struct ptr -- group-struct/f )
|
||||
*void* [ drop f ] unless ;
|
||||
|
||||
M: string group-struct ( string -- group )
|
||||
(group-struct) getgrnam_r 0 = [ (io-error) ] unless ;
|
||||
M: integer group-struct ( id -- group/f )
|
||||
(group-struct) [ getgrgid_r io-error ] keep check-group-struct ;
|
||||
|
||||
M: string group-struct ( string -- group/f )
|
||||
(group-struct) [ getgrnam_r io-error ] keep check-group-struct ;
|
||||
|
||||
: group-struct>group ( group-struct -- group )
|
||||
[ \ group new ] dip
|
||||
|
|
@ -45,12 +48,12 @@ PRIVATE>
|
|||
dup group-cache get [
|
||||
dupd at* [ name>> nip ] [ drop number>string ] if
|
||||
] [
|
||||
group-struct group-gr_name
|
||||
group-struct [ group-gr_name ] [ f ] if*
|
||||
] if*
|
||||
[ nip ] [ number>string ] if* ;
|
||||
|
||||
: group-id ( string -- id )
|
||||
group-struct group-gr_gid ;
|
||||
: group-id ( string -- id/f )
|
||||
group-struct [ group-gr_gid ] [ f ] if* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax unix.types ;
|
||||
USING: alien.syntax unix.types unix.stat ;
|
||||
IN: unix.statfs.freebsd
|
||||
|
||||
CONSTANT: MFSNAMELEN 16 ! length of type name including null */
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax unix.types ;
|
||||
USING: alien.syntax unix.types unix.stat ;
|
||||
IN: unix.statfs.linux
|
||||
|
||||
C-STRUCT: statfs64
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax unix.types ;
|
||||
USING: alien.syntax unix.types unix.stat ;
|
||||
IN: unix.statfs.openbsd
|
||||
|
||||
CONSTANT: MFSNAMELEN 16
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ HELP: VALUE:
|
|||
{ $examples
|
||||
{ $example
|
||||
"USING: values math prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
"VALUE: x"
|
||||
"2 2 + to: x"
|
||||
"x ."
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ ARTICLE: "defining-words" "Defining words"
|
|||
{ $see POSTPONE: SYMBOL: }
|
||||
"The key factor in the definition of " { $link POSTPONE: SYMBOL: } " is " { $link CREATE } ", which reads a token from the input and creates a word with that name. This word is then passed to " { $link define-symbol } "."
|
||||
{ $subsection CREATE }
|
||||
{ $subsection CREATE-WORD }
|
||||
"Colon definitions are defined in a more elaborate way:"
|
||||
{ $subsection POSTPONE: : }
|
||||
"The " { $link POSTPONE: : } " word first calls " { $link CREATE } ", and then reads input until reaching " { $link POSTPONE: ; } " using a utility word:"
|
||||
|
|
|
|||
|
|
@ -338,6 +338,10 @@ HELP: 2each
|
|||
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
|
||||
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
|
||||
|
||||
HELP: 3each
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- )" } } }
|
||||
{ $description "Applies the quotation to triples of elements from " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } "." } ;
|
||||
|
||||
HELP: 2reduce
|
||||
{ $values { "seq1" sequence }
|
||||
{ "seq2" sequence }
|
||||
|
|
@ -350,10 +354,18 @@ HELP: 2map
|
|||
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
|
||||
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
|
||||
|
||||
HELP: 3map
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "newseq" "a new sequence" } }
|
||||
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
|
||||
|
||||
HELP: 2map-as
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
|
||||
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
|
||||
|
||||
HELP: 3map-as
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
|
||||
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
|
||||
|
||||
HELP: 2all?
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
|
||||
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
|
||||
|
|
@ -1262,6 +1274,17 @@ HELP: shorten
|
|||
"V{ 1 2 3 }"
|
||||
} } ;
|
||||
|
||||
HELP: iota
|
||||
{ $values { "n" integer } { "iota" iota } }
|
||||
{ $description "Creates an immutable virtual sequence containing the integers from 0 to " { $snippet "n-1" } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: math sequences prettyprint ;"
|
||||
"3 iota [ sq ] map ."
|
||||
"{ 0 1 4 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
|
||||
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
|
||||
$nl
|
||||
|
|
@ -1422,16 +1445,23 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
|
|||
{ $subsection all? }
|
||||
"Testing how elements are related:"
|
||||
{ $subsection monotonic? }
|
||||
{ $subsection "sequence-2combinators" } ;
|
||||
{ $subsection "sequence-2combinators" }
|
||||
{ $subsection "sequence-3combinators" } ;
|
||||
|
||||
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
|
||||
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
|
||||
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined."
|
||||
{ $subsection 2each }
|
||||
{ $subsection 2reduce }
|
||||
{ $subsection 2map }
|
||||
{ $subsection 2map-as }
|
||||
{ $subsection 2all? } ;
|
||||
|
||||
ARTICLE: "sequence-3combinators" "Triple-wise sequence combinators"
|
||||
"There is a set of combinators which traverse three sequences triple-wise. If one sequence is shorter than the others, then only the prefix having the length of the minimum of the three is examined."
|
||||
{ $subsection 3each }
|
||||
{ $subsection 3map }
|
||||
{ $subsection 3map-as } ;
|
||||
|
||||
ARTICLE: "sequences-tests" "Testing sequences"
|
||||
"Testing for an empty sequence:"
|
||||
{ $subsection empty? }
|
||||
|
|
|
|||
|
|
@ -277,3 +277,7 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
|
|||
{ 3 0 } [ [ 3drop ] 3each ] must-infer-as
|
||||
|
||||
[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test
|
||||
|
||||
[ "asdf" iota ] must-fail
|
||||
[ T{ iota { n 10 } } ] [ 10 iota ] unit-test
|
||||
[ 0 ] [ 10 iota first ] unit-test
|
||||
|
|
|
|||
|
|
@ -101,6 +101,20 @@ M: integer nth-unsafe drop ;
|
|||
|
||||
INSTANCE: integer immutable-sequence
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! In the future, this will replace integer sequences
|
||||
TUPLE: iota { n integer read-only } ;
|
||||
|
||||
: iota ( n -- iota ) \ iota boa ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
M: iota length n>> ;
|
||||
M: iota nth-unsafe drop ;
|
||||
|
||||
INSTANCE: iota immutable-sequence
|
||||
|
||||
: first-unsafe ( seq -- first )
|
||||
0 swap nth-unsafe ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,8 @@ ABOUT: "sequences-sorting"
|
|||
|
||||
HELP: sort
|
||||
{ $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
|
||||
{ $description "Sorts the elements into a new array." } ;
|
||||
{ $description "Sorts the elements into a new array using a stable sort." }
|
||||
{ $notes "The algorithm used is the merge sort." } ;
|
||||
|
||||
HELP: sort-keys
|
||||
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }
|
||||
|
|
|
|||
|
|
@ -207,7 +207,8 @@ DEFER: default-L-parser-values
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
|
||||
: restore-turtle ( turtle -- turtle ) saved>> pop ;
|
||||
|
||||
: restore-turtle ( turtle -- turtle ) saved>> pop dup color>> set-color ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,37 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.tree-5
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: tree-5 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
[ 5 >>angle ] >>turtle-values
|
||||
|
||||
"c(4)FFS" >>axiom
|
||||
|
||||
{
|
||||
{ "S" "FFR>(60)R>(60)R>(60)R>(60)R>(60)R>(30)S" }
|
||||
{ "R" "[Ba]" }
|
||||
{ "a" "$tF[Cx]Fb" }
|
||||
{ "b" "$tF[Dy]Fa" }
|
||||
{ "B" "&B" }
|
||||
{ "C" "+C" }
|
||||
{ "D" "-D" }
|
||||
|
||||
{ "x" "a" }
|
||||
{ "y" "b" }
|
||||
|
||||
{ "F" "'(1.25)F'(.8)" }
|
||||
}
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system tree-5 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors specialized-arrays.double fry kernel locals make math
|
||||
math.constants math.functions math.vectors prettyprint
|
||||
USING: accessors specialized-arrays.double fry kernel locals math
|
||||
math.constants math.functions math.vectors prettyprint combinators.smart
|
||||
sequences hints arrays ;
|
||||
IN: benchmark.nbody
|
||||
|
||||
|
|
@ -53,7 +53,7 @@ TUPLE: nbody-system { bodies array read-only } ;
|
|||
offset-momentum drop ; inline
|
||||
|
||||
: <nbody-system> ( -- system )
|
||||
[ <sun> , <jupiter> , <saturn> , <uranus> , <neptune> , ] { } make nbody-system boa
|
||||
[ <sun> <jupiter> <saturn> <uranus> <neptune> ] output>array nbody-system boa
|
||||
dup bodies>> init-bodies ; inline
|
||||
|
||||
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors curses kernel threads tools.test ;
|
||||
IN: curses.tests
|
||||
|
||||
: hello-curses ( -- )
|
||||
[
|
||||
curses-window new
|
||||
"mainwin" >>name
|
||||
add-curses-window
|
||||
|
||||
"mainwin" "hi" curses-printf
|
||||
|
||||
2000000 sleep
|
||||
] with-curses ;
|
||||
|
||||
[
|
||||
] [ hello-curses ] unit-test
|
||||
|
|
@ -0,0 +1,155 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.strings assocs byte-arrays
|
||||
combinators continuations destructors fry io.encodings.8-bit
|
||||
io io.encodings.string io.encodings.utf8 kernel math
|
||||
namespaces prettyprint sequences
|
||||
strings threads curses.ffi ;
|
||||
IN: curses
|
||||
|
||||
SYMBOL: curses-windows
|
||||
SYMBOL: current-window
|
||||
|
||||
: ERR -1 ; inline
|
||||
: FALSE 0 ; inline
|
||||
: TRUE 1 ; inline
|
||||
: >BOOLEAN ( n -- TRUE/FALSE ) >boolean TRUE FALSE ? ; inline
|
||||
|
||||
ERROR: duplicate-window window ;
|
||||
ERROR: unnamed-window window ;
|
||||
ERROR: window-not-found window ;
|
||||
ERROR: curses-failed ;
|
||||
|
||||
: get-window ( string -- window )
|
||||
dup curses-windows get at*
|
||||
[ nip ] [ drop window-not-found ] if ;
|
||||
|
||||
: window-ptr ( string -- window ) get-window ptr>> ;
|
||||
|
||||
: curses-error ( n -- ) ERR = [ curses-failed ] when ;
|
||||
|
||||
: with-curses ( quot -- )
|
||||
H{ } clone curses-windows [
|
||||
initscr curses-error
|
||||
[
|
||||
curses-windows get values [ dispose ] each
|
||||
nocbreak curses-error
|
||||
echo curses-error
|
||||
endwin curses-error
|
||||
] [ ] cleanup
|
||||
] with-variable ; inline
|
||||
|
||||
: with-window ( name quot -- )
|
||||
[ window-ptr current-window ] dip with-variable ; inline
|
||||
|
||||
TUPLE: curses-window
|
||||
name
|
||||
parent-name
|
||||
ptr
|
||||
{ lines integer initial: 0 }
|
||||
{ columns integer initial: 0 }
|
||||
{ y integer initial: 0 }
|
||||
{ x integer initial: 0 }
|
||||
|
||||
{ cbreak initial: t }
|
||||
{ echo initial: t }
|
||||
{ raw initial: f }
|
||||
|
||||
{ scrollok initial: t }
|
||||
{ leaveok initial: f }
|
||||
|
||||
idcok idlok immedok
|
||||
{ keypad initial: f } ;
|
||||
|
||||
M: curses-window dispose ( window -- )
|
||||
ptr>> delwin curses-error ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: add-window ( window -- )
|
||||
dup name>> [ unnamed-window ] unless*
|
||||
curses-windows get 2dup key?
|
||||
[ duplicate-window ] [ set-at ] if ;
|
||||
|
||||
: delete-window ( window -- )
|
||||
curses-windows get 2dup key?
|
||||
[ delete-at ] [ drop window-not-found ] if ;
|
||||
|
||||
: window-params ( window -- lines columns y x )
|
||||
{ [ lines>> ] [ columns>> ] [ y>> ] [ x>> ] } cleave ;
|
||||
|
||||
: setup-window ( window -- )
|
||||
{
|
||||
[
|
||||
dup
|
||||
dup parent-name>> [
|
||||
window-ptr swap window-params derwin
|
||||
] [
|
||||
window-params newwin
|
||||
] if* [ curses-error ] keep >>ptr drop
|
||||
]
|
||||
[ cbreak>> [ cbreak ] [ nocbreak ] if curses-error ]
|
||||
[ echo>> [ echo ] [ noecho ] if curses-error ]
|
||||
[ raw>> [ raw ] [ noraw ] if curses-error ]
|
||||
[ [ ptr>> ] [ scrollok>> >BOOLEAN ] bi scrollok curses-error ]
|
||||
[ [ ptr>> ] [ leaveok>> >BOOLEAN ] bi leaveok curses-error ]
|
||||
[ [ ptr>> ] [ keypad>> >BOOLEAN ] bi keypad curses-error ]
|
||||
[ add-window ]
|
||||
} cleave ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: add-curses-window ( window -- )
|
||||
[ setup-window ] [ ] [ dispose ] cleanup ;
|
||||
|
||||
: (curses-window-refresh) ( window-ptr -- ) wrefresh curses-error ;
|
||||
: wnrefresh ( window -- ) window-ptr (curses-window-refresh) ;
|
||||
: curses-refresh ( -- ) current-window get (curses-window-refresh) ;
|
||||
|
||||
: (curses-wprint) ( window-ptr string -- )
|
||||
waddstr curses-error ;
|
||||
|
||||
: curses-nwrite ( window string -- )
|
||||
[ window-ptr ] dip (curses-wprint) ;
|
||||
|
||||
: curses-wprint ( window string -- )
|
||||
[ window-ptr dup ] dip (curses-wprint) "\n" (curses-wprint) ;
|
||||
|
||||
: curses-printf ( window string -- )
|
||||
[ window-ptr dup dup ] dip (curses-wprint)
|
||||
"\n" (curses-wprint)
|
||||
(curses-window-refresh) ;
|
||||
|
||||
: curses-writef ( window string -- )
|
||||
[ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
|
||||
|
||||
: (curses-read) ( window-ptr n encoding -- string )
|
||||
[ [ <byte-array> tuck ] keep wgetnstr curses-error ] dip alien>string ;
|
||||
|
||||
: curses-read ( window n -- string )
|
||||
utf8 [ window-ptr ] 2dip (curses-read) ;
|
||||
|
||||
: curses-erase ( window -- ) window-ptr werase curses-error ;
|
||||
|
||||
: move-cursor ( window-name y x -- )
|
||||
[
|
||||
window-ptr
|
||||
{
|
||||
[ ]
|
||||
[ (curses-window-refresh) ]
|
||||
[ c-window-_curx ]
|
||||
[ c-window-_cury ]
|
||||
} cleave
|
||||
] 2dip mvcur curses-error (curses-window-refresh) ;
|
||||
|
||||
: delete-line ( window-name y -- )
|
||||
[ window-ptr dup ] dip
|
||||
0 wmove curses-error wdeleteln curses-error ;
|
||||
|
||||
: insert-blank-line ( window-name y -- )
|
||||
[ window-ptr dup ] dip
|
||||
0 wmove curses-error winsertln curses-error ;
|
||||
|
||||
: insert-line ( window-name y string -- )
|
||||
[ dupd insert-blank-line ] dip
|
||||
curses-writef ;
|
||||
|
|
@ -0,0 +1,231 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.syntax combinators kernel system ;
|
||||
IN: curses.ffi
|
||||
|
||||
<< "curses" {
|
||||
{ [ os winnt? ] [ "libcurses.dll" ] }
|
||||
{ [ os macosx? ] [ "libcurses.dylib" ] }
|
||||
{ [ os unix? ] [ "libcurses.so" ] }
|
||||
} cond "cdecl" add-library >>
|
||||
|
||||
TYPEDEF: void* WINDOW*
|
||||
TYPEDEF: void* SCREEN*
|
||||
TYPEDEF: void* va_list
|
||||
|
||||
TYPEDEF: uint chtype
|
||||
TYPEDEF: chtype attr_t
|
||||
TYPEDEF: short NCURSES_SIZE_T
|
||||
TYPEDEF: ushort wchar_t
|
||||
|
||||
: CCHARW_MAX 5 ; inline
|
||||
|
||||
C-STRUCT: cchar_t
|
||||
{ "attr_t" "attr" }
|
||||
{ { "wchar_t" CCHARW_MAX } "chars" } ;
|
||||
|
||||
C-STRUCT: pdat
|
||||
{ "NCURSES_SIZE_T" "_pad_y" }
|
||||
{ "NCURSES_SIZE_T" "_pad_x" }
|
||||
{ "NCURSES_SIZE_T" "_pad_top" }
|
||||
{ "NCURSES_SIZE_T" "_pad_left" }
|
||||
{ "NCURSES_SIZE_T" "_pad_bottom" }
|
||||
{ "NCURSES_SIZE_T" "_pad_right" } ;
|
||||
|
||||
C-STRUCT: c-window
|
||||
{ "NCURSES_SIZE_T" "_cury" }
|
||||
{ "NCURSES_SIZE_T" "_curx" }
|
||||
|
||||
{ "NCURSES_SIZE_T" "_maxy" }
|
||||
{ "NCURSES_SIZE_T" "_maxx" }
|
||||
{ "NCURSES_SIZE_T" "_begy" }
|
||||
{ "NCURSES_SIZE_T" "_begx" }
|
||||
|
||||
{ "short" " _flags" }
|
||||
|
||||
{ "attr_t" "_attrs" }
|
||||
{ "chtype" "_bkgd" }
|
||||
|
||||
{ "bool" "_notimeout" }
|
||||
{ "bool" "_clear" }
|
||||
{ "bool" "_leaveok" }
|
||||
{ "bool" "_scroll" }
|
||||
{ "bool" "_idlok" }
|
||||
{ "bool" "_idcok" }
|
||||
{ "bool" "_immed" }
|
||||
{ "bool" "_sync" }
|
||||
{ "bool" "_use_keypad" }
|
||||
{ "int" "_delay" }
|
||||
|
||||
{ "char*" "_line" }
|
||||
{ "NCURSES_SIZE_T" "_regtop" }
|
||||
{ "NCURSES_SIZE_T" "_regbottom" }
|
||||
|
||||
{ "int" "_parx" }
|
||||
{ "int" "_pary" }
|
||||
{ "WINDOW*" "_parent" }
|
||||
|
||||
{ "pdat" "_pad" }
|
||||
|
||||
{ "NCURSES_SIZE_T" "_yoffset" }
|
||||
|
||||
{ "cchar_t" "_bkgrnd" } ;
|
||||
|
||||
LIBRARY: curses
|
||||
|
||||
: stdscr ( -- alien )
|
||||
"stdscr" "curses" library dll>> dlsym ;
|
||||
|
||||
FUNCTION: WINDOW* initscr ( ) ;
|
||||
FUNCTION: int endwin ( ) ;
|
||||
FUNCTION: bool isendwin ( ) ;
|
||||
FUNCTION: SCREEN* newterm ( char* type, FILE* outfd, FILE* infd ) ;
|
||||
FUNCTION: SCREEN* set_term ( SCREEN* new ) ;
|
||||
FUNCTION: void delscreen ( SCREEN* sp ) ;
|
||||
|
||||
FUNCTION: int def_prog_mode ( ) ;
|
||||
FUNCTION: int def_shell_mode ( ) ;
|
||||
FUNCTION: int reset_prog_mode ( ) ;
|
||||
FUNCTION: int reset_shell_mode ( ) ;
|
||||
FUNCTION: int resetty ( ) ;
|
||||
FUNCTION: int savetty ( ) ;
|
||||
FUNCTION: int ripoffline ( int line, void* callback ) ;
|
||||
FUNCTION: int curs_set ( int visibility ) ;
|
||||
FUNCTION: int napms ( int ms ) ;
|
||||
|
||||
FUNCTION: WINDOW* newwin ( int nlines, int ncols, int begin_y, int begin_x ) ;
|
||||
FUNCTION: int delwin ( WINDOW* win ) ;
|
||||
FUNCTION: int mvwin ( WINDOW* win, int y, int x ) ;
|
||||
FUNCTION: WINDOW* subwin ( WINDOW* orig, int nlines, int ncols, int begin_y, int begin_x ) ;
|
||||
FUNCTION: WINDOW* derwin ( WINDOW* orig, int nlines, int ncols, int begin_y, int begin_x ) ;
|
||||
FUNCTION: int mvderwin ( WINDOW* win, int par_y, int par_x ) ;
|
||||
FUNCTION: WINDOW* dupwin ( WINDOW* win ) ;
|
||||
FUNCTION: void wsyncup ( WINDOW* win ) ;
|
||||
FUNCTION: int syncok ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: void wcursyncup ( WINDOW* win ) ;
|
||||
FUNCTION: void wsyncdown ( WINDOW* win ) ;
|
||||
|
||||
FUNCTION: int cbreak ( ) ;
|
||||
FUNCTION: int nocbreak ( ) ;
|
||||
FUNCTION: int echo ( ) ;
|
||||
FUNCTION: int noecho ( ) ;
|
||||
FUNCTION: int halfdelay ( int tenths ) ;
|
||||
FUNCTION: int intrflush ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: int keypad ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: int meta ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: int nodelay ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: int raw ( ) ;
|
||||
FUNCTION: int noraw ( ) ;
|
||||
FUNCTION: void noqiflush ( ) ;
|
||||
FUNCTION: void qiflush ( ) ;
|
||||
FUNCTION: int notimeout ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: void timeout ( int delay ) ;
|
||||
FUNCTION: void wtimeout ( WINDOW* win, int delay ) ;
|
||||
FUNCTION: int typeahead ( int fd ) ;
|
||||
|
||||
FUNCTION: int clearok ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: int idlok ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: void idcok ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: void immedok ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: int leaveok ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: int setscrreg ( int top, int bot ) ;
|
||||
FUNCTION: int wsetscrreg ( WINDOW* win, int top, int bot ) ;
|
||||
FUNCTION: int scrollok ( WINDOW* win, bool bf ) ;
|
||||
FUNCTION: int nl ( ) ;
|
||||
FUNCTION: int nonl ( ) ;
|
||||
|
||||
FUNCTION: int erase ( ) ;
|
||||
FUNCTION: int werase ( WINDOW* win ) ;
|
||||
FUNCTION: int clear ( ) ;
|
||||
FUNCTION: int wclear ( WINDOW* win ) ;
|
||||
FUNCTION: int clrtobot ( ) ;
|
||||
FUNCTION: int wclrtobot ( WINDOW* win ) ;
|
||||
FUNCTION: int clrtoeol ( ) ;
|
||||
FUNCTION: int wclrtoeol ( WINDOW* win ) ;
|
||||
|
||||
FUNCTION: int refresh ( ) ;
|
||||
FUNCTION: int wrefresh ( WINDOW* win ) ;
|
||||
FUNCTION: int wnoutrefresh ( WINDOW* win ) ;
|
||||
FUNCTION: int doupdate ( ) ;
|
||||
FUNCTION: int redrawwin ( WINDOW* win ) ;
|
||||
FUNCTION: int wredrawln ( WINDOW* win, int beg_line, int num_lines ) ;
|
||||
|
||||
FUNCTION: int getch ( ) ;
|
||||
FUNCTION: int wgetch ( WINDOW* win ) ;
|
||||
FUNCTION: int mvgetch ( int y, int x ) ;
|
||||
FUNCTION: int mvwgetch ( WINDOW* win, int y, int x ) ;
|
||||
FUNCTION: int ungetch ( int ch ) ;
|
||||
FUNCTION: int has_key ( int ch ) ;
|
||||
|
||||
FUNCTION: int getstr ( char* str ) ;
|
||||
FUNCTION: int getnstr ( char* str, int n ) ;
|
||||
FUNCTION: int wgetstr ( WINDOW* win, char* str ) ;
|
||||
FUNCTION: int wgetnstr ( WINDOW* win, char* str, int n ) ;
|
||||
FUNCTION: int mvgetstr ( int y, int x, char* str ) ;
|
||||
FUNCTION: int mvwgetstr ( WINDOW* win, int y, int x, char* str ) ;
|
||||
FUNCTION: int mvgetnstr ( int y, int x, char* str, int n ) ;
|
||||
FUNCTION: int mvwgetnstr ( WINDOW* win, int y, int x, char* str, int n ) ;
|
||||
|
||||
FUNCTION: int printw ( char* fmt, int lol ) ;
|
||||
FUNCTION: int wprintw ( WINDOW* win, char* fmt, int lol ) ;
|
||||
FUNCTION: int mvprintw ( int y, int x, char* fmt, int lol ) ;
|
||||
FUNCTION: int mvwprintw ( WINDOW* win, int y, int x, char* fmt, int lol ) ;
|
||||
FUNCTION: int vwprintw ( WINDOW* win, char* fmt, va_list varglist ) ;
|
||||
FUNCTION: int vw_printw ( WINDOW* win, char* fmt, va_list varglist ) ;
|
||||
|
||||
FUNCTION: int move ( int y, int x ) ;
|
||||
FUNCTION: int wmove ( WINDOW* win, int y, int x ) ;
|
||||
|
||||
|
||||
FUNCTION: int scroll ( WINDOW* win ) ;
|
||||
FUNCTION: int scrl ( int n ) ;
|
||||
FUNCTION: int wscrl ( WINDOW* win, int n ) ;
|
||||
|
||||
! int setupterm(char *term, int fildes, int *errret);
|
||||
! int setterm(char *term);
|
||||
! TERMINAL *set_curterm(TERMINAL *nterm);
|
||||
! int del_curterm(TERMINAL *oterm);
|
||||
! int restartterm(const char *term, int fildes, int *errret);
|
||||
! char *tparm(char *str, ...);
|
||||
! int tputs(const char *str, int affcnt, int (*putc)(int));
|
||||
! int putp(const char *str);
|
||||
! int vidputs(chtype attrs, int (*putc)(int));
|
||||
! int vidattr(chtype attrs);
|
||||
! int vid_puts(attr_t attrs, short pair, void *opts, int (*putc)(char));
|
||||
! int vid_attr(attr_t attrs, short pair, void *opts);
|
||||
FUNCTION: int mvcur ( int oldrow, int oldcol, int newrow, int newcol ) ;
|
||||
! int tigetflag(char *capname);
|
||||
! int tigetnum(char *capname);
|
||||
! char *tigetstr(char *capname);
|
||||
|
||||
FUNCTION: int touchwin ( WINDOW* win ) ;
|
||||
FUNCTION: int touchline ( WINDOW* win, int start, int count ) ;
|
||||
FUNCTION: int untouchwin ( WINDOW* win ) ;
|
||||
FUNCTION: int wtouchln ( WINDOW* win, int y, int n, int changed ) ;
|
||||
FUNCTION: bool is_linetouched ( WINDOW* win, int line ) ;
|
||||
FUNCTION: bool is_wintouched ( WINDOW* win ) ;
|
||||
|
||||
FUNCTION: int insch ( chtype ch ) ;
|
||||
FUNCTION: int winsch ( WINDOW* win, chtype ch ) ;
|
||||
FUNCTION: int mvinsch ( int y, int x, chtype ch ) ;
|
||||
FUNCTION: int mvwinsch ( WINDOW* win, int y, int x, chtype ch ) ;
|
||||
FUNCTION: int delch ( ) ;
|
||||
FUNCTION: int wdelch ( WINDOW* win ) ;
|
||||
FUNCTION: int mvdelch ( int y, int x ) ;
|
||||
FUNCTION: int mvwdelch ( WINDOW* win, int y, int x ) ;
|
||||
|
||||
FUNCTION: int deleteln ( ) ;
|
||||
FUNCTION: int wdeleteln ( WINDOW* win ) ;
|
||||
FUNCTION: int insdelln ( int n ) ;
|
||||
FUNCTION: int winsdelln ( WINDOW* win, int n ) ;
|
||||
FUNCTION: int insertln ( ) ;
|
||||
FUNCTION: int winsertln ( WINDOW* win ) ;
|
||||
|
||||
FUNCTION: int addstr ( char* str ) ;
|
||||
FUNCTION: int addnstr ( char* str, int n ) ;
|
||||
FUNCTION: int waddstr ( WINDOW* win, char* str ) ;
|
||||
FUNCTION: int waddnstr ( WINDOW* win, char* str, int n ) ;
|
||||
FUNCTION: int mvaddstr ( int y, int x, char* str ) ;
|
||||
FUNCTION: int mvaddnstr ( int y, int x, char* str, int n ) ;
|
||||
FUNCTION: int mvwaddstr ( WINDOW* win, int y, int x, char* str ) ;
|
||||
FUNCTION: int mvwaddnstr ( WINDOW* win, int y, int x, char* str, int n ) ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
ncurses binding
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -4,9 +4,10 @@
|
|||
USING: accessors arrays assocs classes.tuple combinators
|
||||
compiler.units continuations debugger definitions help help.crossref
|
||||
help.markup help.topics io io.pathnames io.streams.string kernel lexer
|
||||
make math math.order memoize namespaces parser quotations prettyprint
|
||||
make math math.order memoize namespaces parser prettyprint quotations
|
||||
sequences sets sorting source-files strings summary tools.crossref
|
||||
tools.vocabs tools.vocabs.browser vectors vocabs vocabs.parser words ;
|
||||
tools.scaffold tools.vocabs tools.vocabs.browser vectors vocabs
|
||||
vocabs.loader vocabs.parser words ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
|
|
@ -69,13 +70,15 @@ M: integer fuel-pprint pprint ; inline
|
|||
|
||||
M: string fuel-pprint pprint ; inline
|
||||
|
||||
M: sequence fuel-pprint
|
||||
"(" write [ " " write ] [ fuel-pprint ] interleave ")" write ; inline
|
||||
: fuel-pprint-sequence ( seq open close -- )
|
||||
[ write ] dip swap [ " " write ] [ fuel-pprint ] interleave write ; inline
|
||||
|
||||
M: sequence fuel-pprint "(" ")" fuel-pprint-sequence ; inline
|
||||
|
||||
M: quotation fuel-pprint "[" "]" fuel-pprint-sequence ; inline
|
||||
|
||||
M: tuple fuel-pprint tuple>array fuel-pprint ; inline
|
||||
|
||||
M: quotation fuel-pprint pprint ; inline
|
||||
|
||||
M: continuation fuel-pprint drop ":continuation" write ; inline
|
||||
|
||||
M: restart fuel-pprint name>> fuel-pprint ; inline
|
||||
|
|
@ -328,7 +331,7 @@ SYMBOL: vocab-list
|
|||
[ describe-words ] with-string-writer \ describe-words swap 2array ; inline
|
||||
|
||||
: (fuel-vocab-help) ( name -- element )
|
||||
\ article swap dup >vocab-link
|
||||
dup require \ article swap dup >vocab-link
|
||||
[
|
||||
{
|
||||
[ vocab-authors [ \ $authors prefix , ] when* ]
|
||||
|
|
@ -358,13 +361,24 @@ MEMO: (fuel-get-vocabs/author) ( author -- element )
|
|||
: fuel-get-vocabs/author ( author -- )
|
||||
(fuel-get-vocabs/author) fuel-eval-set-result ;
|
||||
|
||||
MEMO: (fuel-get-vocabs/tag ( tag -- element )
|
||||
MEMO: (fuel-get-vocabs/tag) ( tag -- element )
|
||||
[ "Vocabularies tagged " prepend \ $heading swap 2array ]
|
||||
[ tagged fuel-vocab-list ] bi 2array ;
|
||||
|
||||
: fuel-get-vocabs/tag ( tag -- )
|
||||
(fuel-get-vocabs/tag fuel-eval-set-result ;
|
||||
(fuel-get-vocabs/tag) fuel-eval-set-result ;
|
||||
|
||||
! Scaffold support
|
||||
|
||||
: fuel-scaffold-vocab ( root name devname -- )
|
||||
developer-name set
|
||||
[ scaffold-vocab ] 2keep [ (normalize-path) ] dip dup
|
||||
append-path append-path ".factor" append fuel-eval-set-result ;
|
||||
|
||||
: fuel-scaffold-help ( name devname -- )
|
||||
developer-name set
|
||||
dup require dup scaffold-help vocab-docs-path
|
||||
(normalize-path) fuel-eval-set-result ;
|
||||
|
||||
! -run=fuel support
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,446 @@
|
|||
|
||||
USING: accessors combinators.cleave combinators.short-circuit
|
||||
concurrency.combinators destructors fry io io.directories
|
||||
io.encodings io.encodings.utf8 io.launcher io.pathnames
|
||||
io.pipes io.ports kernel locals math namespaces sequences
|
||||
splitting strings ui ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.editors ui.gadgets.labels ui.gadgets.packs
|
||||
ui.gadgets.tracks ;
|
||||
|
||||
IN: git-status
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: head** ( seq obj -- seq/f ) dup number? [ head ] [ dupd find drop head ] if ;
|
||||
|
||||
: tail** ( seq obj -- seq/f )
|
||||
dup number?
|
||||
[ tail ]
|
||||
[ dupd find drop [ tail ] [ drop f ] if* ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: <process-stdout-stderr-reader> ( DESC -- process stream stream )
|
||||
[
|
||||
[let | STDOUT-PIPE [ (pipe) |dispose ]
|
||||
STDERR-PIPE [ (pipe) |dispose ] |
|
||||
|
||||
[let | PROCESS [ DESC >process ] |
|
||||
|
||||
PROCESS
|
||||
[ STDOUT-PIPE out>> or ] change-stdout
|
||||
[ STDERR-PIPE out>> or ] change-stderr
|
||||
run-detached
|
||||
|
||||
STDOUT-PIPE out>> dispose
|
||||
STDERR-PIPE out>> dispose
|
||||
|
||||
STDOUT-PIPE in>> <input-port> utf8 <decoder>
|
||||
STDERR-PIPE in>> <input-port> utf8 <decoder> ] ]
|
||||
]
|
||||
with-destructors ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: run-process/result ( desc -- process )
|
||||
<process-stdout-stderr-reader>
|
||||
{
|
||||
[ contents [ string-lines ] [ f ] if* ]
|
||||
[ contents [ string-lines ] [ f ] if* ]
|
||||
}
|
||||
parallel-spread
|
||||
[ >>stdout ] [ >>stderr ] bi*
|
||||
dup wait-for-process >>status ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! process popup windows
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: popup-window ( title contents -- )
|
||||
dup string? [ ] [ "\n" join ] if
|
||||
<editor> tuck set-editor-string swap open-window ;
|
||||
|
||||
: popup-process-window ( process -- )
|
||||
[ stdout>> [ "output" swap popup-window ] when* ]
|
||||
[ stderr>> [ "error" swap popup-window ] when* ]
|
||||
[
|
||||
[ stdout>> ] [ stderr>> ] bi or not
|
||||
[ "Process" "NO OUTPUT" popup-window ]
|
||||
when
|
||||
]
|
||||
tri ;
|
||||
|
||||
: popup-if-error ( process -- )
|
||||
{ [ status>> 0 = not ] [ popup-process-window t ] } 1&& drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: git-process ( REPO DESC -- process )
|
||||
REPO [ DESC run-process/result ] with-directory ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: git-status-section ( lines section -- lines/f )
|
||||
'[ _ = ] tail**
|
||||
[
|
||||
[ "#\t" head? ] tail**
|
||||
[ "#\t" head? not ] head**
|
||||
[ 2 tail ] map
|
||||
]
|
||||
[ f ]
|
||||
if* ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: colon ( -- ch ) CHAR: : ;
|
||||
: space ( -- ch ) 32 ;
|
||||
|
||||
: git-status-line-file ( line -- file )
|
||||
{ [ colon = ] 1 [ space = not ] } [ tail** ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <git-status>
|
||||
repository
|
||||
to-commit-new
|
||||
to-commit-modified
|
||||
to-commit-deleted
|
||||
modified
|
||||
deleted
|
||||
untracked ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: check-empty ( seq -- seq/f ) dup empty? [ drop f ] when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: refresh-git-status ( GIT-STATUS -- GIT-STATUS )
|
||||
|
||||
[let | LINES [ GIT-STATUS repository>> "git-status" git-process stdout>> ] |
|
||||
|
||||
GIT-STATUS
|
||||
|
||||
LINES "# Changes to be committed:" git-status-section
|
||||
[ "new file:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>to-commit-new
|
||||
|
||||
LINES "# Changes to be committed:" git-status-section
|
||||
[ "modified:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>to-commit-modified
|
||||
|
||||
LINES "# Changes to be committed:" git-status-section
|
||||
[ "deleted:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>to-commit-deleted
|
||||
|
||||
LINES "# Changed but not updated:" git-status-section
|
||||
[ "modified:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>modified
|
||||
|
||||
LINES "# Changed but not updated:" git-status-section
|
||||
[ "deleted:" head? ] filter
|
||||
[ git-status-line-file ] map
|
||||
check-empty
|
||||
>>deleted
|
||||
|
||||
LINES "# Untracked files:" git-status-section >>untracked ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: git-status ( REPO -- <git-status> )
|
||||
|
||||
<git-status> new REPO >>repository refresh-git-status ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: factor-git-status ( -- <git-status> ) "resource:" git-status ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! git-tool
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: to-commit ( <git-status> -- seq )
|
||||
{ to-commit-new>> to-commit-modified>> to-commit-deleted>> } 1arr concat ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: refresh-status-pile ( STATUS PILE -- )
|
||||
|
||||
STATUS refresh-git-status drop
|
||||
|
||||
PILE clear-gadget
|
||||
|
||||
PILE
|
||||
|
||||
! Commit section
|
||||
|
||||
[wlet | add-commit-path-button [| TEXT PATH |
|
||||
|
||||
{ 1 0 } <track>
|
||||
|
||||
TEXT <label> 2/8 track-add
|
||||
PATH <label> 6/8 track-add
|
||||
|
||||
"Reset"
|
||||
[
|
||||
drop
|
||||
|
||||
STATUS repository>>
|
||||
{ "git" "reset" "HEAD" PATH }
|
||||
git-process
|
||||
drop
|
||||
|
||||
STATUS PILE refresh-status-pile
|
||||
]
|
||||
<bevel-button> f track-add
|
||||
|
||||
add-gadget ] |
|
||||
|
||||
STATUS to-commit
|
||||
[
|
||||
"Changes to be committed" <label> reverse-video-theme add-gadget
|
||||
|
||||
STATUS to-commit-new>>
|
||||
[| PATH | "new file: " PATH add-commit-path-button ]
|
||||
each
|
||||
|
||||
STATUS to-commit-modified>>
|
||||
[| PATH | "modified: " PATH add-commit-path-button ]
|
||||
each
|
||||
|
||||
STATUS to-commit-deleted>>
|
||||
[| PATH | "deleted: " PATH add-commit-path-button ]
|
||||
each
|
||||
|
||||
<pile> 1 >>fill
|
||||
|
||||
[let | EDITOR [ <editor> "COMMIT MESSAGE" over set-editor-string ] |
|
||||
|
||||
EDITOR add-gadget
|
||||
|
||||
"Commit"
|
||||
[
|
||||
drop
|
||||
[let | MSG [ EDITOR editor-string ] |
|
||||
|
||||
STATUS repository>>
|
||||
{ "git" "commit" "-m" MSG } git-process
|
||||
popup-if-error ]
|
||||
STATUS PILE refresh-status-pile
|
||||
]
|
||||
<bevel-button>
|
||||
add-gadget ]
|
||||
|
||||
add-gadget
|
||||
|
||||
]
|
||||
when ]
|
||||
|
||||
! Modified section
|
||||
|
||||
STATUS modified>>
|
||||
[
|
||||
"Modified but not updated" <label> reverse-video-theme add-gadget
|
||||
|
||||
STATUS modified>>
|
||||
[| PATH |
|
||||
|
||||
<shelf>
|
||||
|
||||
PATH <label> add-gadget
|
||||
|
||||
"Add"
|
||||
[
|
||||
drop
|
||||
STATUS repository>> { "git" "add" PATH } git-process popup-if-error
|
||||
STATUS PILE refresh-status-pile
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
"Diff"
|
||||
[
|
||||
drop
|
||||
STATUS repository>> { "git-diff" PATH } git-process
|
||||
popup-process-window
|
||||
]
|
||||
<bevel-button> add-gadget
|
||||
|
||||
add-gadget
|
||||
|
||||
]
|
||||
each
|
||||
|
||||
]
|
||||
when
|
||||
|
||||
! Untracked section
|
||||
|
||||
STATUS untracked>>
|
||||
[
|
||||
"Untracked files" <label> reverse-video-theme add-gadget
|
||||
|
||||
STATUS untracked>>
|
||||
[| PATH |
|
||||
|
||||
{ 1 0 } <track>
|
||||
|
||||
PATH <label> f track-add
|
||||
|
||||
"Add"
|
||||
[
|
||||
drop
|
||||
STATUS repository>> { "git" "add" PATH } git-process popup-if-error
|
||||
STATUS PILE refresh-status-pile
|
||||
]
|
||||
<bevel-button> f track-add
|
||||
|
||||
add-gadget
|
||||
|
||||
]
|
||||
each
|
||||
|
||||
]
|
||||
when
|
||||
|
||||
! Refresh button
|
||||
|
||||
"Refresh" [ drop STATUS PILE refresh-status-pile ] <bevel-button> add-gadget
|
||||
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: git-remote-branches ( REPO NAME -- seq )
|
||||
REPO { "git-remote" "show" NAME } git-process stdout>>
|
||||
" Tracked remote branches" over index 1 + tail first " " split
|
||||
[ empty? not ] filter ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: refresh-remotes-pile ( REPO PILE -- )
|
||||
|
||||
PILE clear-gadget
|
||||
|
||||
PILE
|
||||
|
||||
"Remotes" <label> reverse-video-theme add-gadget
|
||||
|
||||
REPO "git-remote" git-process stdout>> [ empty? not ] filter
|
||||
|
||||
[| NAME |
|
||||
|
||||
[let | BRANCH! [ "master" ] |
|
||||
|
||||
{ 1 0 } <track>
|
||||
|
||||
NAME <label> 1 track-add
|
||||
|
||||
[let | BRANCH-BUTTON [ "master" [ drop ] <bevel-button> ] |
|
||||
|
||||
BRANCH-BUTTON
|
||||
[
|
||||
drop
|
||||
|
||||
<pile>
|
||||
|
||||
1 >>fill
|
||||
|
||||
REPO NAME git-remote-branches
|
||||
[| OTHER-BRANCH |
|
||||
OTHER-BRANCH
|
||||
[
|
||||
drop
|
||||
|
||||
OTHER-BRANCH BRANCH!
|
||||
|
||||
OTHER-BRANCH BRANCH-BUTTON gadget-child set-label-string
|
||||
|
||||
]
|
||||
<bevel-button>
|
||||
add-gadget
|
||||
]
|
||||
each
|
||||
|
||||
"Select a branch" open-window
|
||||
]
|
||||
>>quot
|
||||
|
||||
1 track-add ]
|
||||
|
||||
"Fetch"
|
||||
[ drop REPO { "git-fetch" NAME } git-process popup-process-window ]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
"..remote/branch"
|
||||
[
|
||||
drop
|
||||
[let | ARG [ { ".." NAME "/" BRANCH } concat ] |
|
||||
REPO { "git-log" ARG } git-process popup-process-window ]
|
||||
]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
"Merge"
|
||||
[
|
||||
drop
|
||||
[let | ARG [ { NAME "/" BRANCH } concat ] |
|
||||
REPO { "git-merge" ARG } git-process popup-process-window ]
|
||||
]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
"remote/branch.."
|
||||
[
|
||||
drop
|
||||
[let | ARG [ { NAME "/" BRANCH ".." } concat ] |
|
||||
REPO { "git-log" ARG } git-process popup-process-window ]
|
||||
]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
"Push"
|
||||
[
|
||||
drop
|
||||
REPO { "git-push" NAME "master" } git-process popup-process-window
|
||||
]
|
||||
<bevel-button>
|
||||
1 track-add
|
||||
|
||||
add-gadget ]
|
||||
|
||||
]
|
||||
each
|
||||
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: git-tool ( REPO -- )
|
||||
|
||||
<pile> 1 >>fill
|
||||
|
||||
"Repository: " REPO [ current-directory get ] with-directory append
|
||||
<label>
|
||||
add-gadget
|
||||
|
||||
REPO git-status <pile> 1 >>fill tuck refresh-status-pile add-gadget
|
||||
REPO <pile> 1 >>fill tuck refresh-remotes-pile add-gadget
|
||||
|
||||
"Git" open-window ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: factor-git-tool ( -- ) "resource:" git-tool ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -43,6 +43,26 @@ beast.
|
|||
Many aspects of the environment can be customized:
|
||||
M-x customize-group fuel will show you how many.
|
||||
|
||||
*** Faster listener startup
|
||||
|
||||
On startup, run-factor loads the fuel vocabulary, which can take a
|
||||
while. If you want to speedup the load process, type 'save' in the
|
||||
listener prompt just after invoking run-factor. This will save a
|
||||
factor image (overwriting the current one) with all the needed
|
||||
vocabs.
|
||||
|
||||
*** Vocabulary creation
|
||||
|
||||
FUEL offers a basic interface with Factor's scaffolding utilities.
|
||||
To create a new vocabulary directory and associated files:
|
||||
|
||||
M-x fuel-scaffold-vocab
|
||||
|
||||
and when in a vocab file, to create a docs file with boilerplate
|
||||
for each word:
|
||||
|
||||
M-x fuel-scaffold-help
|
||||
|
||||
* Quick key reference
|
||||
|
||||
(Triple chords ending in a single letter <x> accept also C-<x> (e.g.
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ code in the buffer."
|
|||
(= (- be (point)) (current-indentation))
|
||||
(= ln (line-number-at-pos be)))
|
||||
(fuel-syntax--indentation-at bs))
|
||||
((or (fuel-syntax--is-eol bs)
|
||||
((or (fuel-syntax--is-last-char bs)
|
||||
(not (eq ?\ (char-after (1+ bs)))))
|
||||
(fuel-syntax--increased-indentation
|
||||
(fuel-syntax--indentation-at bs)))
|
||||
|
|
@ -238,15 +238,17 @@ code in the buffer."
|
|||
|
||||
;;; Keymap:
|
||||
|
||||
(defun factor-mode-insert-and-indent (n)
|
||||
(interactive "p")
|
||||
(defun factor-mode--insert-and-indent (n)
|
||||
(interactive "*p")
|
||||
(let ((start (point)))
|
||||
(self-insert-command n)
|
||||
(save-excursion (font-lock-fontify-region start (point))))
|
||||
(indent-according-to-mode))
|
||||
|
||||
(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 [?\]] '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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fu.el --- Startup file for FUEL
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
|
|
@ -24,6 +24,11 @@
|
|||
"Minor mode showing in the minibuffer a synopsis of Factor word at point."
|
||||
t)
|
||||
|
||||
(autoload 'fuel-scaffold-vocab "fuel-scaffold.el"
|
||||
"Create a new Factor vocabulary." t)
|
||||
|
||||
(autoload 'fuel-scaffold-help "fuel-scaffold.el"
|
||||
"Create a Factor vocabulary help file." t)
|
||||
|
||||
|
||||
;;; fu.el ends here
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@
|
|||
(factor (case sexp
|
||||
(:rs 'fuel-eval-restartable)
|
||||
(:nrs 'fuel-eval-non-restartable)
|
||||
(:in (fuel-syntax--current-vocab))
|
||||
(:in (or (fuel-syntax--current-vocab) "fuel"))
|
||||
(:usings `(:array ,@(fuel-syntax--usings)))
|
||||
(:get 'fuel-eval-set-result)
|
||||
(:end '\;)
|
||||
|
|
@ -70,7 +70,7 @@
|
|||
(defsubst factor--fuel-in (in)
|
||||
(cond ((or (eq in :in) (null in)) :in)
|
||||
((eq in 'f) 'f)
|
||||
((eq in 't) "fuel-scratchpad")
|
||||
((eq in 't) "fuel")
|
||||
((stringp in) in)
|
||||
(t (error "Invalid 'in' (%s)" in))))
|
||||
|
||||
|
|
|
|||
|
|
@ -54,6 +54,9 @@
|
|||
factor-font-lock font-lock factor-mode
|
||||
((comment comment "comments")
|
||||
(constructor type "constructors (<foo>)")
|
||||
(constant constant "constants and literal values")
|
||||
(number constant "integers and floats")
|
||||
(ratio constant "ratios")
|
||||
(declaration keyword "declaration words")
|
||||
(parsing-word keyword "parsing words")
|
||||
(setter-word function-name "setter words (>>foo)")
|
||||
|
|
@ -73,17 +76,23 @@
|
|||
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
|
||||
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
|
||||
(,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
|
||||
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
|
||||
(,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration)
|
||||
(,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
|
||||
(,fuel-syntax--alias-definition-regex (1 'factor-font-lock-word)
|
||||
(2 'factor-font-lock-word))
|
||||
(,fuel-syntax--int-constant-def-regex 2 'factor-font-lock-constant)
|
||||
(,fuel-syntax--integer-regex . 'factor-font-lock-number)
|
||||
(,fuel-syntax--float-regex . 'factor-font-lock-number)
|
||||
(,fuel-syntax--ratio-regex . 'factor-font-lock-ratio)
|
||||
(,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-name)
|
||||
(,fuel-syntax--parent-type-regex 2 'factor-font-lock-type-name)
|
||||
(,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
|
||||
(,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
|
||||
(,fuel-syntax--getter-regex . 'factor-font-lock-getter-word)
|
||||
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
|
||||
(,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name))
|
||||
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol))
|
||||
"Font lock keywords definition for Factor mode.")
|
||||
|
||||
(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
|
||||
|
|
@ -98,7 +107,6 @@
|
|||
(list (cons 'font-lock-syntactic-keywords
|
||||
fuel-syntax--syntactic-keywords))))))
|
||||
|
||||
|
||||
|
||||
;;; Fontify strings as Factor code:
|
||||
|
||||
|
|
|
|||
|
|
@ -102,6 +102,8 @@ buffer."
|
|||
|
||||
(defun fuel-listener-nuke ()
|
||||
(interactive)
|
||||
(goto-char (point-max))
|
||||
(comint-kill-region comint-last-input-start (point))
|
||||
(comint-redirect-cleanup)
|
||||
(fuel-con--setup-connection fuel-listener--buffer))
|
||||
|
||||
|
|
|
|||
|
|
@ -373,10 +373,10 @@
|
|||
(let ((heading `($heading ,(match-string-no-properties 0)))
|
||||
(rows))
|
||||
(forward-line)
|
||||
(when (looking-at "Word *Stack effect$")
|
||||
(push '("Word" "Stack effect") rows)
|
||||
(when (looking-at "Word *\\(Stack effect\\|Syntax\\)$")
|
||||
(push (list "Word" (match-string-no-properties 1)) rows)
|
||||
(forward-line))
|
||||
(while (looking-at "\\(.+?\\)\\( +\\(( .*\\)\\)?$")
|
||||
(while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$")
|
||||
(let ((word `($link ,(match-string-no-properties 1)
|
||||
,(match-string-no-properties 1)
|
||||
word))
|
||||
|
|
|
|||
|
|
@ -32,7 +32,13 @@
|
|||
(insert word)
|
||||
(indent-region begin (point))
|
||||
(set-mark (point))
|
||||
(fuel-syntax--beginning-of-defun)
|
||||
(let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point)))
|
||||
(end (save-excursion
|
||||
(re-search-backward fuel-syntax--end-of-def-regex nil t)
|
||||
(forward-line 1)
|
||||
(skip-syntax-forward "-")
|
||||
(point))))
|
||||
(goto-char (max beg end)))
|
||||
(open-line 1)
|
||||
(let ((start (point)))
|
||||
(insert ": " word " " stack-effect "\n" code " ;\n")
|
||||
|
|
|
|||
|
|
@ -0,0 +1,84 @@
|
|||
;;; fuel-scaffold.el -- interaction with tools.scaffold
|
||||
|
||||
;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Sun Jan 11, 2009 18:40
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; Utilities for creating new vocabulary files and other boilerplate.
|
||||
;; Mainly, an interface to Factor's tools.scaffold.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-edit)
|
||||
(require 'fuel-syntax)
|
||||
(require 'fuel-base)
|
||||
|
||||
|
||||
;;; Customisation:
|
||||
|
||||
(defgroup fuel-scaffold nil
|
||||
"Options for FUEL's scaffolding."
|
||||
:group 'fuel)
|
||||
|
||||
(defcustom fuel-scaffold-developer-name user-full-name
|
||||
"The name to be inserted as yours in scaffold templates."
|
||||
:type 'string
|
||||
:group 'fuel-scaffold)
|
||||
|
||||
|
||||
;;; Auxiliary functions:
|
||||
|
||||
(defun fuel-scaffold--vocab-roots ()
|
||||
(let ((cmd '(:fuel* (vocab-roots get :get) "fuel")))
|
||||
(fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
|
||||
|
||||
;;; User interface:
|
||||
|
||||
(defun fuel-scaffold-vocab ()
|
||||
"Creates a directory in the given root for a new vocabulary and
|
||||
adds source, tests and authors.txt files.
|
||||
|
||||
You can configure `fuel-scaffold-developer-name' (set by default to
|
||||
`user-full-name') for the name to be inserted in the generated files."
|
||||
(interactive)
|
||||
(let* ((name (read-string "Vocab name: "))
|
||||
(root (completing-read "Vocab root: "
|
||||
(fuel-scaffold--vocab-roots)
|
||||
nil t "resource:"))
|
||||
(cmd `(:fuel* ((,root ,name ,fuel-scaffold-developer-name)
|
||||
(fuel-scaffold-vocab)) "fuel"))
|
||||
(ret (fuel-eval--send/wait cmd))
|
||||
(file (fuel-eval--retort-result ret)))
|
||||
(unless file
|
||||
(error "Error creating vocab (%s)" (car (fuel-eval--retort-error ret))))
|
||||
(find-file file)
|
||||
(goto-char (point-max))))
|
||||
|
||||
(defun fuel-scaffold-help (&optional arg)
|
||||
"Creates, if it does not already exist, a help file with
|
||||
scaffolded help for each word in the current vocabulary.
|
||||
|
||||
With prefix argument, ask for the vocabulary name.
|
||||
You can configure `fuel-scaffold-developer-name' (set by default to
|
||||
`user-full-name') for the name to be inserted in the generated file."
|
||||
(interactive "P")
|
||||
(let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
|
||||
(fuel-edit--read-vocabulary-name nil)))
|
||||
(cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
|
||||
"fuel"))
|
||||
(ret (fuel-eval--send/wait cmd))
|
||||
(file (fuel-eval--retort-result ret)))
|
||||
(unless file
|
||||
(error "Error creating help file" (car (fuel-eval--retort-error ret))))
|
||||
(find-file file)))
|
||||
|
||||
|
||||
(provide 'fuel-scaffold)
|
||||
;;; fuel-scaffold.el ends here
|
||||
|
|
@ -44,28 +44,36 @@
|
|||
|
||||
(defconst fuel-syntax--parsing-words
|
||||
'(":" "::" ";" "<<" "<PRIVATE" ">>"
|
||||
"B" "BIN:" "C:" "C-STRUCT:" "C-UNION:" "CHAR:"
|
||||
"DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
|
||||
"GENERIC#" "GENERIC:" "HEX:" "HOOK:"
|
||||
"IN:" "INSTANCE:" "INTERSECTION:"
|
||||
"ABOUT:" "ALIAS:" "ARTICLE:"
|
||||
"B" "BIN:"
|
||||
"C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
|
||||
"DEFER:"
|
||||
"ERROR:" "EXCLUDE:"
|
||||
"f" "FORGET:" "FROM:"
|
||||
"GENERIC#" "GENERIC:"
|
||||
"HELP:" "HEX:" "HOOK:"
|
||||
"IN:" "initial:" "INSTANCE:" "INTERSECTION:"
|
||||
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
|
||||
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
|
||||
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
|
||||
"OCT:"
|
||||
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
|
||||
"QUALIFIED-WITH:" "QUALIFIED:"
|
||||
"read-only" "RENAME:" "REQUIRE:" "REQUIRES:"
|
||||
"SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:"
|
||||
"TUPLE:" "t" "t?" "TYPEDEF:"
|
||||
"UNION:" "USE:" "USING:" "VARS:"
|
||||
"call-next-method" "delimiter" "f" "initial:" "read-only"))
|
||||
|
||||
(defconst fuel-syntax--bracers
|
||||
'("B" "BV" "C" "CS" "H" "T" "V" "W"))
|
||||
"UNION:" "USE:" "USING:"
|
||||
"VARS:"))
|
||||
|
||||
(defconst fuel-syntax--parsing-words-regex
|
||||
(regexp-opt fuel-syntax--parsing-words 'words))
|
||||
|
||||
(defconst fuel-syntax--bracers
|
||||
'("B" "BV" "C" "CS" "H" "T" "V" "W"))
|
||||
|
||||
(defconst fuel-syntax--brace-words-regex
|
||||
(format "%s{" (regexp-opt fuel-syntax--bracers t)))
|
||||
|
||||
(defconst fuel-syntax--declaration-words
|
||||
'("flushable" "foldable" "inline" "parsing" "recursive"))
|
||||
'("flushable" "foldable" "inline" "parsing" "recursive" "delimiter"))
|
||||
|
||||
(defconst fuel-syntax--declaration-words-regex
|
||||
(regexp-opt fuel-syntax--declaration-words 'words))
|
||||
|
|
@ -76,13 +84,35 @@
|
|||
(defconst fuel-syntax--method-definition-regex
|
||||
"^M: +\\([^ ]+\\) +\\([^ ]+\\)")
|
||||
|
||||
(defconst fuel-syntax--integer-regex
|
||||
"\\_<-?[0-9]+\\_>")
|
||||
|
||||
(defconst fuel-syntax--ratio-regex
|
||||
"\\_<-?\\([0-9]+\\+\\)?[0-9]+/-?[0-9]+\\_>")
|
||||
|
||||
(defconst fuel-syntax--float-regex
|
||||
"\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>")
|
||||
|
||||
(defconst fuel-syntax--word-definition-regex
|
||||
(fuel-syntax--second-word-regex '(":" "::" "GENERIC:")))
|
||||
(fuel-syntax--second-word-regex
|
||||
'(":" "::" "GENERIC:" "DEFER:" "HOOK:" "MAIN:" "MATH:" "POSTPONE:"
|
||||
"SYMBOL:" "RENAME:")))
|
||||
|
||||
(defconst fuel-syntax--alias-definition-regex
|
||||
"^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
|
||||
|
||||
(defconst fuel-syntax--vocab-ref-regexp
|
||||
(fuel-syntax--second-word-regex
|
||||
'("IN:" "USE:" "FROM:" "EXCLUDE:" "QUALIFIED:" "QUALIFIED-WITH:")))
|
||||
|
||||
(defconst fuel-syntax--int-constant-def-regex
|
||||
(fuel-syntax--second-word-regex '("CHAR:" "BIN:" "HEX:" "OCT:")))
|
||||
|
||||
(defconst fuel-syntax--type-definition-regex
|
||||
(fuel-syntax--second-word-regex '("TUPLE:" "SINGLETON:")))
|
||||
(fuel-syntax--second-word-regex '("MIXIN:" "TUPLE:" "SINGLETON:" "UNION:")))
|
||||
|
||||
(defconst fuel-syntax--parent-type-regex "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
|
||||
(defconst fuel-syntax--parent-type-regex
|
||||
"^\\(TUPLE\\|PREDICTE\\): +[^ ]+ +< +\\([^ ]+\\)")
|
||||
|
||||
(defconst fuel-syntax--constructor-regex "<[^ >]+>")
|
||||
|
||||
|
|
@ -102,21 +132,39 @@
|
|||
|
||||
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
|
||||
|
||||
(defconst fuel-syntax--definition-starters-regex
|
||||
(regexp-opt
|
||||
'("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD" ":" "")))
|
||||
|
||||
(defconst fuel-syntax--definition-start-regex
|
||||
(format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
|
||||
(format "^\\(%s:\\) " (regexp-opt '("" ":"
|
||||
"FROM"
|
||||
"INTERSECTION:"
|
||||
"MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD"
|
||||
"PREDICATE" "PRIMITIVE"
|
||||
"SINGLETONS" "SYMBOLS"
|
||||
"TUPLE"
|
||||
"UNION"
|
||||
"VARS"))))
|
||||
|
||||
(defconst fuel-syntax--definition-end-regex
|
||||
(format "\\(\\(^\\| +\\);\\( *%s\\)*\\($\\| +\\)\\)"
|
||||
fuel-syntax--declaration-words-regex))
|
||||
|
||||
(defconst fuel-syntax--single-liner-regex
|
||||
(format "^%s" (regexp-opt '("C:" "DEFER:" "GENERIC:" "IN:"
|
||||
"PRIVATE>" "<PRIVATE"
|
||||
"SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
|
||||
(format "^%s" (regexp-opt '("ABOUT:"
|
||||
"ARTICLE:"
|
||||
"ALIAS:"
|
||||
"CONSTANT:" "C:"
|
||||
"DEFER:"
|
||||
"FORGET:"
|
||||
"GENERIC:" "GENERIC#"
|
||||
"HELP:" "HEX:" "HOOK:"
|
||||
"IN:" "INSTANCE:"
|
||||
"MAIN:" "MATH:" "MIXIN:"
|
||||
"OCT:"
|
||||
"POSTPONE:" "PRIVATE>" "<PRIVATE"
|
||||
"QUALIFIED-WITH:" "QUALIFIED:"
|
||||
"RENAME:"
|
||||
"SINGLETON:" "SLOT:" "SYMBOL:"
|
||||
"USE:"
|
||||
"VAR:"))))
|
||||
|
||||
(defconst fuel-syntax--begin-of-def-regex
|
||||
(format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
|
||||
|
|
@ -170,8 +218,7 @@
|
|||
(" \\(|\\) " (1 "(|"))
|
||||
(" \\(|\\)$" (1 ")"))
|
||||
;; Opening brace words:
|
||||
(,(format "\\_<%s\\({\\)\\_>" (regexp-opt fuel-syntax--bracers)) (1 "(}"))
|
||||
("\\_<\\({\\)\\_>" (1 "(}"))
|
||||
("\\_<\\w*\\({\\)\\_>" (1 "(}"))
|
||||
("\\_<\\(}\\)\\_>" (1 "){"))
|
||||
;; Parenthesis:
|
||||
("\\_<\\((\\)\\_>" (1 "()"))
|
||||
|
|
@ -215,7 +262,7 @@
|
|||
(defsubst fuel-syntax--looking-at-emptiness ()
|
||||
(looking-at "^[ ]*$\\|$"))
|
||||
|
||||
(defsubst fuel-syntax--is-eol (pos)
|
||||
(defsubst fuel-syntax--is-last-char (pos)
|
||||
(save-excursion
|
||||
(goto-char (1+ pos))
|
||||
(fuel-syntax--looking-at-emptiness)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue