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

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

db4
Joe Groff 2008-12-24 12:51:21 -08:00
parent e88781b73e 028d27a2cb
commit 9705778f4b
102 changed files with 2131 additions and 639 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/columns/columns.factor
View File

@ -9,7 +9,7 @@ TUPLE: column seq col ;
C: <column> column
M: column virtual-seq seq>> ;
M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
M: column length seq>> length ;
INSTANCE: column virtual-sequence

30
basis/core-foundation/run-loop/run-loop.factor
View File

@ -19,9 +19,9 @@ FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
FUNCTION: SInt32 CFRunLoopRunInMode (
CFStringRef mode,
CFTimeInterval seconds,
Boolean returnAfterSourceHandled
CFStringRef mode,
CFTimeInterval seconds,
Boolean returnAfterSourceHandled
) ;
FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
@ -31,27 +31,27 @@ FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
) ;
FUNCTION: void CFRunLoopAddSource (
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveSource (
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
) ;
FUNCTION: void CFRunLoopAddTimer (
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveTimer (
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
) ;
: CFRunLoopDefaultMode ( -- alien )

24
basis/core-foundation/strings/strings.factor
View File

@ -23,11 +23,11 @@ TYPEDEF: int CFStringEncoding
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
FUNCTION: CFStringRef CFStringCreateWithBytes (
CFAllocatorRef alloc,
UInt8* bytes,
CFIndex numBytes,
CFStringEncoding encoding,
Boolean isExternalRepresentation
CFAllocatorRef alloc,
UInt8* bytes,
CFIndex numBytes,
CFStringEncoding encoding,
Boolean isExternalRepresentation
) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
@ -35,16 +35,16 @@ FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
FUNCTION: Boolean CFStringGetCString (
CFStringRef theString,
char* buffer,
CFIndex bufferSize,
CFStringEncoding encoding
CFStringRef theString,
char* buffer,
CFIndex bufferSize,
CFStringEncoding encoding
) ;
FUNCTION: CFStringRef CFStringCreateWithCString (
CFAllocatorRef alloc,
char* cStr,
CFStringEncoding encoding
CFAllocatorRef alloc,
char* cStr,
CFStringEncoding encoding
) ;
: <CFString> ( string -- alien )

4
basis/disjoint-sets/disjoint-sets.factor
View File

@ -60,8 +60,8 @@ GENERIC: add-atom ( a disjoint-set -- )
M: disjoint-set add-atom
[ dupd parents>> set-at ]
[ 0 -rot ranks>> set-at ]
[ 1 -rot counts>> set-at ]
[ [ 0 ] 2dip ranks>> set-at ]
[ [ 1 ] 2dip counts>> set-at ]
2tri ;
: add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ;

20
basis/documents/documents.factor
View File

@ -153,18 +153,18 @@ GENERIC: next-elt ( loc document elt -- newloc )
TUPLE: char-elt ;
: (prev-char) ( loc document quot -- loc )
-rot {
{ [ over { 0 0 } = ] [ drop ] }
{ [ over second zero? ] [ [ first 1- ] dip line-end ] }
[ pick call ]
} cond nip ; inline
{
{ [ pick { 0 0 } = ] [ 2drop ] }
{ [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
[ call ]
} cond ; inline
: (next-char) ( loc document quot -- loc )
-rot {
{ [ 2dup doc-end = ] [ drop ] }
{ [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
[ pick call ]
} cond nip ; inline
{
{ [ 2over doc-end = ] [ 2drop ] }
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
[ call ]
} cond ; inline
M: char-elt prev-elt
drop [ drop -1 +col ] (prev-char) ;

6
basis/formatting/formatting-tests.factor
View File

@ -85,13 +85,13 @@ IN: formatting.tests
[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
[ t ] [ "10/09/08" testtime "%m/%d/%y" strftime = ] unit-test
[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
[ t ] [ "October" testtime "%B" strftime = ] unit-test
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
[ t ] [ "PM" testtime "%p" strftime = ] unit-test

41
basis/formatting/formatting.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays ascii calendar combinators fry kernel
io io.encodings.ascii io.files io.streams.string
generalizations io io.encodings.ascii io.files io.streams.string
macros math math.functions math.parser peg.ebnf quotations
sequences splitting strings unicode.case vectors ;
@ -32,10 +32,7 @@ IN: formatting
[ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
: max-digits ( n digits -- n' )
10 swap ^ [ * round ] keep / ;
: max-width ( string length -- string' )
short head ;
10 swap ^ [ * round ] keep / ; inline
: >exp ( x -- exp base )
[
@ -69,7 +66,7 @@ pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 =
sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]]
width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]]
width_ = "." ([0-9])* => [[ second >digits '[ _ short head ] ]]
width = (width_)? => [[ [ ] or ]]
digits_ = "." ([0-9])* => [[ second >digits ]]
@ -113,23 +110,25 @@ MACRO: printf ( format-string -- )
<PRIVATE
: zero-pad ( str -- str' ) 2 CHAR: 0 pad-left ; inline
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-left ; inline
: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline
: >time ( timestamp -- string )
[ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
[ number>string zero-pad ] map ":" join ; inline
[ pad-00 ] map ":" join ; inline
: >date ( timestamp -- string )
[ month>> ] [ day>> ] [ year>> ] tri 3array
[ number>string zero-pad ] map "/" join ; inline
[ pad-00 ] map "/" join ; inline
: >datetime ( timestamp -- string )
{ [ day-of-week day-abbreviation3 ]
[ month>> month-abbreviation ]
[ day>> number>string zero-pad ]
[ day>> pad-00 ]
[ >time ]
[ year>> number>string ]
} cleave 3array [ 2array ] dip append " " join ; inline
} cleave 5 narray " " join ; inline
: (week-of-year) ( timestamp day -- n )
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
@ -147,20 +146,20 @@ fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
fmt-B = "B" => [[ [ dup month>> month-name ] ]]
fmt-c = "c" => [[ [ dup >datetime ] ]]
fmt-d = "d" => [[ [ dup day>> number>string zero-pad ] ]]
fmt-H = "H" => [[ [ dup hour>> number>string zero-pad ] ]]
fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when number>string zero-pad ] ]]
fmt-j = "j" => [[ [ dup day-of-year number>string ] ]]
fmt-m = "m" => [[ [ dup month>> number>string zero-pad ] ]]
fmt-M = "M" => [[ [ dup minute>> number>string zero-pad ] ]]
fmt-d = "d" => [[ [ dup day>> pad-00 ] ]]
fmt-H = "H" => [[ [ dup hour>> pad-00 ] ]]
fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when pad-00 ] ]]
fmt-j = "j" => [[ [ dup day-of-year pad-000 ] ]]
fmt-m = "m" => [[ [ dup month>> pad-00 ] ]]
fmt-M = "M" => [[ [ dup minute>> pad-00 ] ]]
fmt-p = "p" => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]]
fmt-S = "S" => [[ [ dup second>> round number>string zero-pad ] ]]
fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]]
fmt-S = "S" => [[ [ dup second>> floor pad-00 ] ]]
fmt-U = "U" => [[ [ dup week-of-year-sunday pad-00 ] ]]
fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
fmt-W = "W" => [[ [ dup week-of-year-monday ] ]]
fmt-W = "W" => [[ [ dup week-of-year-monday pad-00 ] ]]
fmt-x = "x" => [[ [ dup >date ] ]]
fmt-X = "X" => [[ [ dup >time ] ]]
fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]]
fmt-y = "y" => [[ [ dup year>> 100 mod pad-00 ] ]]
fmt-Y = "Y" => [[ [ dup year>> number>string ] ]]
fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
unknown = (.)* => [[ "Unknown directive" throw ]]

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

@ -100,14 +100,12 @@ $nl
{ $code "10 [ \"Factor rocks!\" print ] times" }
"Now we can look at a new data type, the array:"
{ $code "{ 1 2 3 }" }
"An array looks like a quotation except it cannot be evaluated; it simply stores data."
"An array differs from a quotation in that it cannot be evaluated; it simply stores data."
$nl
"You can perform an operation on each element of an array:"
{ $example
"{ 1 2 3 } [ \"The number is \" write . ] each"
"The number is 1"
"The number is 2"
"The number is 3"
"The number is 1\nThe number is 2\nThe number is 3"
}
"You can transform each element, collecting the results in a new array:"
{ $example "{ 5 12 0 -12 -5 } [ sq ] map ." "{ 25 144 0 144 25 }" }

1
basis/help/help-tests.factor
View File

@ -3,3 +3,4 @@ USING: tools.test help kernel ;
[ 3 throw ] must-fail
[ ] [ :help ] unit-test
[ ] [ f print-topic ] unit-test

1
basis/help/help.factor
View File

@ -112,6 +112,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
] with-style nl ;
: print-topic ( topic -- )
>link
last-element off dup $title
article-content print-content nl ;

2
basis/http/server/cgi/cgi.factor
View File

@ -58,6 +58,8 @@ IN: http.server.cgi
] with-stream
] >>body ;
SLOT: special
: enable-cgi ( responder -- responder )
[ serve-cgi ] "application/x-cgi-script"
pick special>> set-at ;

6
basis/inspector/inspector.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays generic hashtables io kernel assocs math
namespaces prettyprint sequences strings io.styles vectors words
quotations mirrors splitting math.parser classes vocabs refs
sets sorting summary debugger continuations ;
sets sorting summary debugger continuations fry ;
IN: inspector
: value-editor ( path -- )
@ -53,7 +53,7 @@ SYMBOL: +editable+
[ drop ] [
dup enum? [ +sequence+ on ] when
standard-table-style [
swap [ -rot describe-row ] curry each-index
swap '[ [ _ ] 2dip describe-row ] each-index
] tabular-output
] if-empty ;
@ -64,7 +64,7 @@ M: tuple error. describe ;
: namestack. ( seq -- )
[ [ global eq? not ] filter [ keys ] gather ] keep
[ dupd assoc-stack ] curry H{ } map>assoc describe ;
'[ dup _ assoc-stack ] H{ } map>assoc describe ;
: .vars ( -- )
namestack namestack. ;

12
basis/io/backend/unix/unix-tests.factor
View File

@ -1,7 +1,7 @@
USING: io.files io.files.temp io.directories io.sockets io kernel threads
namespaces tools.test continuations strings byte-arrays
sequences prettyprint system io.encodings.binary io.encodings.ascii
io.streams.duplex destructors make ;
io.streams.duplex destructors make io.launcher ;
IN: io.backend.unix.tests
! Unix domain stream sockets
@ -138,3 +138,13 @@ datagram-client delete-file
input-stream get send
] with-file-reader
] must-fail
! closing stdin caused some problems
[ ] [
[
vm ,
"-i=" image append ,
"-run=none" ,
"-e=USING: destructors namespaces io calendar threads ; input-stream get dispose 1 seconds sleep" ,
] { } make try-process
] unit-test

19
basis/io/files/info/unix/linux/linux.factor
View File

@ -3,8 +3,9 @@
USING: accessors alien.c-types alien.syntax combinators csv
io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux
specialized-arrays.direct.uint arrays io.files.info.unix ;
system unix unix.statfs.linux unix.statvfs.linux io.files.links
specialized-arrays.direct.uint arrays io.files.info.unix assocs
io.pathnames ;
IN: io.files.info.unix.linux
TUPLE: linux-file-system-info < unix-file-system-info
@ -70,6 +71,16 @@ M: linux file-systems
} cleave
] map ;
: (find-mount-point) ( path mtab-paths -- mtab-entry )
[ follow-links ] dip 2dup at* [
2nip
] [
drop [ parent-directory ] dip (find-mount-point)
] if ;
: find-mount-point ( path -- mtab-entry )
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
ERROR: file-system-not-found ;
M: linux file-system-info ( path -- )
@ -80,9 +91,7 @@ M: linux file-system-info ( path -- )
[ file-system-statvfs statvfs>file-system-info ] bi
file-system-calculations
] keep
parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
[ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
find-mount-point
{
[ file-system-name>> >>device-name drop ]
[ mount-point>> >>mount-point drop ]

5
basis/io/files/info/windows/windows.factor
View File

@ -102,10 +102,7 @@ M: windows link-info ( path -- info )
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
{
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
[ ]
} cleave ;
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;

35
basis/io/files/links/links-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io.files.info ;
USING: help.markup help.syntax io.files.info math ;
IN: io.files.links
HELP: make-link
@ -13,11 +13,40 @@ HELP: copy-link
{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
{ $description "Copies a symbolic link without following the link." } ;
{ make-link read-link copy-link } related-words
HELP: follow-link
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Returns an absolute path from " { $link read-link } "." } ;
HELP: follow-links
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Follows a chain of symlinks up to " { $link symlink-depth } "." } ;
{ read-link follow-link follow-links } related-words
HELP: symlink-depth
{ $values
{ "value" integer }
}
{ $description "The number of redirections " { $link follow-links } " will follow." } ;
HELP: too-many-symlinks
{ $values
{ "path" "a pathname string" } { "n" integer }
}
{ $description "An error thrown when the number of redirections in a chain of symlinks surpasses the value in the " { $link symlink-depth } " variable." } ;
ARTICLE: "io.files.links" "Symbolic links"
"Reading and creating links:"
"Reading links:"
{ $subsection read-link }
{ $subsection follow-link }
{ $subsection follow-links }
"Creating links:"
{ $subsection make-link }
"Copying links:"
{ $subsection copy-link }

26
basis/io/files/links/links.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel vocabs.loader ;
USING: accessors io.backend io.files.info io.files.types
io.pathnames kernel math namespaces system vocabs.loader ;
IN: io.files.links
HOOK: make-link os ( target symlink -- )
@ -10,4 +11,25 @@ HOOK: read-link os ( symlink -- path )
: copy-link ( target symlink -- )
[ read-link ] dip make-link ;
os unix? [ "io.files.links.unix" require ] when
os unix? [ "io.files.links.unix" require ] when
: follow-link ( path -- path' )
[ parent-directory ] [ read-link ] bi append-path ;
SYMBOL: symlink-depth
10 symlink-depth set-global
ERROR: too-many-symlinks path n ;
<PRIVATE
: (follow-links) ( n path -- path' )
over 0 = [ symlink-depth get too-many-symlinks ] when
dup link-info type>> +symbolic-link+ =
[ [ 1- ] [ follow-link ] bi* (follow-links) ]
[ nip ] if ; inline recursive
PRIVATE>
: follow-links ( path -- path' )
[ symlink-depth get ] dip normalize-path (follow-links) ;

32
basis/io/files/links/unix/unix-tests.factor Normal file
View File

@ -0,0 +1,32 @@
USING: io.directories io.files.links tools.test sequences
io.files.unique tools.files fry math kernel math.parser
io.pathnames namespaces ;
IN: io.files.links.unix.tests
: make-test-links ( n path -- )
[ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ]
[ [ number>string ] dip prepend touch-file ] 2bi ; inline
[ t ] [
[
5 "lol" make-test-links
"lol1" follow-links
current-directory get "lol5" append-path =
] with-unique-directory
] unit-test
[
[
100 "laf" make-test-links "laf1" follow-links
] with-unique-directory
] [ too-many-symlinks? ] must-fail-with
[ t ] [
110 symlink-depth [
[
100 "laf" make-test-links
"laf1" follow-links
current-directory get "laf100" append-path =
] with-unique-directory
] with-variable
] unit-test

2
basis/io/files/links/unix/unix.factor
View File

@ -7,4 +7,4 @@ M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ;
M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ;
normalize-path read-symbolic-link ;

2
basis/logging/logging.factor
View File

@ -61,7 +61,7 @@ PRIVATE>
[ dup ] 2dip 2curry annotate ;
: call-logging-quot ( quot word level -- quot' )
"called" -rot [ log-message ] 3curry prepose ;
[ "called" ] 2dip [ log-message ] 3curry prepose ;
: add-logging ( word level -- )
[ call-logging-quot ] (define-logging) ;

2
basis/logging/parser/parser-docs.factor
View File

@ -13,7 +13,7 @@ HELP: parse-log
} ;
ARTICLE: "logging.parser" "Log file parser"
"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs."
"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $vocab-link "logging.insomniac" } " to analyze logs."
$nl
"There is only one primary entry point:"
{ $subsection parse-log } ;

17
basis/logging/server/server.factor
View File

@ -28,7 +28,7 @@ SYMBOL: log-files
: multiline-header ( -- string ) 20 CHAR: - <string> ; foldable
: (write-message) ( msg name>> level multi? -- )
: (write-message) ( msg word-name level multi? -- )
[
"[" write multiline-header write "] " write
] [
@ -36,18 +36,19 @@ SYMBOL: log-files
] if
write bl write ": " write print ;
: write-message ( msg name>> level -- )
rot harvest {
{ [ dup empty? ] [ 3drop ] }
{ [ dup length 1 = ] [ first -rot f (write-message) ] }
: write-message ( msg word-name level -- )
[ harvest ] 2dip {
{ [ pick empty? ] [ 3drop ] }
{ [ pick length 1 = ] [ [ first ] 2dip f (write-message) ] }
[
[ first -rot f (write-message) ] 3keep
rest -rot [ t (write-message) ] 2curry each
[ [ first ] 2dip f (write-message) ]
[ [ rest ] 2dip [ t (write-message) ] 2curry each ]
3bi
]
} cond ;
: (log-message) ( msg -- )
#! msg: { msg name>> level service }
#! msg: { msg word-name level service }
first4 log-stream [ write-message flush ] with-output-stream* ;
: try-dispose ( stream -- )

8
basis/math/ratios/ratios.factor
View File

@ -50,11 +50,11 @@ M: ratio <= scale <= ;
M: ratio > scale > ;
M: ratio >= scale >= ;
M: ratio + 2dup scale + -rot ratio+d / ;
M: ratio - 2dup scale - -rot ratio+d / ;
M: ratio * 2>fraction * [ * ] dip / ;
M: ratio + [ scale + ] [ ratio+d ] 2bi / ;
M: ratio - [ scale - ] [ ratio+d ] 2bi / ;
M: ratio * 2>fraction [ * ] 2bi@ / ;
M: ratio / scale / ;
M: ratio /i scale /i ;
M: ratio /f scale /f ;
M: ratio mod [ /i ] 2keep rot * - ;
M: ratio mod 2dup /i * - ;
M: ratio /mod [ /i ] 2keep mod ;

2
basis/mirrors/mirrors.factor
View File

@ -32,7 +32,7 @@ M: mirror set-at ( val key mirror -- )
swap set-slot ;
M: mirror delete-at ( key mirror -- )
f -rot set-at ;
[ f ] 2dip set-at ;
M: mirror clear-assoc ( mirror -- )
[ object>> ] [ object-slots ] bi [

24
basis/models/compose/compose-tests.factor
View File

@ -1,5 +1,5 @@
USING: arrays generic kernel math models namespaces sequences assocs
tools.test models.compose accessors ;
tools.test models.compose accessors locals ;
IN: models.compose.tests
! Test compose
@ -22,3 +22,25 @@ IN: models.compose.tests
[ { 4 5 } ] [ "c" get value>> ] unit-test
[ ] [ "c" get deactivate-model ] unit-test
TUPLE: an-observer { i integer } ;
M: an-observer model-changed nip [ 1+ ] change-i drop ;
[ 1 0 ] [
[let* | m1 [ 1 <model> ]
m2 [ 2 <model> ]
c [ { m1 m2 } <compose> ]
o1 [ an-observer new ]
o2 [ an-observer new ] |
o1 m1 add-connection
o2 m2 add-connection
c activate-model
"OH HAI" m1 set-model
o1 i>>
o2 i>>
]
] unit-test

3
basis/models/compose/compose.factor
View File

@ -18,7 +18,8 @@ TUPLE: compose < model ;
M: compose model-changed
nip
[ [ value>> ] composed-value ] keep set-model ;
dup [ value>> ] composed-value >>value
notify-connections ;
M: compose model-activated dup model-changed ;

7
basis/opengl/capabilities/capabilities.factor
View File

@ -1,14 +1,11 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make sequences splitting opengl.gl
continuations math.parser math arrays sets math.order ;
continuations math.parser math arrays sets math.order fry ;
IN: opengl.capabilities
: (require-gl) ( thing require-quot make-error-quot -- )
-rot dupd call
[ 2drop ]
[ swap " " make throw ]
if ; inline
[ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
: gl-extensions ( -- seq )
GL_EXTENSIONS glGetString " " split ;

20
basis/opengl/opengl.factor
View File

@ -6,7 +6,7 @@ USING: alien alien.c-types continuations kernel libc math macros
namespaces math.vectors math.constants math.functions
math.parser opengl.gl opengl.glu combinators arrays sequences
splitting words byte-arrays assocs colors accessors
generalizations locals specialized-arrays.float
generalizations locals fry specialized-arrays.float
specialized-arrays.uint ;
IN: opengl
@ -154,19 +154,21 @@ MACRO: all-enabled-client-state ( seq quot -- )
: delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ;
: with-gl-buffer ( binding id quot -- )
-rot dupd glBindBuffer
[ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
:: with-gl-buffer ( binding id quot -- )
binding id glBindBuffer
quot [ binding 0 glBindBuffer ] [ ] cleanup ; inline
: with-array-element-buffers ( array-buffer element-buffer quot -- )
-rot GL_ELEMENT_ARRAY_BUFFER swap [
swap GL_ARRAY_BUFFER -rot with-gl-buffer
[ GL_ELEMENT_ARRAY_BUFFER ] 2dip '[
GL_ARRAY_BUFFER swap _ with-gl-buffer
] with-gl-buffer ; inline
: <gl-buffer> ( target data hint -- id )
pick gen-gl-buffer [ [
[ dup byte-length swap ] dip glBufferData
] with-gl-buffer ] keep ;
pick gen-gl-buffer [
[
[ [ byte-length ] keep ] dip glBufferData
] with-gl-buffer
] keep ;
: buffer-offset ( int -- alien )
<alien> ; inline

3
basis/peg/parsers/parsers.factor
View File

@ -51,8 +51,7 @@ PRIVATE>
dup zero? [
2drop epsilon
] [
2dup exactly-n
-rot 1- at-most-n 2choice
[ exactly-n ] [ 1- at-most-n ] 2bi 2choice
] if ;
: at-least-n ( parser n -- parser' )

2
basis/peg/peg.factor
View File

@ -373,7 +373,7 @@ TUPLE: range-parser min max ;
pick empty? [
3drop f
] [
pick first -rot between? [
[ dup first ] 2dip between? [
unclip-slice <parse-result>
] [
drop f

10
basis/sequences/deep/deep.factor
View File

@ -14,11 +14,11 @@ M: object branch? drop f ;
: deep-each ( obj quot: ( elt -- ) -- )
[ call ] 2keep over branch?
[ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive
[ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive
: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
[ call ] keep over branch?
[ [ deep-map ] curry map ] [ drop ] if ; inline recursive
[ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
: deep-filter ( obj quot: ( elt -- ? ) -- seq )
over [ pusher [ deep-each ] dip ] dip
@ -27,7 +27,7 @@ M: object branch? drop f ;
: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
f -rot [ [ nip ] dip (deep-find) ] curry find drop >boolean
[ f ] 2dip '[ nip _ (deep-find) ] find drop >boolean
] [ 2drop f f ] if
] if ; inline recursive
@ -36,7 +36,7 @@ M: object branch? drop f ;
: deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
'[ @ not ] deep-contains? not ; inline
: deep-member? ( obj seq -- ? )
swap '[
@ -50,7 +50,7 @@ M: object branch? drop f ;
: deep-change-each ( obj quot: ( elt -- elt' ) -- )
over branch? [
[ [ call ] keep over [ deep-change-each ] dip ] curry change-each
'[ _ [ call ] keep over [ deep-change-each ] dip ] change-each
] [ 2drop ] if ; inline recursive
: flatten ( obj -- seq )

12
basis/struct-arrays/struct-arrays-tests.factor
View File

@ -1,6 +1,7 @@
IN: struct-arrays.tests
USING: struct-arrays tools.test kernel math sequences
alien.syntax alien.c-types destructors libc accessors ;
alien.syntax alien.c-types destructors libc accessors
destructors ;
C-STRUCT: test-struct
{ "int" "x" }
@ -27,3 +28,12 @@ C-STRUCT: test-struct
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
] with-destructors
] unit-test
[ ] [ ALIEN: 123 10 "test-struct" <direct-struct-array> drop ] unit-test
[ ] [
[
10 "test-struct" malloc-struct-array
underlying>> &free drop
] with-destructors
] unit-test

4
basis/struct-arrays/struct-arrays.factor
View File

@ -32,9 +32,9 @@ ERROR: bad-byte-array-length byte-array ;
] keep struct-array boa ; inline
: <direct-struct-array> ( alien length c-type -- struct-array )
struct-array boa ; inline
heap-size struct-array boa ; inline
: malloc-struct-array ( length c-type -- struct-array )
heap-size [ calloc ] 2keep <direct-struct-array> ;
[ heap-size calloc ] 2keep <direct-struct-array> ;
INSTANCE: struct-array sequence

2
basis/tools/deploy/macosx/macosx.factor
View File

@ -13,7 +13,7 @@ IN: tools.deploy.macosx
vm parent-directory parent-directory ;
: copy-bundle-dir ( bundle-name dir -- )
bundle-dir over append-path -rot
[ bundle-dir prepend-path swap ] keep
"Contents" prepend-path append-path copy-tree ;
: app-plist ( executable bundle-name -- assoc )

18
basis/tools/profiler/profiler-docs.factor
View File

@ -2,14 +2,18 @@ USING: tools.profiler.private tools.time help.markup help.syntax
quotations io strings words definitions ;
IN: tools.profiler
ARTICLE: "profiling" "Profiling code"
"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler is completely accurate with words and methods which are compiled with the non-optimizing compiler. Some optimizations performed by the optimizing compiler can inhibit accurate call counting, however:"
ARTICLE: "profiler-limitations" "Profiler limitations"
"Certain optimizations performed by the compiler can inhibit accurate call counting:"
{ $list
"The optimizing compiler open-codes certain primitives with inline machine code, and in some cases optimizes them out altogether; this includes stack shuffling operations, conditionals, and many object allocation operations."
{ "Calls to " { $link POSTPONE: inline } " words are not counted.." }
"Calls to open-coded intrinsics are not counted. Certain words are open-coded as inline machine code, and in some cases optimized out altogether; this includes stack shuffling operations, conditionals, and many object allocation operations."
{ "Calls to " { $link POSTPONE: inline } " words are not counted." }
{ "Calls to methods which were inlined as a result of type inference are not counted." }
"Tail-recursive loops will only count the initial invocation of the word, not every tail call."
}
} ;
ARTICLE: "profiling" "Profiling code"
"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler."
$nl
"Quotations can be passed to a combinator which calls them with the profiler enabled:"
{ $subsection profile }
"After a quotation has been profiled, call counts can be presented in various ways:"
@ -17,7 +21,9 @@ ARTICLE: "profiling" "Profiling code"
{ $subsection vocab-profile. }
{ $subsection usage-profile. }
{ $subsection vocabs-profile. }
{ $subsection method-profile. } ;
{ $subsection method-profile. }
{ $subsection "profiler-limitations" }
{ $see-also "ui-profiler" } ;
ABOUT: "profiling"

3
basis/ui/gadgets/borders/borders.factor
View File

@ -16,6 +16,9 @@ TUPLE: border < gadget
swap border new-border
swap dup 2array >>size ;
: <filled-border> ( child gap -- border )
<border> { 1 1 } >>fill ;
M: border pref-dim*
[ size>> 2 v*n ] keep
gadget-child pref-dim v+ ;

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

@ -107,7 +107,7 @@ M: editor ungraft*
editor-font* "" string-height ;
: y>line ( y editor -- line# )
line-height / >fixnum ;
line-height /i ;
:: point>loc ( point editor -- loc )
point second editor y>line {

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

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: locals accessors arrays ui.commands ui.gadgets
USING: locals accessors arrays ui.commands ui.operations ui.gadgets
ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic
hashtables kernel math models namespaces opengl sequences
math.vectors ui.gadgets.theme ui.gadgets.packs
@ -54,3 +54,9 @@ M: menu-glass layout* gadget-child prefer ;
: show-commands-menu ( target commands -- )
[ dup [ ] ] dip <commands-menu> show-menu ;
: <operations-menu> ( target hook -- menu )
over object-operations <commands-menu> ;
: show-operations-menu ( gadget target -- )
[ ] <operations-menu> show-menu ;

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

@ -35,8 +35,6 @@ HELP: <presentation>
{ <button> <bevel-button> <command-button> <roll-button> <presentation> } related-words
{ <commands-menu> <toolbar> operations-menu show-menu } related-words
{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
HELP: show-mouse-help

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

@ -11,8 +11,8 @@ IN: ui.gadgets.presentations
TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- )
over dup hook>> call
[ object>> ] dip invoke-command ;
[ [ dup hook>> call ] [ object>> ] bi ] dip
invoke-command ;
: invoke-primary ( presentation -- )
dup object>> primary-operation
@ -23,7 +23,7 @@ TUPLE: presentation < button object hook ;
invoke-presentation ;
: show-mouse-help ( presentation -- )
dup object>> over show-summary button-update ;
[ [ object>> ] keep show-summary ] [ button-update ] bi ;
: <presentation> ( label object -- button )
swap [ invoke-primary ] presentation new-button
@ -35,18 +35,13 @@ M: presentation ungraft*
dup hand-gadget get-global child? [ dup hide-status ] when
call-next-method ;
: <operations-menu> ( presentation -- menu )
[ object>> ]
[ dup hook>> curry ]
[ object>> object-operations ]
tri <commands-menu> ;
: operations-menu ( presentation -- )
dup <operations-menu> show-menu ;
: show-operations-menu ( presentation -- )
[ ] [ object>> ] [ dup hook>> curry ] tri
<operations-menu> show-menu ;
presentation H{
{ T{ button-down f f 3 } [ operations-menu ] }
{ T{ mouse-leave } [ dup hide-status button-update ] }
{ T{ button-down f f 3 } [ show-operations-menu ] }
{ T{ mouse-leave } [ [ hide-status ] [ button-update ] bi ] }
{ T{ mouse-enter } [ show-mouse-help ] }
! Responding to motion too allows nested presentations to
! display status help properly, when the mouse leaves a

17
basis/ui/gadgets/tracks/tracks-tests.factor
View File

@ -21,3 +21,20 @@ IN: ui.gadgets.tracks.tests
<gadget> { 10 10 } >>dim 0 track-add
pref-dim
] unit-test
[ { 10 30 } ] [
{ 0 1 } <track>
<gadget> { 10 10 } >>dim f track-add
<gadget> { 10 10 } >>dim f track-add
<gadget> { 10 10 } >>dim f track-add
pref-dim
] unit-test
[ { 10 40 } ] [
{ 0 1 } <track>
{ 5 5 } >>gap
<gadget> { 10 10 } >>dim f track-add
<gadget> { 10 10 } >>dim f track-add
<gadget> { 10 10 } >>dim f track-add
pref-dim
] unit-test

15
basis/ui/gadgets/tracks/tracks.factor
View File

@ -27,10 +27,15 @@ TUPLE: track < pack sizes ;
[ children>> ] [ sizes>> ] bi { 0 0 }
[ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
: gap-dim ( track -- dim )
[ gap>> ] [ children>> length 1 [-] ] bi v*n ;
: available-dim ( track -- dim )
[ dim>> ] [ alloted-dim ] bi v- ;
: track-layout ( track -- sizes )
[ available-dim ] [ children>> ] [ normalized-sizes ] tri
[ [ available-dim ] [ gap-dim ] bi v- ]
[ children>> ] [ normalized-sizes ] tri
[ [ over n*v ] [ pref-dim ] ?if ] 2map nip ;
M: track layout* ( track -- ) dup track-layout pack-layout ;
@ -41,11 +46,9 @@ M: track layout* ( track -- ) dup track-layout pack-layout ;
: track-pref-dims-2 ( track -- dim )
[
[ children>> pref-dims ] [ normalized-sizes ] bi
[ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map
[ dup { 0 f } member? [ 2drop { 0 0 } ] [ v/n ] if ] 2map
max-dim [ >fixnum ] map
]
[ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
v+ ;
] [ gap-dim ] bi v+ ;
M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ]

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

@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
ui.tools.search ui.tools.workspace kernel models namespaces
sequences tools.test ui.gadgets ui.gadgets.buttons
ui.gadgets.labelled ui.gadgets.presentations
ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
ui.gadgets.menus ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
IN: ui.tools.tests
[ f ]
@ -40,7 +40,10 @@ IN: ui.tools.tests
[ t ] [ "p" get presentation? ] unit-test
[ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
[ ] [
"p" get [ object>> ] [ dup hook>> curry ] bi
<operations-menu> gadget-child gadget-child "c" set
] unit-test
[ ] [ notify-queued ] unit-test

1
basis/uuid/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

1
basis/uuid/summary.txt Normal file
View File

@ -0,0 +1 @@
Generates UUID's.

47
basis/uuid/uuid-docs.factor Normal file
View File

@ -0,0 +1,47 @@
USING: help.syntax help.markup kernel prettyprint sequences strings ;
IN: uuid
HELP: uuid1
{ $values { "string" "a UUID string" } }
{ $description
"Generates a UUID (version 1) from the host ID, sequence number, "
"and current time."
} ;
HELP: uuid3
{ $values { "namespace" string } { "name" string } { "string" "a UUID string" } }
{ $description
"Generates a UUID (version 3) from the MD5 hash of a namespace "
"UUID and a name."
} ;
HELP: uuid4
{ $values { "string" "a UUID string" } }
{ $description
"Generates a UUID (version 4) from random bits."
} ;
HELP: uuid5
{ $values { "namespace" string } { "name" string } { "string" "a UUID string" } }
{ $description
"Generates a UUID (version 5) from the SHA-1 hash of a namespace "
"UUID and a name."
} ;
ARTICLE: "uuid" "UUID (Universally Unique Identifier)"
"The " { $vocab-link "uuid" } " vocabulary is used to generate UUIDs. "
"The below words can be used to generate version 1, 3, 4, and 5 UUIDs as specified in RFC 4122."
$nl
"If all you want is a unique ID, you should probably call " { $link uuid1 } " or " { $link uuid4 } "."
{ $subsection uuid1 }
{ $subsection uuid3 }
{ $subsection uuid4 }
{ $subsection uuid5 }
;
ABOUT: "uuid"

18
basis/uuid/uuid-tests.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: kernel uuid tools.test ;
IN: uuid.tests
[ t ] [ NAMESPACE_DNS [ uuid-parse uuid-unparse ] keep = ] unit-test
[ t ] [ NAMESPACE_URL [ uuid-parse uuid-unparse ] keep = ] unit-test
[ t ] [ NAMESPACE_OID [ uuid-parse uuid-unparse ] keep = ] unit-test
[ t ] [ NAMESPACE_X500 [ uuid-parse uuid-unparse ] keep = ] unit-test
[ t ] [ NAMESPACE_URL "ABCD" uuid3
"2e10e403-d7fa-3ffb-808f-ab834a46890e" = ] unit-test
[ t ] [ NAMESPACE_URL "ABCD" uuid5
"0aa883d6-7953-57e7-a8f0-66db29ce5a91" = ] unit-test

89
basis/uuid/uuid.factor Normal file
View File

@ -0,0 +1,89 @@
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: byte-arrays checksums checksums.md5 checksums.sha1
kernel math math.parser math.ranges random unicode.case
sequences strings system io.binary ;
IN: uuid
<PRIVATE
: (timestamp) ( -- time_high time_mid time_low )
! 0x01b21dd213814000L is the number of 100-ns intervals
! between the UUID epoch 1582-10-15 00:00:00 and the
! Unix epoch 1970-01-01 00:00:00.
micros 10 * HEX: 01b21dd213814000 +
[ -48 shift HEX: 0fff bitand ]
[ -32 shift HEX: ffff bitand ]
[ HEX: ffffffff bitand ]
tri ;
: (hardware) ( -- address )
! Choose a random 48-bit number with eighth bit
! set to 1 (as recommended in RFC 4122)
48 random-bits HEX: 010000000000 bitor ;
: (clock) ( -- clockseq )
! Choose a random 14-bit number
14 random-bits ;
: <uuid> ( address clockseq time_high time_mid time_low -- n )
96 shift
[ 80 shift ] dip bitor
[ 64 shift ] dip bitor
[ 48 shift ] dip bitor
bitor ;
: (version) ( n version -- n' )
[
HEX: c000 48 shift bitnot bitand
HEX: 8000 48 shift bitor
HEX: f000 64 shift bitnot bitand
] dip 76 shift bitor ;
: uuid>string ( n -- string )
>hex 32 CHAR: 0 pad-left
[ CHAR: - 20 ] dip insert-nth
[ CHAR: - 16 ] dip insert-nth
[ CHAR: - 12 ] dip insert-nth
[ CHAR: - 8 ] dip insert-nth ;
: string>uuid ( string -- n )
[ CHAR: - = not ] filter 16 base> ;
: uuid>byte-array ( n -- byte-array )
16 >be ;
PRIVATE>
: uuid-parse ( string -- byte-array )
string>uuid uuid>byte-array ;
: uuid-unparse ( byte-array -- string )
be> uuid>string ;
: uuid1 ( -- string )
(hardware) (clock) (timestamp) <uuid>
1 (version) uuid>string ;
: uuid3 ( namespace name -- string )
[ uuid-parse ] dip append
md5 checksum-bytes 16 short head be>
3 (version) uuid>string ;
: uuid4 ( -- string )
128 random-bits
4 (version) uuid>string ;
: uuid5 ( namespace name -- string )
[ uuid-parse ] dip append
sha1 checksum-bytes 16 short head be>
5 (version) uuid>string ;
CONSTANT: NAMESPACE_DNS "6ba7b810-9dad-11d1-80b4-00c04fd430c8"
CONSTANT: NAMESPACE_URL "6ba7b811-9dad-11d1-80b4-00c04fd430c8"
CONSTANT: NAMESPACE_OID "6ba7b812-9dad-11d1-80b4-00c04fd430c8"
CONSTANT: NAMESPACE_X500 "6ba7b814-9dad-11d1-80b4-00c04fd430c8"

12
basis/x11/xim/xim.factor
View File

@ -9,14 +9,14 @@ IN: x11.xim
SYMBOL: xim
: (init-xim) ( classname medifier -- im )
XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
[ dpy get f ] dip dup XOpenIM ;
XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
[ dpy get f ] dip dup XOpenIM ;
: init-xim ( classname -- )
dup "" (init-xim)
[ nip ]
[ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
xim set-global ;
dup "" (init-xim)
[ nip ]
[ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
xim set-global ;
: close-xim ( -- )
xim get-global XCloseIM drop f xim set-global ;

1
basis/xml/tests/test.factor
View File

@ -61,3 +61,4 @@ SYMBOL: xml-file
[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk second ] unit-test
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk second ] unit-test
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk second ] unit-test
[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk [ write-xml-chunk ] with-string-writer = ] unit-test

2
basis/xml/writer/writer.factor
View File

@ -112,7 +112,7 @@ M: system-id write-xml-chunk
M: public-id write-xml-chunk
"PUBLIC '" write
[ pubid-literal>> write "' '" write ]
[ system-literal>> write "'>" write ] bi ;
[ system-literal>> write "'" write ] bi ;
M: doctype-decl write-xml-chunk
"<!DOCTYPE " write

6
core/compiler/errors/errors-docs.factor
View File

@ -3,18 +3,20 @@ USING: help.markup help.syntax vocabs.loader words io
quotations words.symbol ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"The compiler saves various notifications in a global variable:"
"The compiler saves " { $link "inference-errors" } " in a global variable:"
{ $subsection compiler-errors }
"These notifications can be viewed later:"
{ $subsection :errors }
{ $subsection :warnings }
{ $subsection :linkage }
"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
{ $link with-compiler-errors } ;
{ $subsection with-compiler-errors } ;
HELP: compiler-errors
{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ;
ABOUT: "compiler-errors"
HELP: compiler-error
{ $values { "error" "an error" } { "word" word } }
{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;

4
core/kernel/kernel-tests.factor
View File

@ -1,7 +1,7 @@
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs
sequences.private accessors ;
sequences.private accessors locals.backend ;
IN: kernel.tests
[ 0 ] [ f size ] unit-test
@ -35,7 +35,7 @@ IN: kernel.tests
[ ] [ [ :c ] with-string-writer drop ] unit-test
: overflow-r 3 [ overflow-r ] dip ;
: overflow-r 3 load-local overflow-r ;
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with

2
core/math/math.factor
View File

@ -114,7 +114,7 @@ M: float fp-infinity? ( float -- ? )
<PRIVATE
: iterate-prep ( n quot -- i n quot ) 0 -rot ; inline
: iterate-prep ( n quot -- i n quot ) [ 0 ] 2dip ; inline
: if-iterate? ( i n true false -- ) [ 2over < ] 2dip if ; inline

2
core/words/words.factor
View File

@ -54,7 +54,7 @@ M: primitive definition drop f ;
SYMBOL: bootstrapping?
: if-bootstrapping ( true false -- )
bootstrapping? get -rot if ; inline
[ bootstrapping? get ] 2dip if ; inline
: bootstrap-word ( word -- target )
[ target-word ] [ ] if-bootstrapping ;

2
extra/bunny/model/model.factor
View File

@ -30,7 +30,7 @@ IN: bunny.model
[ n ] keep [ rot [ v+ ] change-nth ] with with each ;
: normals ( vs is -- ns )
over length { 0.0 0.0 0.0 } <array> -rot
[ [ length { 0.0 0.0 0.0 } <array> ] keep ] dip
[ [ 2dup ] dip normal ] each drop
[ normalize ] map ;

111
extra/easy-help/easy-help.factor Normal file
View File

@ -0,0 +1,111 @@
USING: arrays assocs compiler.units
grouping help help.markup help.topics kernel lexer multiline
namespaces parser sequences splitting words
easy-help.expand-markup ;
IN: easy-help
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Description:
".." parse-multiline-string
string-lines
1 tail
[ dup " " head? [ 4 tail ] [ ] if ] map
[ dup "" = [ drop { $nl } ] [ ] if ] map
\ $description prefix
parsed
; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Example:
{ $heading "Example" } parsed
".." parse-multiline-string
string-lines
[ dup " " head? [ 4 tail ] [ ] if ] map
[ "" = not ] filter
! \ $example prefix
\ $code prefix
parsed
; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Summary:
".." parse-multiline-string
string-lines
1 tail
[ dup " " head? [ 4 tail ] [ ] if ] map
[ dup "" = [ drop { $nl } ] [ ] if ] map
{ $heading "Summary" } prefix
parsed
; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Values:
".." parse-multiline-string
string-lines
1 tail
[ dup " " head? [ 4 tail ] [ ] if ] map
[ " " split1 [ " " first = ] trim-left 2array ] map
\ $values prefix
parsed
; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Word:
scan current-vocab create dup old-definitions get
[ delete-at ] with each dup set-word
bootstrap-word dup set-word
dup >link save-location
\ ; parse-until >array swap set-word-help ; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Contract:
".." parse-multiline-string
string-lines
1 tail
[ dup " " head? [ 4 tail ] [ ] if ] map
[ expand-markup ] map
concat
[ dup "" = [ drop { $nl } ] [ ] if ] map
\ $contract prefix
parsed
; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: Notes:
".." parse-multiline-string
string-lines
1 tail
[ dup " " head? [ 4 tail ] [ ] if ] map
[ expand-markup ] map
concat
[ dup "" = [ drop { $nl } ] [ ] if ] map
\ $notes prefix
parsed
; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

47
extra/easy-help/expand-markup/expand-markup.factor Normal file
View File

@ -0,0 +1,47 @@
USING: accessors arrays kernel lexer locals math namespaces parser
sequences splitting ;
IN: easy-help.expand-markup
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: scan-one-array ( string -- array rest )
string-lines
lexer-factory get call
[
[
\ } parse-until >array
lexer get line-text>>
lexer get column>> tail
]
with-lexer
]
with-scope ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: contains-markup? ( string -- ? ) "{ $" swap subseq? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: expand-markup ( LINE -- lines )
LINE contains-markup?
[
[let | N [ "{ $" LINE start ] |
LINE N head
LINE N 2 + tail scan-one-array dup " " head? [ 1 tail ] [ ] if
[ 2array ] dip
expand-markup
append ]
]
[ LINE 1array ]
if ;

131
extra/fuel/fuel.factor
View File

@ -1,19 +1,17 @@
! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.tuple
combinators compiler.units continuations debugger definitions
eval help io io.files io.pathnames io.streams.string kernel
lexer listener listener.private make math memoize namespaces
parser prettyprint prettyprint.config quotations sequences sets
sorting source-files strings tools.vocabs vectors vocabs
vocabs.loader vocabs.parser ;
USING: accessors arrays assocs classes.tuple combinators
compiler.units continuations debugger definitions io io.pathnames
io.streams.string kernel lexer math math.order memoize namespaces
parser prettyprint sequences sets sorting source-files strings summary
tools.vocabs vectors vocabs vocabs.parser words ;
IN: fuel
! Evaluation status:
TUPLE: fuel-status in use ds? restarts ;
TUPLE: fuel-status in use restarts ;
SYMBOL: fuel-status-stack
V{ } clone fuel-status-stack set-global
@ -36,25 +34,21 @@ t clone fuel-eval-res-flag set-global
: fuel-eval-non-restartable ( -- )
f fuel-eval-res-flag set-global ; inline
: push-fuel-status ( -- )
in get use get clone display-stacks? get restarts get-global clone
: fuel-push-status ( -- )
in get use get clone restarts get-global clone
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 ]
[
restarts>> fuel-eval-restartable? [ drop ] [
clone restarts set-global
] if
]
} cleave
] unless ;
: fuel-pop-restarts ( restarts -- )
fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline
: fuel-pop-status ( -- )
fuel-status-stack get empty? [
fuel-status-stack get pop
[ in>> in set ]
[ use>> clone use set ]
[ restarts>> fuel-pop-restarts ] tri
] unless ;
! Lispy pretty printing
@ -69,11 +63,7 @@ M: integer fuel-pprint pprint ; inline
M: string fuel-pprint pprint ; inline
M: sequence fuel-pprint
dup empty? [ drop f fuel-pprint ] [
"(" write
[ " " write ] [ fuel-pprint ] interleave
")" write
] if ;
"(" write [ " " write ] [ fuel-pprint ] interleave ")" write ; inline
M: tuple fuel-pprint tuple>array fuel-pprint ; inline
@ -112,22 +102,20 @@ M: source-file fuel-pprint path>> fuel-pprint ;
error get
fuel-eval-result get-global
fuel-eval-output get-global
3array fuel-pprint flush nl "EOT:" write ;
3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
: fuel-forget-error ( -- ) f error set-global ; inline
: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
: (fuel-begin-eval) ( -- )
push-fuel-status
display-stacks? off
fuel-push-status
fuel-forget-error
fuel-forget-result
fuel-forget-output ;
: (fuel-end-eval) ( quot -- )
with-string-writer fuel-eval-output set-global
fuel-retort pop-fuel-status ; inline
: (fuel-end-eval) ( output -- )
fuel-eval-output set-global fuel-retort fuel-pop-status ; inline
: (fuel-eval) ( lines -- )
[ [ parse-lines ] with-compilation-unit call ] curry
@ -144,36 +132,76 @@ M: source-file fuel-pprint path>> fuel-pprint ;
[ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
: 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-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
(fuel-end-eval) ;
: fuel-eval ( lines -- )
(fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline
! Loading files
: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
: fuel-run-file ( path -- ) run-file ; inline
: fuel-with-autouse ( quot -- )
[
auto-use? on
[ amended-use get clone fuel-eval-set-result ] print-use-hook set
call
] curry with-scope ;
: (fuel-get-uses) ( lines -- )
[ parse-fresh drop ] curry with-compilation-unit ; inline
: fuel-get-uses ( lines -- )
[ (fuel-get-uses) ] curry fuel-with-autouse ;
! Edit locations
: fuel-normalize-loc ( seq -- path line )
dup length 1 > [ first2 [ (normalize-path) ] dip ] [ f ] if ; inline
: fuel-get-edit-location ( defspec -- )
where [
first2 [ (normalize-path) ] dip 2array fuel-eval-set-result
] when* ; inline
where fuel-normalize-loc 2array fuel-eval-set-result ; inline
: fuel-get-vocab-location ( vocab -- )
>vocab-link fuel-get-edit-location ; inline
: fuel-get-doc-location ( defspec -- )
props>> "help-loc" swap at
fuel-normalize-loc 2array fuel-eval-set-result ;
! Cross-references
: fuel-word>xref ( word -- xref )
[ name>> ] [ vocabulary>> ] [ where fuel-normalize-loc ] tri 4array ;
: fuel-sort-xrefs ( seq -- seq' )
[ [ first ] dip first <=> ] sort ; inline
: fuel-format-xrefs ( seq -- seq' )
[ word? ] filter [ fuel-word>xref ] map fuel-sort-xrefs ;
: fuel-callers-xref ( word -- )
usage fuel-format-xrefs fuel-eval-set-result ; inline
: fuel-callees-xref ( word -- )
uses fuel-format-xrefs fuel-eval-set-result ; inline
! Completion support
: fuel-filter-prefix ( seq prefix -- seq )
[ drop-prefix nip length 0 = ] curry filter prune ; inline
: (fuel-get-vocabs) ( -- seq )
all-vocabs-seq [ vocab-name ] map ; inline
: fuel-get-vocabs ( -- )
(fuel-get-vocabs) fuel-eval-set-result ; inline
: fuel-get-vocabs/prefix ( prefix -- )
(fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ; inline
: fuel-vocab-summary ( name -- )
>vocab-link summary fuel-eval-set-result ; inline
MEMO: (fuel-vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ;
@ -185,12 +213,13 @@ MEMO: (fuel-vocab-words) ( name -- seq )
: (fuel-get-words) ( prefix names/f -- seq )
[ fuel-vocabs-words ] [ fuel-current-words ] if* natural-sort
swap [ drop-prefix nip length 0 = ] curry filter ;
swap fuel-filter-prefix ;
: fuel-get-words ( prefix names -- )
(fuel-get-words) fuel-eval-set-result ; inline
: fuel-run-file ( path -- ) run-file ; inline
! -run=fuel support
: fuel-startup ( -- ) "listener" run-file ; inline

0
unmaintained/golden-section/authors.txt → extra/golden-section/authors.txt
View File

0
unmaintained/golden-section/deploy.factor → extra/golden-section/deploy.factor
View File

0
unmaintained/golden-section/golden-section.factor → extra/golden-section/golden-section.factor
View File

0
unmaintained/golden-section/summary.txt → extra/golden-section/summary.txt
View File

0
unmaintained/golden-section/tags.txt → extra/golden-section/tags.txt
View File

2
extra/google-tech-talk/google-tech-talk.factor
View File

@ -203,7 +203,7 @@ IN: google-tech-talk
{ $code "13 <circle> tell-me" }
{ $code "103 76 <rectangle> tell-me" }
{ $code "101 tell-me" }
{ { $link integer } ", " { $link array } ", and others area built-in classes" }
{ { $link integer } ", " { $link array } ", and others are built-in classes" }
}
{ $slide "Object system"
"Anyone can define new shapes..."

0
unmaintained/nehe/2/2.factor → extra/nehe/2/2.factor
View File

0
unmaintained/nehe/2/authors.txt → extra/nehe/2/authors.txt
View File

0
unmaintained/nehe/3/3.factor → extra/nehe/3/3.factor
View File

0
unmaintained/nehe/3/authors.txt → extra/nehe/3/authors.txt
View File

0
unmaintained/nehe/4/4.factor → extra/nehe/4/4.factor
View File

0
unmaintained/nehe/4/authors.txt → extra/nehe/4/authors.txt
View File

0
unmaintained/nehe/5/5.factor → extra/nehe/5/5.factor
View File

0
unmaintained/nehe/5/authors.txt → extra/nehe/5/authors.txt
View File

0
unmaintained/nehe/authors.txt → extra/nehe/authors.txt
View File

0
unmaintained/nehe/deploy.factor → extra/nehe/deploy.factor
View File

0
unmaintained/nehe/nehe.factor → extra/nehe/nehe.factor
View File

0
unmaintained/nehe/summary.txt → extra/nehe/summary.txt
View File

0
unmaintained/nehe/tags.txt → extra/nehe/tags.txt
View File

61
extra/size-of/size-of.factor Normal file
View File

@ -0,0 +1,61 @@
USING: io io.encodings.ascii io.files io.files.temp io.launcher
locals math.parser sequences sequences.deep
help.syntax
easy-help ;
IN: size-of
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Word: size-of
Values:
HEADERS sequence : List of header files
TYPE string : A C type
n integer : Size in number of bytes ..
Description:
Use 'size-of' to find out the size in bytes of a C type.
The 'headers' argument is a list of header files to use. You may
pass 'f' to only use 'stdio.h'. ..
Example:
! Find the size of 'int'
f "int" size-of . ..
Example:
! Find the size of the 'XAnyEvent' struct from Xlib.h
{ "X11/Xlib.h" } "XAnyEvent" size-of . ..
;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: size-of ( HEADERS TYPE -- n )
[let | C-FILE [ "size-of.c" temp-file ]
EXE-FILE [ "size-of" temp-file ]
INCLUDES [ HEADERS [| FILE | { "#include <" FILE ">" } concat ] map ] |
{
"#include <stdio.h>"
INCLUDES
"main() { printf( \"%i\" , sizeof( " TYPE " ) ) ; }"
}
flatten C-FILE ascii set-file-lines
{ "gcc" C-FILE "-o" EXE-FILE } try-process
EXE-FILE ascii <process-reader> contents string>number ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

35
unmaintained/plot/plot.factor → extra/ui/gadgets/plot/plot.factor
View File

@ -1,12 +1,41 @@
USING: kernel quotations arrays sequences math math.ranges fry
opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
accessors ;
accessors
help.syntax
easy-help ;
IN: ui.gadgets.plot
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "ui.gadgets.plot" "Plot Gadget"
Summary:
A simple gadget for ploting two dimentional functions.
Use the arrow keys to move around.
Use 'a' and 'z' keys to zoom in and out. ..
Example:
<plot> [ sin ] add-function gadget. ..
Example:
<plot>
[ sin ] red function boa add-function
[ cos ] blue function boa add-function
gadget. ..
;
ABOUT: "ui.gadgets.plot"
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: plot < cartesian functions points ;
: init-plot ( plot -- plot )
@ -29,11 +58,11 @@ TUPLE: function function color ;
GENERIC: plot-function ( plot object -- plot )
M: callable plot-function ( plot quotation -- plot )
>r dup plot-range r> '[ dup @ 2array ] map line-strip ;
[ dup plot-range ] dip '[ dup @ 2array ] map line-strip ;
M: function plot-function ( plot function -- plot )
dup color>> dup [ >stroke-color ] [ drop ] if
>r dup plot-range r> function>> '[ dup @ 2array ] map line-strip ;
[ dup plot-range ] dip function>> '[ dup @ 2array ] map line-strip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

29
extra/ui/gadgets/slate/slate.factor
View File

@ -1,8 +1,35 @@
USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
USING: kernel namespaces opengl ui.render ui.gadgets accessors
help.syntax
easy-help ;
IN: ui.gadgets.slate
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "slate" "Slate Gadget"
Summary:
A gadget with an 'action' slot which should be set to a callable. ..
Example:
! Load the right vocabs for the examples
USING: processing.shapes ui.gadgets.slate ; ..
Example:
[ { { 10 10 } { 50 30 } { 10 50 } } polygon fill-mode ] <slate>
gadget. ..
;
ABOUT: "slate"
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: slate < gadget action pdim graft ungraft ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

36
unmaintained/tiling/tiling.factor → extra/ui/gadgets/tiling/tiling.factor
View File

@ -1,10 +1,42 @@
USING: kernel sequences math math.order
ui.gadgets ui.gadgets.tracks ui.gestures
bake.fry accessors ;
ui.gadgets ui.gadgets.tracks ui.gestures accessors fry
help.syntax
easy-help ;
IN: ui.gadgets.tiling
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "ui.gadgets.tiling" "Tiling Layout Gadgets"
Summary:
A gadget which tiles it's children.
A tiling gadget may contain any number of children, but only a
fixed number is displayed at one time. How many are displayed can
be controlled via Control-[ and Control-].
The focus may be switched with Alt-Left and Alt-Right.
The focused child may be moved via Shift-Alt-Left and
Shift-Alt-Right. ..
Example:
<tiling-shelf>
"resource:" directory-files
[ [ drop ] <bevel-button> tiling-add ]
each
"Files" open-window ..
;
ABOUT: "ui.gadgets.tiling"
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: tiling < track gadgets tiles first focused ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

18
misc/fuel/README
View File

@ -57,8 +57,10 @@ C-cC-eC-r is the same as C-cC-er)).
- M-. : edit word at point in Emacs
- M-TAB : complete word at point
- C-cC-eu : update USING: line
- C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary)
- C-cC-ew : edit word (M-x fuel-edit-word)
- C-cC-ew : edit word (M-x fuel-edit-word-at-point)
- C-cC-ed : edit word's doc (M-x fuel-edit-word-at-point)
- C-cr, C-cC-er : eval region
- C-M-r, C-cC-ee : eval region, extending it to definition boundaries
@ -68,12 +70,17 @@ C-cC-eC-r is the same as C-cC-er)).
- C-cC-da : toggle autodoc mode
- C-cC-dd : help for word at point
- C-cC-ds : short help word at point
- C-cC-de : show stack effect of current sexp (with prefix, region)
- C-cM-<, C-cC-d< : show callers of word at point
- C-cM->, C-cC-d> : show callees of word at point
* In the listener:
- TAB : complete word at point
- M-. : edit word at point in Emacs
- C-ca : toggle autodoc mode
- C-cs : toggle stack mode
- C-cv : edit vocabulary
- C-ch : help for word at point
- C-ck : run file
@ -90,5 +97,12 @@ C-cC-eC-r is the same as C-cC-er)).
- RET : help for word at point
- f/b : next/previous page
- SPC/S-SPC : scroll up/down
- q: bury buffer
- TAB/S-TAB : next/previous headline
- C-cz : switch to listener
- q : bury buffer
* In crossref buffers
- TAB/BACKTAB : navigate links
- RET/mouse click : follow link
- q : bury buffer

45
misc/fuel/factor-mode.el
View File

@ -24,8 +24,9 @@
;;; Customization:
(defgroup factor-mode nil
"Major mode for Factor source code"
:group 'fuel)
"Major mode for Factor source code."
:group 'fuel
:group 'languages)
(defcustom factor-mode-use-fuel t
"Whether to use the full FUEL facilities in factor mode.
@ -59,23 +60,6 @@ code in the buffer."
:type 'hook
:group 'factor-mode)
;;; Faces:
(fuel-font-lock--define-faces
factor-font-lock font-lock factor-mode
((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")))
;;; Syntax table:
@ -111,16 +95,19 @@ code in the buffer."
(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))
(iop (fuel-syntax--indentation-at op)))
(when (> ln (line-number-at-pos op))
(if (and (> cl 0)
(= (- cl (point)) (current-indentation))
(= ln (line-number-at-pos cl)))
iop
(fuel-syntax--increased-indentation iop)))))))
(let* ((bs (fuel-syntax--brackets-start))
(be (fuel-syntax--brackets-end))
(ln (line-number-at-pos)))
(when (> ln (line-number-at-pos bs))
(cond ((and (> be 0)
(= (- be (point)) (current-indentation))
(= ln (line-number-at-pos be)))
(fuel-syntax--indentation-at bs))
((or (fuel-syntax--is-eol bs)
(not (eq ?\ (char-after (1+ bs)))))
(fuel-syntax--increased-indentation
(fuel-syntax--indentation-at bs)))
(t (+ 2 (fuel-syntax--line-offset bs)))))))))
(defun factor-mode--indent-definition ()
(save-excursion

3
misc/fuel/fu.el
View File

@ -17,6 +17,9 @@
(autoload 'run-factor "fuel-listener.el"
"Start a Factor listener, or switch to a running one." t)
(autoload 'switch-to-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)

95
misc/fuel/fuel-autodoc.el Normal file
View File

@ -0,0 +1,95 @@
;;; fuel-autodoc.el -- doc snippets in the echo area
;; 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 20, 2008 00:50
;;; Comentary:
;; Utilities for displaying information automatically in the echo
;; area.
;;; Code:
(require 'fuel-eval)
(require 'fuel-syntax)
(require 'fuel-base)
;;; Customization:
(defgroup fuel-autodoc nil
"Options controlling FUEL's autodoc system."
:group 'fuel)
(defcustom fuel-autodoc-minibuffer-font-lock t
"Whether to use font lock for info messages in the minibuffer."
:group 'fuel-autodoc
:type 'boolean)
;;; Autodoc mode:
(defvar fuel-autodoc--font-lock-buffer
(let ((buffer (get-buffer-create " *fuel help minibuffer messages*")))
(set-buffer buffer)
(fuel-font-lock--font-lock-setup)
buffer))
(defun fuel-autodoc--font-lock-str (str)
(set-buffer fuel-autodoc--font-lock-buffer)
(erase-buffer)
(insert str)
(let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
(buffer-string))
(defun fuel-autodoc--word-synopsis (&optional word)
(let ((word (or word (fuel-syntax-symbol-at-point)))
(fuel-log--inhibit-p t))
(when word
(let* ((cmd (if (fuel-syntax--in-using)
`(:fuel* (,word fuel-vocab-summary) t t)
`(:fuel* (((:quote ,word) synopsis :get)) t)))
(ret (fuel-eval--send/wait cmd 20))
(res (fuel-eval--retort-result ret)))
(when (and ret (not (fuel-eval--retort-error ret)) (stringp res))
(if fuel-autodoc-minibuffer-font-lock
(fuel-autodoc--font-lock-str res)
res))))))
(make-variable-buffer-local
(defvar fuel-autodoc--fallback-function nil))
(defun fuel-autodoc--eldoc-function ()
(or (and fuel-autodoc--fallback-function
(funcall fuel-autodoc--fallback-function))
(fuel-autodoc--word-synopsis)))
(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-autodoc
(set (make-local-variable 'eldoc-documentation-function)
(when fuel-autodoc-mode 'fuel-autodoc--eldoc-function))
(set (make-local-variable 'eldoc-minor-mode-string) nil)
(eldoc-mode fuel-autodoc-mode)
(message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled")))
(provide 'fuel-autodoc)
;;; fuel-autodoc.el ends here

33
misc/fuel/fuel-base.el
View File

@ -25,8 +25,8 @@
;;;###autoload
(defgroup fuel nil
"Factor's Ultimate Emacs Library"
:group 'language)
"Factor's Ultimate Emacs Library."
:group 'languages)
;;; Emacs compatibility:
@ -39,6 +39,20 @@
(when (equal item (ring-ref ring ind))
(throw 'found ind)))))))
(when (not (fboundp 'completion-table-dynamic))
(defun completion-table-dynamic (fun)
(lexical-let ((fun fun))
(lambda (string pred action)
(with-current-buffer (let ((win (minibuffer-selected-window)))
(if (window-live-p win) (window-buffer win)
(current-buffer)))
(complete-with-action action (funcall fun string) string pred))))))
(when (not (fboundp 'looking-at-p))
(defsubst looking-at-p (regexp)
(let ((inhibit-changing-match-data t))
(looking-at regexp))))
;;; Utilities
@ -59,8 +73,23 @@
" ")
len))
(defsubst fuel--region-to-string (begin &optional end)
(let ((end (or end (point))))
(if (< begin end)
(mapconcat 'identity
(split-string (buffer-substring-no-properties begin end)
nil
t)
" ")
"")))
(defsubst empty-string-p (str) (equal str ""))
(defun fuel--string-prefix-p (prefix str)
(and (>= (length str) (length prefix))
(string= (substring-no-properties str 0 (length prefix))
(substring-no-properties prefix))))
(defun fuel--respecting-message (format &rest format-args)
"Display TEXT as a message, without hiding any minibuffer contents."
(let ((text (format " [%s]" (apply #'format format format-args))))

42
misc/fuel/fuel-completion.el
View File

@ -32,6 +32,10 @@
(fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
fuel-completion--vocabs)
(defsubst fuel-completion--vocab-list (prefix)
(fuel-eval--retort-result
(fuel-eval--send/wait `(:fuel* (,prefix fuel-get-vocabs/prefix) t t))))
(defun fuel-completion--words (prefix vocabs)
(let ((vs (if vocabs (cons :array vocabs) 'f))
(us (or vocabs 't)))
@ -55,7 +59,7 @@ performed."))
If this window is no longer active or displaying the completions
buffer then we can ignore `fuel-completion--window-cfg'."))
(defun fuel-completion--maybe-save-window-configuration ()
(defun fuel-completion--save-window-cfg ()
"Maybe save the current window configuration.
Return true if the configuration was saved."
(unless (or fuel-completion--window-cfg
@ -66,17 +70,17 @@ Return true if the configuration was saved."
(defun fuel-completion--delay-restoration ()
(add-hook 'pre-command-hook
'fuel-completion--maybe-restore-window-configuration
'fuel-completion--maybe-restore-window-cfg
nil t))
(defun fuel-completion--forget-window-configuration ()
(defun fuel-completion--forget-window-cfg ()
(setq fuel-completion--window-cfg nil)
(setq fuel-completion--completions-window nil))
(defun fuel-completion--restore-window-configuration ()
(defun fuel-completion--restore-window-cfg ()
"Restore the window config if available."
(remove-hook 'pre-command-hook
'fuel-completion--maybe-restore-window-configuration)
'fuel-completion--maybe-restore-window-cfg)
(when (and fuel-completion--window-cfg
(fuel-completion--window-active-p))
(save-excursion
@ -85,21 +89,21 @@ Return true if the configuration was saved."
(when (buffer-live-p fuel-completion--comp-buffer)
(kill-buffer fuel-completion--comp-buffer))))
(defun fuel-completion--maybe-restore-window-configuration ()
(defun fuel-completion--maybe-restore-window-cfg ()
"Restore the window configuration, if the following command
terminates a current completion."
(remove-hook 'pre-command-hook
'fuel-completion--maybe-restore-window-configuration)
'fuel-completion--maybe-restore-window-cfg)
(condition-case err
(cond ((find last-command-char "()\"'`,# \r\n:")
(fuel-completion--restore-window-configuration))
(fuel-completion--restore-window-cfg))
((not (fuel-completion--window-active-p))
(fuel-completion--forget-window-configuration))
(fuel-completion--forget-window-cfg))
(t (fuel-completion--delay-restoration)))
(error
;; Because this is called on the pre-command-hook, we mustn't let
;; errors propagate.
(message "Error in fuel-completion--restore-window-configuration: %S" err))))
(message "Error in fuel-completion--restore-window-cfg: %S" err))))
(defun fuel-completion--window-active-p ()
"Is the completion window currently active?"
@ -108,7 +112,7 @@ terminates a current completion."
fuel-completion--comp-buffer)))
(defun fuel-completion--display-comp-list (completions base)
(let ((savedp (fuel-completion--maybe-save-window-configuration)))
(let ((savedp (fuel-completion--save-window-cfg)))
(with-output-to-temp-buffer fuel-completion--comp-buffer
(display-completion-list completions base)
(let ((offset (- (point) 1 (length base))))
@ -152,14 +156,16 @@ terminates a current completion."
(defvar fuel-completion--all-words-list-func
(completion-table-dynamic 'fuel-completion--all-words-list))
(defun fuel-completion--complete (prefix)
(let* ((words (fuel-completion--word-list prefix))
(defun fuel-completion--complete (prefix vocabs)
(let* ((words (if vocabs
(fuel-completion--vocabs)
(fuel-completion--word-list prefix)))
(completions (all-completions prefix words))
(partial (try-completion prefix words))
(partial (if (eq partial t) prefix partial)))
(cons completions partial)))
(defsubst fuel-completion--read-word (prompt &optional default history all)
(defun fuel-completion--read-word (prompt &optional default history all)
(completing-read prompt
(if all fuel-completion--all-words-list-func
fuel-completion--word-list-func)
@ -172,18 +178,18 @@ terminates a current completion."
Perform completion similar to Emacs' complete-symbol."
(interactive)
(let* ((end (point))
(beg (fuel-syntax--symbol-start))
(beg (fuel-syntax--beginning-of-symbol-pos))
(prefix (buffer-substring-no-properties beg end))
(result (fuel-completion--complete prefix))
(result (fuel-completion--complete prefix (fuel-syntax--in-using)))
(completions (car result))
(partial (cdr result)))
(cond ((null completions)
(fuel--respecting-message "Can't find completion for %S" prefix)
(fuel-completion--restore-window-configuration))
(fuel-completion--restore-window-cfg))
(t (insert-and-inherit (substring partial (length prefix)))
(cond ((= (length completions) 1)
(fuel--respecting-message "Sole completion")
(fuel-completion--restore-window-configuration))
(fuel-completion--restore-window-cfg))
(t (fuel--respecting-message "Complete but not unique")
(fuel-completion--display-or-scroll completions
partial)))))))

67
misc/fuel/fuel-connection.el
View File

@ -46,8 +46,7 @@
(cons :id (random))
(cons :string str)
(cons :continuation cont)
(cons :buffer (or sender-buffer (current-buffer)))
(cons :output "")))
(cons :buffer (or sender-buffer (current-buffer)))))
(defsubst fuel-con--request-p (req)
(and (listp req) (eq (car req) :fuel-connection-request)))
@ -64,11 +63,6 @@
(defsubst fuel-con--request-buffer (req)
(cdr (assoc :buffer req)))
(defun fuel-con--request-output (req &optional suffix)
(let ((cell (assoc :output req)))
(when suffix (setcdr cell (concat (cdr cell) suffix)))
(cdr cell)))
(defsubst fuel-con--request-deactivate (req)
(setcdr (assoc :continuation req) nil))
@ -139,64 +133,69 @@
(fuel-con--connection-start-timer conn))))
(defconst fuel-con--prompt-regex "( .+ ) ")
(defconst fuel-con--eot-marker "EOT:")
(defconst fuel-con--init-stanza (format "USE: fuel %S write" fuel-con--eot-marker))
(defconst fuel-con--eot-marker "<~FUEL~>")
(defconst fuel-con--init-stanza "USE: fuel fuel-retort")
(defconst fuel-con--comint-finished-regex
(format "%s%s" fuel-con--eot-marker fuel-con--prompt-regex))
(format "^%s$" fuel-con--eot-marker))
(defun fuel-con--setup-comint ()
(comint-redirect-cleanup)
(set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
(add-hook 'comint-redirect-filter-functions
'fuel-con--comint-redirect-filter t t)
'fuel-con--comint-preoutput-filter nil t)
(add-hook 'comint-redirect-hook
'fuel-con--comint-redirect-hook nil t))
(defadvice comint-redirect-setup (after fuel-con--advice activate)
(setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))
(defun fuel-con--comint-preoutput-filter (str)
(when (string-match fuel-con--comint-finished-regex str)
(setq comint-redirect-finished-regexp fuel-con--prompt-regex))
str)
;;; Requests handling:
(defsubst fuel-con--comint-buffer ()
(get-buffer-create " *fuel connection retort*"))
(defsubst fuel-con--comint-buffer-form ()
(with-current-buffer (fuel-con--comint-buffer)
(goto-char (point-min))
(condition-case nil
(read (current-buffer))
(error (list 'fuel-con-error (buffer-string))))))
(defun fuel-con--process-next (con)
(when (not (fuel-con--connection-current-request con))
(let* ((buffer (fuel-con--connection-buffer con))
(req (fuel-con--connection-pop-request con))
(str (and req (fuel-con--request-string req))))
(str (and req (fuel-con--request-string req)))
(cbuf (with-current-buffer (fuel-con--comint-buffer)
(erase-buffer)
(current-buffer))))
(if (not (buffer-live-p buffer))
(fuel-con--connection-cancel-timer con)
(when (and buffer req str)
(set-buffer buffer)
(fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)
(comint-redirect-send-command (format "%s" str)
(fuel-log--buffer) nil t))))))
(comint-redirect-send-command (format "%s" str) cbuf nil t))))))
(defun fuel-con--process-completed-request (req)
(let ((str (fuel-con--request-output req))
(cont (fuel-con--request-continuation req))
(let ((cont (fuel-con--request-continuation req))
(id (fuel-con--request-id req))
(rstr (fuel-con--request-string req))
(buffer (fuel-con--request-buffer req)))
(if (not cont)
(fuel-log--warn "<%s> Droping result for request %S (%s)"
id rstr str)
id rstr req)
(condition-case cerr
(with-current-buffer (or buffer (current-buffer))
(funcall cont str)
(fuel-log--info "<%s>: processed\n\t%s" id str))
(error (fuel-log--error "<%s>: continuation failed %S \n\t%s"
id rstr cerr))))))
(defvar fuel-con--debug-comint-p nil)
(defun fuel-con--comint-redirect-filter (str)
(if (not fuel-con--connection)
(fuel-log--error "No connection in buffer (%s)" str)
(let ((req (fuel-con--connection-current-request fuel-con--connection)))
(if (not req) (fuel-log--error "No current request (%s)" str)
(fuel-con--request-output req str)
(fuel-log--info "<%s>: in progress" (fuel-con--request-id req)))))
(if fuel-con--debug-comint-p (fuel--shorten-str str 256) ""))
(funcall cont (fuel-con--comint-buffer-form))
(fuel-log--info "<%s>: processed\n\t%s" id req))
(error (fuel-log--error
"<%s>: continuation failed %S \n\t%s" id rstr cerr))))))
(defun fuel-con--comint-redirect-hook ()
(if (not fuel-con--connection)
@ -236,7 +235,7 @@
(not (fuel-con--connection-completed-p con id)))
(accept-process-output nil waitsecs)
(setq time (- time step)))
(error (setq time 1)))
(error (setq time 0)))
(or (> time 0)
(fuel-con--request-deactivate req)
nil)))))

224
misc/fuel/fuel-debug-uses.el Normal file
View File

@ -0,0 +1,224 @@
;;; fuel-debug-uses.el -- retrieving USING: stanzas
;; 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 23, 2008 04:23
;;; Comentary:
;; Support for getting and updating factor source vocabulary lists.
;;; Code:
(require 'fuel-debug)
(require 'fuel-eval)
(require 'fuel-popup)
(require 'fuel-font-lock)
(require 'fuel-base)
;;; Customization:
(fuel-font-lock--defface fuel-font-lock-debug-missing-vocab
'font-lock-warning-face fuel-debug "missing vocabulary names")
(fuel-font-lock--defface fuel-font-lock-debug-unneeded-vocab
'font-lock-warning-face fuel-debug "unneeded vocabulary names")
(fuel-font-lock--defface fuel-font-lock-debug-uses-header
'bold fuel-debug "headers in Uses buffers")
;;; Utility functions:
(defsubst fuel-debug--at-eou-p ()
(looking-at ".*\\_<;\\_>"))
(defun fuel-debug--file-lines (file)
(when (file-readable-p file)
(with-current-buffer (find-file-noselect file)
(save-excursion
(goto-char (point-min))
(let ((lines) (in-usings))
(while (not (eobp))
(when (looking-at "^USING: ") (setq in-usings t))
(unless in-usings
(let ((line (substring-no-properties (thing-at-point 'line) 0 -1)))
(unless (or (empty-string-p line)
(fuel--string-prefix-p "! " line))
(push line lines))))
(when (and in-usings (fuel-debug--at-eou-p)) (setq in-usings nil))
(forward-line))
(reverse lines))))))
(defun fuel-debug--highlight-names (names ref face)
(dolist (n names)
(when (not (member n ref))
(put-text-property 0 (length n) 'face face n))))
(defun fuel-debug--uses-new-uses (file uses)
(pop-to-buffer (find-file-noselect file))
(goto-char (point-min))
(if (re-search-forward "^USING: " nil t)
(let ((begin (point))
(end (or (and (re-search-forward "\\_<;\\_>") (point)) (point))))
(kill-region begin end))
(re-search-forward "^IN: " nil t)
(beginning-of-line)
(open-line 2)
(insert "USING: "))
(let ((start (point)))
(insert (mapconcat 'identity uses " ") " ;")
(fill-region start (point) nil)))
(defun fuel-debug--uses-filter (restarts)
(let ((result) (i 1) (rn 0))
(dolist (r restarts (reverse result))
(setq rn (1+ rn))
(when (string-match "Use the .+ vocabulary\\|Defer" r)
(push (list i rn r) result)
(setq i (1+ i))))))
;;; Retrieving USINGs:
(fuel-popup--define fuel-debug--uses-buffer
"*fuel uses*" 'fuel-debug-uses-mode)
(make-variable-buffer-local
(defvar fuel-debug--uses nil))
(make-variable-buffer-local
(defvar fuel-debug--uses-file nil))
(make-variable-buffer-local
(defvar fuel-debug--uses-restarts nil))
(defsubst fuel-debug--uses-insert-title ()
(insert "Infering USING: stanza for " fuel-debug--uses-file ".\n\n"))
(defun fuel-debug--uses-prepare (file)
(fuel--with-popup (fuel-debug--uses-buffer)
(setq fuel-debug--uses-file file
fuel-debug--uses nil
fuel-debug--uses-restarts nil)
(erase-buffer)
(fuel-debug--uses-insert-title)))
(defun fuel-debug--uses-clean ()
(setq fuel-debug--uses-file nil
fuel-debug--uses nil
fuel-debug--uses-restarts nil))
(defun fuel-debug--uses-for-file (file)
(let* ((lines (fuel-debug--file-lines file))
(cmd `(:fuel ((V{ ,@lines } fuel-get-uses)) t t)))
(fuel-debug--uses-prepare file)
(fuel--with-popup (fuel-debug--uses-buffer)
(insert "Asking Factor. Please, wait ...\n")
(fuel-eval--send cmd 'fuel-debug--uses-cont))
(fuel-popup--display (fuel-debug--uses-buffer))))
(defun fuel-debug--uses-cont (retort)
(let ((uses (fuel-eval--retort-result retort))
(err (fuel-eval--retort-error retort)))
(if uses (fuel-debug--uses-display uses)
(fuel-debug--uses-display-err retort))))
(defun fuel-debug--insert-vlist (title vlist)
(goto-char (point-max))
(insert title "\n\n ")
(let ((i 0) (step 5))
(dolist (v vlist)
(setq i (1+ i))
(insert v)
(insert (if (zerop (mod i step)) "\n " " ")))
(unless (zerop (mod i step)) (newline))
(newline)))
(defun fuel-debug--uses-display (uses)
(let* ((inhibit-read-only t)
(old (with-current-buffer (find-file-noselect fuel-debug--uses-file)
(fuel-syntax--usings)))
(old (sort old 'string<))
(new (sort uses 'string<)))
(erase-buffer)
(fuel-debug--uses-insert-title)
(if (equalp old new)
(progn
(insert "Current USING: is already fine!. Type 'q' to bury buffer.\n")
(fuel-debug--uses-clean))
(fuel-debug--highlight-names old new 'fuel-font-lock-debug-unneeded-vocab)
(fuel-debug--highlight-names new old 'fuel-font-lock-debug-missing-vocab)
(fuel-debug--insert-vlist "Current vocabulary list:" old)
(newline)
(fuel-debug--insert-vlist "Correct vocabulary list:" new)
(setq fuel-debug--uses new)
(insert "\nType 'y' to update your USING: to the new one.\n"))))
(defun fuel-debug--uses-display-err (retort)
(let* ((inhibit-read-only t)
(err (fuel-eval--retort-error retort))
(restarts (fuel-debug--uses-filter (fuel-eval--error-restarts err)))
(unique (= 1 (length restarts))))
(erase-buffer)
(fuel-debug--uses-insert-title)
(insert (fuel-eval--retort-output retort))
(newline)
(if (not restarts)
(insert "\nSorry, couldn't infer the vocabulary list.\n")
(setq fuel-debug--uses-restarts restarts)
(if unique (fuel-debug--uses-restart 1)
(insert "\nPlease, type the number of the desired vocabulary:\n\n")
(dolist (r restarts)
(insert (format " :%s %s\n" (first r) (third r))))))))
(defun fuel-debug--uses-update-usings ()
(interactive)
(let ((inhibit-read-only t))
(when (and fuel-debug--uses-file fuel-debug--uses)
(fuel-debug--uses-new-uses fuel-debug--uses-file fuel-debug--uses)
(message "USING: updated!")
(with-current-buffer (fuel-debug--uses-buffer)
(insert "\n Done!")
(fuel-debug--uses-clean)
(fuel-popup--quit)))))
(defun fuel-debug--uses-restart (n)
(when (and (> n 0) (<= n (length fuel-debug--uses-restarts)))
(let* ((inhibit-read-only t)
(restart (format ":%s" (cadr (nth (1- n) fuel-debug--uses-restarts))))
(cmd `(:fuel ([ (:factor ,restart) ] fuel-with-autouse) t t)))
(setq fuel-debug--uses-restarts nil)
(insert "\nAsking Factor. Please, wait ...\n")
(fuel-eval--send cmd 'fuel-debug--uses-cont))))
;;; Fuel uses mode:
(defvar fuel-debug-uses-mode-map
(let ((map (make-keymap)))
(suppress-keymap map)
(dotimes (n 9)
(define-key map (vector (+ ?1 n))
`(lambda () (interactive) (fuel-debug--uses-restart ,(1+ n)))))
(define-key map "y" 'fuel-debug--uses-update-usings)
(define-key map "\C-c\C-c" 'fuel-debug--uses-update-usings)
map))
(defun fuel-debug-uses-mode ()
"A major mode for displaying Factor's USING: inference results."
(interactive)
(kill-all-local-variables)
(buffer-disable-undo)
(setq major-mode 'fuel-debug-uses-mode)
(setq mode-name "Fuel Uses:")
(use-local-map fuel-debug-uses-mode-map))
(provide 'fuel-debug-uses)
;;; fuel-debug-uses.el ends here

77
misc/fuel/fuel-debug.el
View File

@ -14,29 +14,30 @@
;;; Code:
(require 'fuel-base)
(require 'fuel-eval)
(require 'fuel-popup)
(require 'fuel-font-lock)
(require 'fuel-base)
;;; Customization:
(defgroup fuel-debug nil
"Major mode for interaction with the Factor debugger"
"Major mode for interaction with the Factor debugger."
:group 'fuel)
(defcustom fuel-debug-mode-hook nil
"Hook run after `fuel-debug-mode' activates"
"Hook run after `fuel-debug-mode' activates."
:group 'fuel-debug
:type 'hook)
(defcustom fuel-debug-show-short-help t
"Whether to show short help on available keys in debugger"
"Whether to show short help on available keys in debugger."
:group 'fuel-debug
:type 'boolean)
(fuel-font-lock--define-faces
fuel-debug-font-lock font-lock fuel-debug
fuel-font-lock-debug font-lock fuel-debug
((error warning "highlighting errors")
(line variable-name "line numbers in errors/warnings")
(column variable-name "column numbers in errors/warnings")
@ -66,14 +67,14 @@
(defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)")
(defconst fuel-debug--font-lock-keywords
`((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error)
(,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line)
(,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column)
(,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number)
(2 'fuel-debug-font-lock-restart-name))
(,fuel-debug--compiler-info-regex 1 'fuel-debug-font-lock-restart-number)
("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info)
("^Error: " . 'fuel-debug-font-lock-error)))
`((,fuel-debug--error-file-regex . 'fuel-font-lock-debug-error)
(,fuel-debug--error-line-regex 1 'fuel-font-lock-debug-line)
(,fuel-debug--error-cont-regex 1 'fuel-font-lock-debug-column)
(,fuel-debug--restart-regex (1 'fuel-font-lock-debug-restart-number)
(2 'fuel-font-lock-debug-restart-name))
(,fuel-debug--compiler-info-regex 1 'fuel-font-lock-debug-restart-number)
("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-font-lock-debug-info)
("^Error: " . 'fuel-font-lock-debug-error)))
(defun fuel-debug--font-lock-setup ()
(set (make-local-variable 'font-lock-defaults)
@ -82,7 +83,8 @@
;;; Debug buffer:
(defvar fuel-debug--buffer nil)
(fuel-popup--define fuel-debug--buffer
"*fuel debug*" 'fuel-debug-mode)
(make-variable-buffer-local
(defvar fuel-debug--last-ret nil))
@ -90,14 +92,14 @@
(make-variable-buffer-local
(defvar fuel-debug--file nil))
(defun fuel-debug--buffer ()
(or (and (buffer-live-p fuel-debug--buffer) fuel-debug--buffer)
(with-current-buffer
(setq fuel-debug--buffer (get-buffer-create "*fuel dbg*"))
(fuel-debug-mode)
(current-buffer))))
(defun fuel-debug--prepare-compilation (file msg)
(let ((inhibit-read-only t))
(with-current-buffer (fuel-debug--buffer)
(erase-buffer)
(insert msg)
(setq fuel-debug--file file))))
(defun fuel-debug--display-retort (ret &optional success-msg no-pop file)
(defun fuel-debug--display-retort (ret &optional success-msg no-pop)
(let ((err (fuel-eval--retort-error ret))
(inhibit-read-only t))
(with-current-buffer (fuel-debug--buffer)
@ -111,16 +113,15 @@
(when err
(fuel-debug--display-restarts err)
(delete-blank-lines)
(newline)
(let ((hstr (fuel-debug--help-string err file)))
(if fuel-debug-show-short-help
(insert "-----------\n" hstr "\n")
(message "%s" hstr))))
(newline))
(let ((hstr (fuel-debug--help-string err fuel-debug--file)))
(if fuel-debug-show-short-help
(insert "-----------\n" hstr "\n")
(message "%s" hstr)))
(setq fuel-debug--last-ret ret)
(setq fuel-debug--file file)
(goto-char (point-max))
(font-lock-fontify-buffer)
(when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))
(when (and err (not no-pop)) (fuel-popup--display))
(not err))))
(defun fuel-debug--display-output (ret)
@ -179,16 +180,16 @@
(defun fuel-debug-goto-error ()
(interactive)
(let* ((err (or (fuel-debug--buffer-error)
(error "No errors reported")))
(let* ((err (fuel-debug--buffer-error))
(file (or (fuel-debug--buffer-file)
(error "No file associated with error")))
(l/c (fuel-eval--error-line/column err))
(error "No file associated with compilation")))
(l/c (and err (fuel-eval--error-line/column err)))
(line (or (car l/c) 1))
(col (or (cdr l/c) 0)))
(find-file-other-window file)
(goto-line line)
(forward-char col)))
(when line
(goto-line line)
(when col (forward-char col)))))
(defun fuel-debug--read-restart-no ()
(let ((rs (fuel-debug--buffer-restarts)))
@ -225,8 +226,7 @@
(error "%s information not available" info))
(message "Retrieving %s info ..." info)
(unless (fuel-debug--display-retort
(fuel-eval--send/wait `(:fuel ((:factor ,info))))
"" (fuel-debug--buffer-file))
(fuel-eval--send/wait `(:fuel ((:factor ,info)))) "")
(error "Sorry, no %s info available" info))))
@ -239,7 +239,6 @@
(define-key map "\C-c\C-c" 'fuel-debug-goto-error)
(define-key map "n" 'next-line)
(define-key map "p" 'previous-line)
(define-key map "q" 'bury-buffer)
(dotimes (n 9)
(define-key map (vector (+ ?1 n))
`(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t))))
@ -255,15 +254,15 @@ invoking restarts as needed.
(interactive)
(kill-all-local-variables)
(buffer-disable-undo)
(setq major-mode 'factor-mode)
(setq major-mode 'fuel-debug-mode)
(setq mode-name "Fuel Debug")
(use-local-map fuel-debug-mode-map)
(fuel-debug--font-lock-setup)
(setq fuel-debug--file nil)
(setq fuel-debug--last-ret nil)
(setq buffer-read-only t)
(run-hooks 'fuel-debug-mode-hook))
(provide 'fuel-debug)
;;; fuel-debug.el ends here

26
misc/fuel/fuel-eval.el
View File

@ -26,12 +26,13 @@
(cond ((null sexp) "f")
((eq sexp t) "t")
((or (stringp sexp) (numberp sexp)) (format "%S" sexp))
((vectorp sexp) (cons :quotation (append sexp nil)))
((vectorp sexp) (factor (cons :quotation (append sexp nil))))
((listp sexp)
(case (car sexp)
(:array (factor--seq 'V{ '} (cdr sexp)))
(:quote (format "\\ %s" (factor `(:factor ,(cadr sexp)))))
(:quotation (factor--seq '\[ '\] (cdr sexp)))
(:using (factor `(USING: ,@(cdr sexp) :end)))
(:factor (format "%s" (mapconcat 'identity (cdr sexp) " ")))
(:fuel (factor--fuel-factor (cons :rs (cdr sexp))))
(:fuel* (factor--fuel-factor (cons :nrs (cdr sexp))))
@ -43,6 +44,7 @@
(:in (fuel-syntax--current-vocab))
(:usings `(:array ,@(fuel-syntax--usings)))
(:get 'fuel-eval-set-result)
(:end '\;)
(t `(:factor ,(symbol-name sexp))))))
((symbolp sexp) (symbol-name sexp))))
@ -66,7 +68,8 @@
(defsubst factor--fuel-in (in)
(cond ((null in) :in)
((eq in t) "fuel-scratchpad")
((eq in 'f) 'f)
((eq in 't) "fuel-scratchpad")
((stringp in) in)
(t (error "Invalid 'in' (%s)" in))))
@ -115,28 +118,27 @@
(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--retort-p (ret)
(and (listp ret) (= 3 (length ret))))
(defsubst fuel-eval--make-parse-error-retort (str)
(fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil))
(defun fuel-eval--parse-retort (str)
(save-current-buffer
(condition-case nil
(let ((ret (car (read-from-string str))))
(if (fuel-eval--retort-p ret) ret (error)))
(error (fuel-eval--make-parse-error-retort str)))))
(defun fuel-eval--parse-retort (ret)
(if (fuel-eval--retort-p ret) ret
(fuel-eval--make-parse-error-retort ret)))
(defsubst fuel-eval--error-name (err) (car err))
(defsubst fuel-eval--error-restarts (err)
(cdr (assoc :restarts (fuel-eval--error-name-p err 'condition))))
(defun fuel-eval--error-name-p (err name)
(unless (null err)
(or (and (eq (fuel-eval--error-name err) name) err)
(assoc name err))))
(defsubst fuel-eval--error-restarts (err)
(cdr (assoc :restarts (or (fuel-eval--error-name-p err 'condition)
(fuel-eval--error-name-p err 'lexer-error)))))
(defsubst fuel-eval--error-file (err)
(nth 1 (fuel-eval--error-name-p err 'source-file-error)))

50
misc/fuel/fuel-font-lock.el
View File

@ -13,21 +13,32 @@
;;; Code:
(require 'fuel-base)
(require 'fuel-syntax)
(require 'fuel-base)
(require 'font-lock)
;;; Faces:
(defgroup fuel-faces nil
"Faces used by FUEL."
:group 'fuel
:group 'faces)
(defmacro fuel-font-lock--defface (face def group doc)
`(defface ,face (face-default-spec ,def)
,(format "Face for %s." doc)
:group ',group
:group 'fuel-faces
:group 'faces))
(put 'fuel-font-lock--defface 'lisp-indent-function 1)
(defmacro fuel-font-lock--make-face (prefix def-prefix group face def doc)
(let ((face (intern (format "%s-%s" prefix face)))
(def (intern (format "%s-%s-face" def-prefix def))))
`(defface ,face (face-default-spec ,def)
,(format "Face for %s." doc)
:group ',group
:group 'faces)))
`(fuel-font-lock--defface ,face ,def ,group ,doc)))
(defmacro fuel-font-lock--define-faces (prefix def-prefix group faces)
(let ((setup (make-symbol (format "%s--faces-setup" prefix))))
@ -39,20 +50,30 @@
',faces)))
(,setup))))
(fuel-font-lock--define-faces
factor-font-lock font-lock factor-mode
((comment comment "comments")
(constructor type "constructors (<foo>)")
(declaration keyword "declaration words")
(parsing-word keyword "parsing words")
(setter-word function-name "setter words (>>foo)")
(getter-word function-name "getter 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")))
;;; 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--parsing-words-regex . 'factor-font-lock-parsing-word)
(,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--parsing-words-ext-regex . 'factor-font-lock-parsing-word)
(,fuel-syntax--declaration-words-regex 1 'factor-font-lock-declaration)
(,fuel-syntax--declaration-words-regex . '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)
@ -60,6 +81,7 @@
(,fuel-syntax--parent-type-regex 1 '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))
"Font lock keywords definition for Factor mode.")

161
misc/fuel/fuel-help.el
View File

@ -15,22 +15,19 @@
;;; Code:
(require 'fuel-eval)
(require 'fuel-autodoc)
(require 'fuel-completion)
(require 'fuel-font-lock)
(require 'fuel-popup)
(require 'fuel-base)
;;; Customization:
(defgroup fuel-help nil
"Options controlling FUEL's help system"
"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
@ -51,59 +48,8 @@
:type 'integer
: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-log--inhibit-p t))
(when word
(let* ((cmd `(:fuel* (((:quote ,word) synopsis :get)) t))
(ret (fuel-eval--send/wait cmd 20)))
(when (and ret (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")))
(fuel-font-lock--defface fuel-font-lock-help-headlines
'bold fuel-hep "headlines in help buffers")
;;; Help browser history:
@ -113,8 +59,6 @@ displayed in the minibuffer."
(make-ring fuel-help-history-cache-size) ; previous
(make-ring fuel-help-history-cache-size))) ; next
(defvar fuel-help--history-idx 0)
(defun fuel-help--history-push (term)
(when (and (car fuel-help--history)
(not (string= (caar fuel-help--history) (car term))))
@ -136,10 +80,9 @@ displayed in the minibuffer."
;;; Fuel help buffer and internals:
(defun fuel-help--help-buffer ()
(with-current-buffer (get-buffer-create "*fuel help*")
(fuel-help-mode)
(current-buffer)))
(fuel-popup--define fuel-help--buffer
"*fuel help*" 'fuel-help-mode)
(defvar fuel-help--prompt-history nil)
@ -152,7 +95,8 @@ displayed in the minibuffer."
fuel-help-always-ask))
(def (if ask (fuel-completion--read-word prompt
def
'fuel-help--prompt-history)
'fuel-help--prompt-history
t)
def))
(cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t)))
(message "Looking up '%s' ..." def)
@ -165,7 +109,7 @@ displayed in the minibuffer."
(fuel-help--insert-contents def out))))
(defun fuel-help--insert-contents (def str &optional nopush)
(let ((hb (fuel-help--help-buffer))
(let ((hb (fuel-help--buffer))
(inhibit-read-only t)
(font-lock-verbose nil))
(set-buffer hb)
@ -176,14 +120,41 @@ displayed in the minibuffer."
(when (re-search-forward (format "^%s" def) nil t)
(beginning-of-line)
(kill-region (point-min) (point))
(next-line)
(open-line 1)
(fuel-help--history-push (cons def (buffer-string)))))
(set-buffer-modified-p nil)
(pop-to-buffer hb)
(fuel-popup--display)
(goto-char (point-min))
(message "%s" def)))
;;; Help mode font lock:
(defconst fuel-help--headlines
(regexp-opt '("Class description"
"Definition"
"Errors"
"Examples"
"Generic word contract"
"Inputs and outputs"
"Methods"
"Notes"
"Parent topics:"
"See also"
"Syntax"
"Variable description"
"Variable value"
"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-font-lock-help-headlines)))
;;; Interactive help commands:
@ -221,45 +192,40 @@ buffer."
(error "No previous page"))
(fuel-help--insert-contents (car item) (cdr item) t)))
(defun fuel-help-next-headline (&optional count)
(interactive "P")
(end-of-line)
(when (re-search-forward fuel-help--headlines-regexp nil t (or count 1))
(beginning-of-line)))
(defun fuel-help-previous-headline (&optional count)
(interactive "P")
(re-search-backward fuel-help--headlines-regexp nil t count))
;;;; Factor help mode:
;;;; Help mode map:
(defvar fuel-help-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(define-key map "\C-m" 'fuel-help)
(define-key map "q" 'bury-buffer)
(define-key map "b" 'fuel-help-previous)
(define-key map "f" 'fuel-help-next)
(define-key map "l" 'fuel-help-previous)
(define-key map "p" 'fuel-help-previous)
(define-key map "n" 'fuel-help-next)
(define-key map (kbd "TAB") 'fuel-help-next-headline)
(define-key map (kbd "S-TAB") 'fuel-help-previous-headline)
(define-key map [(backtab)] 'fuel-help-previous-headline)
(define-key map (kbd "SPC") 'scroll-up)
(define-key map (kbd "S-SPC") 'scroll-down)
(define-key map "\M-." 'fuel-edit-word-at-point)
(define-key map "\C-cz" 'run-factor)
(define-key map "\C-c\C-z" 'run-factor)
map))
(defconst fuel-help--headlines
(regexp-opt '("Class description"
"Definition"
"Errors"
"Examples"
"Generic word contract"
"Inputs and outputs"
"Methods"
"Notes"
"Parent topics:"
"See also"
"Syntax"
"Variable description"
"Variable value"
"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)))
;;; Help mode definition:
(defun fuel-help-mode ()
"Major mode for browsing Factor documentation.
@ -268,7 +234,7 @@ buffer."
(kill-all-local-variables)
(buffer-disable-undo)
(use-local-map fuel-help-mode-map)
(setq mode-name "Factor Help")
(setq mode-name "FUEL Help")
(setq major-mode 'fuel-help-mode)
(fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
@ -277,6 +243,7 @@ buffer."
(fuel-autodoc-mode)
(run-mode-hooks 'fuel-help-mode-hook)
(setq buffer-read-only t))

54
misc/fuel/fuel-listener.el
View File

@ -13,8 +13,9 @@
;;; Code:
(require 'fuel-eval)
(require 'fuel-stack)
(require 'fuel-completion)
(require 'fuel-eval)
(require 'fuel-connection)
(require 'fuel-syntax)
(require 'fuel-base)
@ -25,7 +26,7 @@
;;; Customization:
(defgroup fuel-listener nil
"Interacting with a Factor listener inside Emacs"
"Interacting with a Factor listener inside Emacs."
:group 'fuel)
(defcustom fuel-listener-factor-binary "~/factor/factor"
@ -76,6 +77,7 @@ buffer."
(make-comint-in-buffer "fuel listener" (current-buffer) factor nil
"-run=listener" (format "-i=%s" image))
(fuel-listener--wait-for-prompt 10000)
(fuel-con--setup-connection (current-buffer))
(fuel-con--send-string/wait (current-buffer)
fuel-con--init-stanza
'(lambda (s) (message "FUEL listener up and running!"))
@ -101,16 +103,10 @@ buffer."
(goto-char (point-max))
(unless seen (error "No prompt found!"))))
;;; Completion support
(defsubst fuel-listener--current-vocab () nil)
(defsubst fuel-listener--usings () nil)
(defun fuel-listener--setup-completion ()
(setq fuel-syntax--current-vocab-function 'fuel-listener--current-vocab)
(setq fuel-syntax--usings-function 'fuel-listener--usings)
(set-syntax-table fuel-syntax--syntax-table))
(defun fuel-listener-nuke ()
(interactive)
(comint-redirect-cleanup)
(fuel-con--setup-connection fuel-listener--buffer))
;;; Interface: starting fuel listener
@ -127,20 +123,52 @@ buffer."
(pop-to-buffer buf)
(switch-to-buffer buf))))
;;; Completion support
(defsubst fuel-listener--current-vocab () nil)
(defsubst fuel-listener--usings () nil)
(defun fuel-listener--setup-completion ()
(setq fuel-syntax--current-vocab-function 'fuel-listener--current-vocab)
(setq fuel-syntax--usings-function 'fuel-listener--usings)
(set-syntax-table fuel-syntax--syntax-table))
;;; Stack mode support
(defun fuel-listener--stack-region ()
(fuel--region-to-string (if (zerop (fuel-syntax--brackets-depth))
(comint-line-beginning-position)
(1+ (fuel-syntax--brackets-start)))))
(defun fuel-listener--setup-stack-mode ()
(setq fuel-stack--region-function 'fuel-listener--stack-region))
;;; Fuel listener mode:
(defun fuel-listener--bol ()
(interactive)
(when (= (point) (comint-bol)) (beginning-of-line)))
;;;###autoload
(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-con--prompt-regex)
(set (make-local-variable 'comint-use-prompt-regexp) t)
(set (make-local-variable 'comint-prompt-read-only) t)
(fuel-listener--setup-completion))
(set-syntax-table fuel-syntax--syntax-table)
(fuel-listener--setup-completion)
(fuel-listener--setup-stack-mode))
(define-key fuel-listener-mode-map "\C-cz" 'run-factor)
(define-key fuel-listener-mode-map "\C-c\C-z" 'run-factor)
(define-key fuel-listener-mode-map "\C-a" 'fuel-listener--bol)
(define-key fuel-listener-mode-map "\C-ca" 'fuel-autodoc-mode)
(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
(define-key fuel-listener-mode-map "\C-cs" 'fuel-stack-mode)
(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
(define-key fuel-listener-mode-map "\C-cv" 'fuel-edit-vocabulary)
(define-key fuel-listener-mode-map "\C-c\C-v" 'fuel-edit-vocabulary)

149
misc/fuel/fuel-mode.el
View File

@ -14,15 +14,18 @@
;;; Code:
(require 'factor-mode)
(require 'fuel-base)
(require 'fuel-syntax)
(require 'fuel-font-lock)
(require 'fuel-debug)
(require 'fuel-help)
(require 'fuel-eval)
(require 'fuel-completion)
(require 'fuel-listener)
(require 'fuel-completion)
(require 'fuel-debug)
(require 'fuel-debug-uses)
(require 'fuel-eval)
(require 'fuel-help)
(require 'fuel-xref)
(require 'fuel-stack)
(require 'fuel-autodoc)
(require 'fuel-font-lock)
(require 'fuel-syntax)
(require 'fuel-base)
;;; Customization:
@ -32,56 +35,76 @@
:group 'fuel)
(defcustom fuel-mode-autodoc-p t
"Whether `fuel-autodoc-mode' gets enable by default in fuel buffers."
"Whether `fuel-autodoc-mode' gets enabled by default in factor buffers."
:group 'fuel-mode
:group 'fuel-autodoc
:type 'boolean)
(defcustom fuel-mode-stack-p nil
"Whether `fuel-stack-mode' gets enabled by default in factor buffers."
:group 'fuel-mode
:group 'fuel-stack
:type 'boolean)
;;; User commands
(defun fuel-run-file (&optional arg)
"Sends the current file to Factor for compilation.
With prefix argument, ask for the file to run."
(interactive "P")
(defun fuel-mode--read-file (arg)
(let* ((file (or (and arg (read-file-name "File: " nil (buffer-file-name) t))
(buffer-file-name)))
(file (expand-file-name file))
(buffer (find-file-noselect file)))
(when (and buffer
(buffer-modified-p buffer)
(y-or-n-p "Save file? "))
(save-buffer buffer))
(cons file buffer)))
(defun fuel-run-file (&optional arg)
"Sends the current file to Factor for compilation.
With prefix argument, ask for the file to run."
(interactive "P")
(let* ((f/b (fuel-mode--read-file arg))
(file (car f/b))
(buffer (cdr f/b)))
(when buffer
(with-current-buffer buffer
(message "Compiling %s ..." file)
(fuel-eval--send `(:fuel (,file fuel-run-file))
`(lambda (r) (fuel--run-file-cont r ,file)))))))
(let ((msg (format "Compiling %s ..." file)))
(fuel-debug--prepare-compilation file msg)
(message msg)
(fuel-eval--send `(:fuel (,file fuel-run-file))
`(lambda (r) (fuel--run-file-cont r ,file))))))))
(defun fuel--run-file-cont (ret file)
(if (fuel-debug--display-retort ret
(format "%s successfully compiled" file)
nil
file)
(if (fuel-debug--display-retort ret (format "%s successfully compiled" file))
(message "Compiling %s ... OK!" file)
(message "")))
(defun fuel-eval-region (begin end &optional arg)
"Sends region to Fuel's listener for evaluation.
Unless called with a prefix, switchs to the compilation results
Unless called with a prefix, switches to the compilation results
buffer in case of errors."
(interactive "r\nP")
(let* ((lines (split-string (buffer-substring-no-properties begin end)
"[\f\n\r\v]+" t))
(let* ((rstr (buffer-substring begin end))
(lines (split-string (substring-no-properties rstr)
"[\f\n\r\v]+"
t))
(cmd `(:fuel (,(mapcar (lambda (l) `(:factor ,l)) lines))))
(cv (fuel-syntax--current-vocab)))
(fuel-debug--prepare-compilation (buffer-file-name)
(format "Evaluating:\n\n%s" rstr))
(fuel-debug--display-retort
(fuel-eval--send/wait cmd 10000)
(format "%s%s"
(if cv (format "IN: %s " cv) "")
(fuel--shorten-region begin end 70))
arg
(buffer-file-name))))
arg)))
(defun fuel-eval-extended-region (begin end &optional arg)
"Sends region extended outwards to nearest definitions,
"Sends region, extended outwards to nearest definition,
to Fuel's listener for evaluation.
Unless called with a prefix, switchs to the compilation results
Unless called with a prefix, switches to the compilation results
buffer in case of errors."
(interactive "r\nP")
(fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point))
@ -90,7 +113,7 @@ buffer in case of errors."
(defun fuel-eval-definition (&optional arg)
"Sends definition around point to Fuel's listener for evaluation.
Unless called with a prefix, switchs to the compilation results
Unless called with a prefix, switches to the compilation results
buffer in case of errors."
(interactive "P")
(save-excursion
@ -100,6 +123,14 @@ buffer in case of errors."
(unless (< begin end) (error "No evaluable definition around point"))
(fuel-eval-region begin end arg))))
(defun fuel-update-usings (&optional arg)
"Asks factor for the vocabularies needed by this file,
optionally updating the its USING: line.
With prefix argument, ask for the file name."
(interactive "P")
(let ((file (car (fuel-mode--read-file arg))))
(when file (fuel-debug--uses-for-file file))))
(defun fuel--try-edit (ret)
(let* ((err (fuel-eval--retort-error ret))
(loc (fuel-eval--retort-result ret)))
@ -115,12 +146,28 @@ buffer in case of errors."
With prefix, asks for the word to edit."
(interactive "P")
(let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
(fuel-completion--read-word "Edit word: ")))
(cmd `(:fuel ((:quote ,word) fuel-get-edit-location))))
(fuel-completion--read-word "Edit word: ")))
(cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
(condition-case nil
(fuel--try-edit (fuel-eval--send/wait cmd))
(error (fuel-edit-vocabulary nil word)))))
(defun fuel-edit-word-doc-at-point (&optional arg)
"Opens a new window visiting the documentation file for the word at point.
With prefix, asks for the word to edit."
(interactive "P")
(let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
(fuel-completion--read-word "Edit word: ")))
(cmd `(:fuel* ((:quote ,word) fuel-get-doc-location))))
(condition-case nil
(fuel--try-edit (fuel-eval--send/wait cmd))
(error (when (y-or-n-p (concat "No documentation found. "
"Do you want to open the vocab's "
"doc file? "))
(find-file-other-window
(format "%s-docs.factor"
(file-name-sans-extension (buffer-file-name)))))))))
(defvar fuel-mode--word-history nil)
(defun fuel-edit-word (&optional arg)
@ -132,7 +179,7 @@ offered."
nil
fuel-mode--word-history
arg))
(cmd `(:fuel ((:quote ,word) fuel-get-edit-location))))
(cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
(fuel--try-edit (fuel-eval--send/wait cmd))))
(defvar fuel--vocabs-prompt-history nil)
@ -153,6 +200,30 @@ With prefix argument, refreshes cached vocabulary list."
(cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t)))
(fuel--try-edit (fuel-eval--send/wait cmd))))
(defun fuel-show-callers (&optional arg)
"Show a list of callers of word at point.
With prefix argument, ask for word."
(interactive "P")
(let ((word (if arg (fuel-completion--read-word "Find callers for: "
(fuel-syntax-symbol-at-point)
fuel-mode--word-history)
(fuel-syntax-symbol-at-point))))
(when word
(message "Looking up %s's callers ..." word)
(fuel-xref--show-callers word))))
(defun fuel-show-callees (&optional arg)
"Show a list of callers of word at point.
With prefix argument, ask for word."
(interactive "P")
(let ((word (if arg (fuel-completion--read-word "Find callees for: "
(fuel-syntax-symbol-at-point)
fuel-mode--word-history)
(fuel-syntax-symbol-at-point))))
(when word
(message "Looking up %s's callees ..." word)
(fuel-xref--show-callees word))))
;;; Minor mode definition:
@ -178,7 +249,10 @@ interacting with a factor listener is at your disposal.
:keymap fuel-mode-map
(setq fuel-autodoc-mode-string "/A")
(when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode)))
(when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode))
(setq fuel-stack-mode-string "/S")
(when fuel-mode-stack-p (fuel-stack-mode fuel-mode)))
;;; Keys:
@ -191,23 +265,32 @@ interacting with a factor listener is at your disposal.
(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)
(fuel-mode--key-1 ?k 'fuel-run-file)
(fuel-mode--key-1 ?l 'fuel-run-file)
(fuel-mode--key-1 ?r 'fuel-eval-region)
(fuel-mode--key-1 ?z 'run-factor)
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
(define-key fuel-mode-map "\C-c\M-<" 'fuel-show-callers)
(define-key fuel-mode-map "\C-c\M->" 'fuel-show-callees)
(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol)
(fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point)
(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
(fuel-mode--key ?e ?l 'fuel-run-file)
(fuel-mode--key ?e ?r 'fuel-eval-region)
(fuel-mode--key ?e ?u 'fuel-update-usings)
(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
(fuel-mode--key ?e ?w 'fuel-edit-word)
(fuel-mode--key ?e ?x 'fuel-eval-definition)
(fuel-mode--key ?d ?> 'fuel-show-callees)
(fuel-mode--key ?d ?< 'fuel-show-callers)
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
(fuel-mode--key ?d ?d 'fuel-help)
(fuel-mode--key ?d ?e 'fuel-stack-effect-sexp)
(fuel-mode--key ?d ?s 'fuel-help-short)

69
misc/fuel/fuel-popup.el Normal file
View File

@ -0,0 +1,69 @@
;;; fuel-popup.el -- popup windows
;; 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: Sun Dec 21, 2008 14:37
;;; Comentary:
;; A minor mode to pop up windows and restore configurations
;; afterwards.
;;; Code:
(make-variable-buffer-local
(defvar fuel-popup--created-window nil))
(make-variable-buffer-local
(defvar fuel-popup--selected-window nil))
(defun fuel-popup--display (&optional buffer)
(when buffer (set-buffer buffer))
(let ((selected-window (selected-window))
(buffer (current-buffer)))
(unless (eq selected-window (get-buffer-window buffer))
(let ((windows))
(walk-windows (lambda (w) (push w windows)) nil t)
(prog1 (pop-to-buffer buffer)
(set (make-local-variable 'fuel-popup--created-window)
(unless (memq (selected-window) windows) (selected-window)))
(set (make-local-variable 'fuel-popup--selected-window)
selected-window))))))
(defun fuel-popup--quit ()
(interactive)
(let ((selected fuel-popup--selected-window)
(created fuel-popup--created-window))
(bury-buffer)
(when (eq created (selected-window)) (delete-window created))
(when (window-live-p selected) (select-window selected))))
(define-minor-mode fuel-popup-mode
"Mode for displaying read only stuff"
nil nil
'(("q" . fuel-popup--quit))
(setq buffer-read-only t))
(defmacro fuel-popup--define (fun name mode)
`(defun ,fun ()
(or (get-buffer ,name)
(with-current-buffer (get-buffer-create ,name)
(funcall ,mode)
(fuel-popup-mode)
(current-buffer)))))
(put 'fuel-popup--define 'lisp-indent-function 1)
(defmacro fuel--with-popup (buffer &rest body)
`(with-current-buffer ,buffer
(let ((inhibit-read-only t))
,@body)))
(put 'fuel--with-popup 'lisp-indent-function 1)
(provide 'fuel-popup)
;;; fuel-popup.el ends here

138
misc/fuel/fuel-stack.el Normal file
View File

@ -0,0 +1,138 @@
;;; fuel-stack.el -- stack inference help
;; 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 20, 2008 01:08
;;; Comentary:
;; Utilities and a minor mode to show inferred stack effects in the
;; echo area.
;;; Code:
(require 'fuel-autodoc)
(require 'fuel-syntax)
(require 'fuel-eval)
(require 'fuel-font-lock)
(require 'fuel-base)
;;; Customization
(defgroup fuel-stack nil
"Customization for FUEL's stack inference engine."
:group 'fuel)
(fuel-font-lock--defface fuel-font-lock-stack-region
'highlight fuel-stack "highlighting the stack effect region")
(defcustom fuel-stack-highlight-period 2.0
"Time, in seconds, the region is highlighted when showing its
stack effect.
Set it to 0 to disable highlighting."
:group 'fuel-stack
:type 'float)
(defcustom fuel-stack-mode-show-sexp-p t
"Whether to show in the echo area the sexp together with its stack effect."
:group 'fuel-stack
:type 'boolean)
;;; Querying for stack effects
(defun fuel-stack--infer-effect (str)
(let ((cmd `(:fuel*
((:using stack-checker effects)
([ (:factor ,str) ] infer effect>string :get)))))
(fuel-eval--retort-result (fuel-eval--send/wait cmd 500))))
(defsubst fuel-stack--infer-effect/prop (str)
(let ((e (fuel-stack--infer-effect str)))
(when e
(put-text-property 0 (length e) 'face 'factor-font-lock-stack-effect e))
e))
(defvar fuel-stack--overlay
(let ((overlay (make-overlay 0 0)))
(overlay-put overlay 'face 'fuel-font-lock-stack-region)
(delete-overlay overlay)
overlay))
(defun fuel-stack-effect-region (begin end)
"Displays the inferred stack effect of the code in current region."
(interactive "r")
(when (> fuel-stack-highlight-period 0)
(move-overlay fuel-stack--overlay begin end))
(condition-case nil
(let* ((str (fuel--region-to-string begin end))
(effect (fuel-stack--infer-effect/prop str)))
(if effect (message "%s" effect)
(message "Couldn't infer effect for '%s'"
(fuel--shorten-region begin end 60)))
(sit-for fuel-stack-highlight-period))
(error))
(delete-overlay fuel-stack--overlay))
(defun fuel-stack-effect-sexp (&optional arg)
"Displays the inferred stack effect for the current sexp.
With prefix argument, use current region instead"
(interactive "P")
(if arg
(call-interactively 'fuel-stack-effect-region)
(fuel-stack-effect-region (1+ (fuel-syntax--beginning-of-sexp-pos))
(if (looking-at-p ";") (point)
(fuel-syntax--end-of-symbol-pos)))))
;;; Stack mode:
(make-variable-buffer-local
(defvar fuel-stack-mode-string " S"
"Modeline indicator for fuel-stack-mode"))
(make-variable-buffer-local
(defvar fuel-stack--region-function
'(lambda ()
(fuel--region-to-string (1+ (fuel-syntax--beginning-of-sexp-pos))))))
(defun fuel-stack--eldoc ()
(when (looking-at-p " \\|$")
(let* ((r (funcall fuel-stack--region-function))
(e (and r
(not (string-match "^ *$" r))
(fuel-stack--infer-effect/prop r))))
(when e
(if fuel-stack-mode-show-sexp-p
(concat (fuel--shorten-str r 30) " -> " e)
e)))))
(define-minor-mode fuel-stack-mode
"Toggle Fuel's Stack 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 Stack mode is enabled, inferred stack effects for current
sexp are automatically displayed in the echo area."
:init-value nil
:lighter fuel-stack-mode-string
:group 'fuel-stack
(setq fuel-autodoc--fallback-function
(when fuel-stack-mode 'fuel-stack--eldoc))
(set (make-local-variable 'eldoc-minor-mode-string) nil)
(unless fuel-autodoc-mode
(set (make-local-variable 'eldoc-documentation-function)
(when fuel-stack-mode 'fuel-stack--eldoc))
(eldoc-mode fuel-stack-mode)
(message "Fuel Stack Autodoc %s" (if fuel-stack-mode "enabled" "disabled"))))
(provide 'fuel-stack)
;;; fuel-stack.el ends here

178
misc/fuel/fuel-syntax.el
View File

@ -19,18 +19,16 @@
(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_"))
(skip-syntax-backward "w_()"))
(defsubst fuel-syntax--symbol-start ()
(defsubst fuel-syntax--beginning-of-symbol-pos ()
(save-excursion (fuel-syntax--beginning-of-symbol) (point)))
(defun fuel-syntax--end-of-symbol ()
"Move point to the end of the current symbol."
(skip-syntax-forward "w_")
(while (looking-at ":") (forward-char)))
(skip-syntax-forward "w_()"))
(defsubst fuel-syntax--symbol-end ()
(defsubst fuel-syntax--end-of-symbol-pos ()
(save-excursion (fuel-syntax--end-of-symbol) (point)))
(put 'factor-symbol 'end-op 'fuel-syntax--end-of-symbol)
@ -45,20 +43,26 @@
;;; Regexps galore:
(defconst fuel-syntax--parsing-words
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
'(":" "::" ";" "<<" "<PRIVATE" ">>"
"B" "BIN:" "C:" "C-STRUCT:" "C-UNION:" "CHAR:"
"DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
"GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
"GENERIC#" "GENERIC:" "HEX:" "HOOK:"
"IN:" "INSTANCE:" "INTERSECTION:"
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "METHOD:" "MIXIN:"
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
"TUPLE:" "T{" "t\\??" "TYPEDEF:"
"UNION:" "USE:" "USING:" "V{" "VARS:" "W{"))
"TUPLE:" "t" "t?" "TYPEDEF:"
"UNION:" "USE:" "USING:" "VARS:"
"call-next-method" "delimiter" "f" "initial:" "read-only"))
(defconst fuel-syntax--parsing-words-ext-regex
(regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
'words))
(defconst fuel-syntax--bracers
'("B" "BV" "C" "CS" "H" "T" "V" "W"))
(defconst fuel-syntax--parsing-words-regex
(regexp-opt fuel-syntax--parsing-words 'words))
(defconst fuel-syntax--brace-words-regex
(format "%s{" (regexp-opt fuel-syntax--bracers t)))
(defconst fuel-syntax--declaration-words
'("flushable" "foldable" "inline" "parsing" "recursive"))
@ -82,7 +86,8 @@
(defconst fuel-syntax--constructor-regex "<[^ >]+>")
(defconst fuel-syntax--setter-regex "\\W>>[^ ]+\\b")
(defconst fuel-syntax--getter-regex "\\(^\\|\\_<\\)[^ ]+?>>\\_>")
(defconst fuel-syntax--setter-regex "\\_<>>.+?\\_>")
(defconst fuel-syntax--symbol-definition-regex
(fuel-syntax--second-word-regex '("SYMBOL:" "VAR:")))
@ -104,7 +109,7 @@
(format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
(defconst fuel-syntax--definition-end-regex
(format "\\(\\(^\\| +\\);\\( +%s\\)*\\($\\| +\\)\\)"
(format "\\(\\(^\\| +\\);\\( *%s\\)*\\($\\| +\\)\\)"
fuel-syntax--declaration-words-regex))
(defconst fuel-syntax--single-liner-regex
@ -124,62 +129,49 @@
(format "\\(%s\\)\\|\\(%s .*\\)"
fuel-syntax--end-of-def-line-regex
fuel-syntax--single-liner-regex))
(defconst fuel-syntax--defun-signature-regex
(format "\\(%s\\|%s\\)"
(format ":[^ ]* [^ ]+\\(%s\\)*" fuel-syntax--stack-effect-regex)
"M[^:]*: [^ ]+ [^ ]+"))
;;; 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)))
(setq fuel-syntax--syntax-table
(let ((table (make-syntax-table)))
;; Default is word constituent
(dotimes (i 256)
(modify-syntax-entry i "w" table))
;; 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)
;; Whitespace (TAB is not whitespace)
(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)
(modify-syntax-entry ?\ " " table)
(modify-syntax-entry ?\n " " table)
;; Strings
(modify-syntax-entry ?\" "\"" table)
(modify-syntax-entry ?\\ "/" table)
table)
"Syntax table used while in Factor mode.")
table))
(defconst fuel-syntax--syntactic-keywords
`(("\\(#!\\)" (1 "<"))
(" \\(!\\)" (1 "<"))
("^\\(!\\)" (1 "<"))
("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
("\\([[({]\\)\\([^ \"\n]\\)" (1 "_") (2 "_"))
("\\([^ \"\n]\\)\\([])}]\\)" (1 "_") (2 "_"))))
`(("\\_<\\(#?!\\) .*\\(\n\\)" (1 "<") (2 ">"))
("\\_<\\(#?!\\)\\(\n\\)" (1 "<") (2 ">"))
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|"))
(" \\(|\\) " (1 "(|"))
(" \\(|\\)$" (1 ")"))
("CHAR: \\(\"\\)\\( \\|$\\)" (1 "w"))
(,(format "\\_<%s\\({\\)\\_>" (regexp-opt fuel-syntax--bracers)) (1 "(}"))
("\\_<\\({\\)\\_>" (1 "(}"))
("\\_<\\(}\\)\\_>" (1 "){"))
("\\_<\\((\\)\\_>" (1 "()"))
("\\_<\\()\\)\\_>" (1 ")("))
("\\_<\\(\\[\\)\\_>" (1 "(]"))
("\\_<\\(\\]\\)\\_>" (1 ")["))))
;;; Source code analysis:
@ -213,16 +205,44 @@
(looking-at fuel-syntax--end-of-def-regex))
(defsubst fuel-syntax--looking-at-emptiness ()
(looking-at "^[ \t]*$"))
(looking-at "^[ ]*$\\|$"))
(defsubst fuel-syntax--is-eol (pos)
(save-excursion
(goto-char (1+ pos))
(fuel-syntax--looking-at-emptiness)))
(defsubst fuel-syntax--line-offset (pos)
(- pos (save-excursion
(goto-char pos)
(beginning-of-line)
(point))))
(defun fuel-syntax--previous-non-blank ()
(forward-line -1)
(while (and (not (bobp)) (fuel-syntax--looking-at-emptiness))
(forward-line -1)))
(defun fuel-syntax--beginning-of-block-pos ()
(save-excursion
(if (> (fuel-syntax--brackets-depth) 0)
(fuel-syntax--brackets-start)
(fuel-syntax--beginning-of-defun)
(point))))
(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)))))
(when (re-search-forward fuel-syntax--setter-regex
(line-end-position)
t)
(let* ((to (match-beginning 0))
(from (fuel-syntax--beginning-of-block-pos)))
(goto-char from)
(let ((depth (fuel-syntax--brackets-depth)))
(and (or (re-search-forward fuel-syntax--constructor-regex to t)
(re-search-forward fuel-syntax--setter-regex to t))
(= depth (fuel-syntax--brackets-depth))))))))
(defun fuel-syntax--at-constructor-line ()
(save-excursion
@ -232,12 +252,38 @@
(defsubst fuel-syntax--at-using ()
(looking-at fuel-syntax--using-lines-regex))
(defun fuel-syntax--in-using ()
(let ((p (point)))
(save-excursion
(and (re-search-backward "^USING: " nil t)
(re-search-forward " ;" nil t)
(< p (match-end 0))))))
(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))
(defsubst fuel-syntax--end-of-defun-pos ()
(save-excursion
(re-search-forward fuel-syntax--end-of-def-regex nil t)
(point)))
(defun fuel-syntax--beginning-of-body ()
(let ((p (point)))
(and (fuel-syntax--beginning-of-defun)
(re-search-forward fuel-syntax--defun-signature-regex p t)
(not (re-search-forward fuel-syntax--end-of-def-regex p t)))))
(defun fuel-syntax--beginning-of-sexp ()
(if (> (fuel-syntax--brackets-depth) 0)
(goto-char (fuel-syntax--brackets-start))
(fuel-syntax--beginning-of-body)))
(defsubst fuel-syntax--beginning-of-sexp-pos ()
(save-excursion (fuel-syntax--beginning-of-sexp) (point)))
;;; USING/IN:

158
misc/fuel/fuel-xref.el Normal file
View File

@ -0,0 +1,158 @@
;;; fuel-xref.el -- showing cross-reference info
;; 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 20, 2008 22:00
;;; Comentary:
;; A mode and utilities for showing cross-reference information.
;;; Code:
(require 'fuel-eval)
(require 'fuel-syntax)
(require 'fuel-popup)
(require 'fuel-font-lock)
(require 'fuel-base)
(require 'button)
;;; Customization:
(defgroup fuel-xref nil
"FUEL's cross-referencing engine."
:group 'fuel)
(defcustom fuel-xref-follow-link-to-word-p t
"Whether, when following a link to a caller, we position the
cursor at the first ocurrence of the used word."
:group 'fuel-xref
:type 'boolean)
(fuel-font-lock--defface fuel-font-lock-xref-link
'link fuel-xref "highlighting links in cross-reference buffers")
(fuel-font-lock--defface fuel-font-lock-xref-vocab
'italic fuel-xref "vocabulary names in cross-reference buffers")
;;; Buttons:
(define-button-type 'fuel-xref--button-type
'action 'fuel-xref--follow-link
'follow-link t
'face 'fuel-font-lock-xref-link)
(defun fuel-xref--follow-link (button)
(let ((file (button-get button 'file))
(line (button-get button 'line)))
(when (not file)
(error "No file for this ref"))
(when (not (file-readable-p file))
(error "File '%s' is not readable" file))
(let ((word fuel-xref--word))
(find-file-other-window file)
(when (numberp line) (goto-line line))
(when (and word fuel-xref-follow-link-to-word-p)
(and (search-forward word
(fuel-syntax--end-of-defun-pos)
t)
(goto-char (match-beginning 0)))))))
;;; The xref buffer:
(fuel-popup--define fuel-xref--buffer
"*fuel xref*" 'fuel-xref-mode)
(make-local-variable (defvar fuel-xref--word nil))
(defvar fuel-xref--help-string "(Press RET or click to follow crossrefs)")
(defun fuel-xref--title (word cc count)
(let ((cc (if cc "using" "used by")))
(put-text-property 0 (length word) 'font-lock-face 'bold word)
(cond ((zerop count) (format "No known words %s %s" cc word))
((= 1 count) (format "1 word %s %s:" cc word))
(t (format "%s words %s %s:" count cc word)))))
(defun fuel-xref--insert-ref (ref)
(when (and (stringp (first ref))
(stringp (third ref))
(numberp (fourth ref)))
(insert " ")
(insert-text-button (first ref)
:type 'fuel-xref--button-type
'help-echo (format "File: %s (%s)"
(third ref)
(fourth ref))
'file (third ref)
'line (fourth ref))
(when (stringp (second ref))
(insert (format " (in %s)" (second ref))))
(newline)
t))
(defun fuel-xref--fill-buffer (word cc refs)
(let ((inhibit-read-only t)
(count 0))
(with-current-buffer (fuel-xref--buffer)
(erase-buffer)
(dolist (ref refs)
(when (fuel-xref--insert-ref ref) (setq count (1+ count))))
(goto-char (point-min))
(insert (fuel-xref--title word cc count) "\n\n")
(when (> count 0)
(setq fuel-xref--word (and cc word))
(goto-char (point-max))
(insert "\n" fuel-xref--help-string "\n"))
(goto-char (point-min))
count)))
(defun fuel-xref--fill-and-display (word cc refs)
(let ((count (fuel-xref--fill-buffer word cc refs)))
(if (zerop count)
(error (fuel-xref--title word cc 0))
(message "")
(fuel-popup--display (fuel-xref--buffer)))))
(defun fuel-xref--show-callers (word)
(let* ((cmd `(:fuel* (((:quote ,word) fuel-callers-xref))))
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
(fuel-xref--fill-and-display word t res)))
(defun fuel-xref--show-callees (word)
(let* ((cmd `(:fuel* (((:quote ,word) fuel-callees-xref))))
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
(fuel-xref--fill-and-display word nil res)))
;;; Xref mode:
(defvar fuel-xref-mode-map
(let ((map (make-sparse-keymap)))
(suppress-keymap map)
(set-keymap-parent map button-buffer-map)
(define-key map "q" 'bury-buffer)
map))
(defun fuel-xref-mode ()
"Mode for displaying FUEL cross-reference information.
\\{fuel-xref-mode-map}"
(interactive)
(kill-all-local-variables)
(buffer-disable-undo)
(use-local-map fuel-xref-mode-map)
(setq mode-name "FUEL Xref")
(setq major-mode 'fuel-xref-mode)
(font-lock-add-keywords nil '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab)))
(setq buffer-read-only t))
(provide 'fuel-xref)
;;; fuel-xref.el ends here

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