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

basis/columns/columns.factor

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

basis/disjoint-sets/disjoint-sets.factor

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

basis/documents/documents.factor

@@ -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 ] }
+        { [ pick { 0 0 } = ] [ 2drop ] }
-        { [ over second zero? ] [ [ first 1- ] dip line-end ] }
+        { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
-        [ pick call ]
+        [ call ]
-    } cond nip ; inline
+    } cond ; inline
 
 : (next-char) ( loc document quot -- loc )
-    -rot {
+    {
-        { [ 2dup doc-end = ] [ drop ] }
+        { [ 2over doc-end = ] [ 2drop ] }
-        { [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
+        { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
-        [ pick call ]
+        [ call ]
-    } cond nip ; inline
+    } cond ; inline
 
 M: char-elt prev-elt
     drop [ drop -1 +col ] (prev-char) ;

basis/formatting/formatting-tests.factor

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

basis/formatting/formatting.factor

@@ -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 / ;
+    10 swap ^ [ * round ] keep / ; inline
-
-: max-width ( string length -- string' ) 
-    short head ;
 
 : >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-d     = "d"                  => [[ [ dup day>> pad-00 ] ]]
-fmt-H     = "H"                  => [[ [ dup hour>> number>string zero-pad ] ]]
+fmt-H     = "H"                  => [[ [ dup hour>> pad-00 ] ]]
-fmt-I     = "I"                  => [[ [ dup hour>> dup 12 > [ 12 - ] when number>string zero-pad ] ]]
+fmt-I     = "I"                  => [[ [ dup hour>> dup 12 > [ 12 - ] when pad-00 ] ]]
-fmt-j     = "j"                  => [[ [ dup day-of-year number>string ] ]]
+fmt-j     = "j"                  => [[ [ dup day-of-year pad-000 ] ]]
-fmt-m     = "m"                  => [[ [ dup month>> number>string zero-pad ] ]]
+fmt-m     = "m"                  => [[ [ dup month>> pad-00 ] ]]
-fmt-M     = "M"                  => [[ [ dup minute>> number>string zero-pad ] ]]
+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-S     = "S"                  => [[ [ dup second>> floor pad-00 ] ]]
-fmt-U     = "U"                  => [[ [ dup week-of-year-sunday ] ]]
+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 ]]

basis/help/cookbook/cookbook.factor

@@ -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 1\nThe number is 2\nThe number is 3"
-    "The number is 2"
-    "The 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 }" }

basis/help/help-tests.factor

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

basis/help/help.factor

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

basis/http/server/cgi/cgi.factor

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

basis/inspector/inspector.factor

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

basis/io/backend/unix/unix-tests.factor

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

basis/io/files/info/unix/linux/linux.factor

@@ -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
+system unix unix.statfs.linux unix.statvfs.linux io.files.links
-specialized-arrays.direct.uint arrays io.files.info.unix ;
+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
-    
+    find-mount-point
-    parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
-    [ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
     {
         [ file-system-name>> >>device-name drop ]
         [ mount-point>> >>mount-point drop ]

basis/io/files/info/windows/windows.factor

@@ -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 ] keep ;
-        [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
-        [ ]
-    } cleave ;
 
 TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;
 

basis/io/files/links/links-docs.factor

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

basis/io/files/links/links.factor

@@ -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 -- )
@@ -11,3 +12,24 @@ HOOK: read-link os ( symlink -- path )
     [ read-link ] dip make-link ;
 
 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) ;

basis/io/files/links/unix/unix-tests.factor

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

basis/logging/logging.factor

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

basis/logging/parser/parser-docs.factor

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

basis/logging/server/server.factor

@@ -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 -- )
+: write-message ( msg word-name level -- )
-    rot harvest {
+    [ harvest ] 2dip {
-        { [ dup empty? ] [ 3drop ] }
+        { [ pick empty? ] [ 3drop ] }
-        { [ dup length 1 = ] [ first -rot f (write-message) ] }
+        { [ pick length 1 = ] [ [ first ] 2dip f (write-message) ] }
         [
-            [ first -rot f (write-message) ] 3keep
+            [ [ first ] 2dip f (write-message) ]
-            rest -rot [ t (write-message) ] 2curry each
+            [ [ 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 -- )

basis/math/ratios/ratios.factor

@@ -50,11 +50,11 @@ M: ratio <= scale <= ;
 M: ratio > scale > ;
 M: ratio >= scale >= ;
 
-M: ratio + 2dup scale + -rot ratio+d / ;
+M: ratio + [ scale + ] [ ratio+d ] 2bi / ;
-M: ratio - 2dup scale - -rot ratio+d / ;
+M: ratio - [ scale - ] [ ratio+d ] 2bi / ;
-M: ratio * 2>fraction * [ * ] dip / ;
+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 ;

basis/mirrors/mirrors.factor

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

basis/models/compose/compose-tests.factor

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

basis/models/compose/compose.factor

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

basis/opengl/capabilities/capabilities.factor

@@ -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
+    [ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
-    [ 2drop ]
-    [ swap " " make throw ]
-    if ; inline
 
 : gl-extensions ( -- seq )
     GL_EXTENSIONS glGetString " " split ;

basis/opengl/opengl.factor

@@ -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 -- )
+:: with-gl-buffer ( binding id quot -- )
-    -rot dupd glBindBuffer
+    binding id glBindBuffer
-    [ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
+    quot [ binding 0 glBindBuffer ] [ ] cleanup ; inline
 
 : with-array-element-buffers ( array-buffer element-buffer quot -- )
-    -rot GL_ELEMENT_ARRAY_BUFFER swap [
+    [ GL_ELEMENT_ARRAY_BUFFER ] 2dip '[
-        swap GL_ARRAY_BUFFER -rot with-gl-buffer
+        GL_ARRAY_BUFFER swap _ with-gl-buffer
     ] with-gl-buffer ; inline
 
 : <gl-buffer> ( target data hint -- id )
-    pick gen-gl-buffer [ [
+    pick gen-gl-buffer [
-        [ dup byte-length swap ] dip glBufferData
+        [
-    ] with-gl-buffer ] keep ;
+            [ [ byte-length ] keep ] dip glBufferData
+        ] with-gl-buffer
+    ] keep ;
 
 : buffer-offset ( int -- alien )
     <alien> ; inline

basis/peg/parsers/parsers.factor

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

basis/peg/peg.factor

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

basis/sequences/deep/deep.factor

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

basis/struct-arrays/struct-arrays-tests.factor

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

basis/struct-arrays/struct-arrays.factor

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

basis/tools/deploy/macosx/macosx.factor

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

basis/tools/profiler/profiler-docs.factor

@@ -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" 
+ARTICLE: "profiler-limitations" "Profiler limitations"
-"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:"
+"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 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 " { $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"
 

basis/ui/gadgets/borders/borders.factor

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

basis/ui/gadgets/editors/editors.factor

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

basis/ui/gadgets/menus/menus.factor

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

basis/ui/gadgets/presentations/presentations-docs.factor

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

basis/ui/gadgets/presentations/presentations.factor

@@ -11,8 +11,8 @@ IN: ui.gadgets.presentations
 TUPLE: presentation < button object hook ;
 
 : invoke-presentation ( presentation command -- )
-    over dup hook>> call
+    [ [ dup hook>> call ] [ object>> ] bi ] dip
-    [ object>> ] dip invoke-command ;
+    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 )
+: show-operations-menu ( presentation -- )
-    [ object>> ]
+    [ ] [ object>> ] [ dup hook>> curry ] tri
-    [ dup hook>> curry ]
+    <operations-menu> show-menu ;
-    [ object>> object-operations ]
-    tri <commands-menu> ;
-
-: operations-menu ( presentation -- )
-    dup <operations-menu> show-menu ;
 
 presentation H{
-    { T{ button-down f f 3 } [ operations-menu ] }
+    { T{ button-down f f 3 } [ show-operations-menu ] }
-    { T{ mouse-leave } [ dup hide-status button-update ] }
+    { 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

basis/ui/gadgets/tracks/tracks-tests.factor

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

basis/ui/gadgets/tracks/tracks.factor

@@ -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-dim ] bi v+ ;
-    [ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
-    v+ ;
 
 M: track pref-dim* ( gadget -- dim )
     [ track-pref-dims-1 ]

basis/ui/tools/tools-tests.factor

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

basis/uuid/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

basis/uuid/summary.txt

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

basis/uuid/uuid-docs.factor

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

basis/uuid/uuid-tests.factor

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

basis/uuid/uuid.factor

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

basis/xml/tests/test.factor

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

basis/xml/writer/writer.factor

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

core/compiler/errors/errors-docs.factor

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

core/kernel/kernel-tests.factor

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

core/math/math.factor

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

core/words/words.factor

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

extra/bunny/model/model.factor

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

extra/easy-help/easy-help.factor

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

extra/easy-help/expand-markup/expand-markup.factor

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

extra/fuel/fuel.factor

@@ -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
+USING: accessors arrays assocs classes.tuple combinators
-combinators compiler.units continuations debugger definitions
+compiler.units continuations debugger definitions io io.pathnames
-eval help io io.files io.pathnames io.streams.string kernel
+io.streams.string kernel lexer math math.order memoize namespaces
-lexer listener listener.private make math memoize namespaces
+parser prettyprint sequences sets sorting source-files strings summary
-parser prettyprint prettyprint.config quotations sequences sets
+tools.vocabs vectors vocabs vocabs.parser words ;
-sorting source-files strings tools.vocabs vectors vocabs
-vocabs.loader vocabs.parser ;
 
 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,26 +34,22 @@ t clone fuel-eval-res-flag set-global
 : fuel-eval-non-restartable ( -- )
     f fuel-eval-res-flag set-global ; inline
 
-: push-fuel-status ( -- )
+: fuel-push-status ( -- )
-    in get use get clone display-stacks? get restarts get-global clone
+    in get use get clone restarts get-global clone
     fuel-status boa
     fuel-status-stack get push ;
 
-: pop-fuel-status ( -- )
+: 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 {
+        fuel-status-stack get pop
         [ in>> in set ]
         [ use>> clone use set ]
-            [ ds?>> display-stacks? swap [ on ] [ off ] if ]
+        [ restarts>> fuel-pop-restarts ] tri
-            [
-                restarts>> fuel-eval-restartable? [ drop ] [
-                    clone restarts set-global
-                ] if
-            ]
-        } cleave
     ] unless ;
 
-
 ! Lispy pretty printing
 
 GENERIC: fuel-pprint ( obj -- )
@@ -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 ; inline
-        "(" write
-        [ " " write ] [ fuel-pprint ] interleave
-        ")" write
-    ] if ;
 
 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
+    fuel-push-status
-    display-stacks? off
     fuel-forget-error
     fuel-forget-result
     fuel-forget-output ;
 
-: (fuel-end-eval) ( quot -- )
+: (fuel-end-eval) ( output -- )
-    with-string-writer fuel-eval-output set-global
+    fuel-eval-output set-global fuel-retort fuel-pop-status ; inline
-    fuel-retort pop-fuel-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-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer
-    fuel-retort ;
+    (fuel-end-eval) ;
 
-: fuel-eval ( lines -- )
+! Loading files
-    (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline
 
-: 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 [
+    where fuel-normalize-loc 2array fuel-eval-set-result ; inline
-       first2 [ (normalize-path) ] dip 2array fuel-eval-set-result
-    ] when* ; 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
 

extra/google-tech-talk/google-tech-talk.factor

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

extra/size-of/size-of.factor

@@ -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 ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/ui/gadgets/plot/plot.factor

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

extra/ui/gadgets/slate/slate.factor

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

extra/ui/gadgets/tiling/tiling.factor

@@ -1,10 +1,42 @@
 
 USING: kernel sequences math math.order
-       ui.gadgets ui.gadgets.tracks ui.gestures
+       ui.gadgets ui.gadgets.tracks ui.gestures accessors fry
-       bake.fry accessors ;
+       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 ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

misc/fuel/README

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

misc/fuel/factor-mode.el

@@ -24,8 +24,9 @@
 ;;; Customization:
 
 (defgroup factor-mode nil
-  "Major mode for Factor source code"
+  "Major mode for Factor source code."
-  :group 'fuel)
+  :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))
+      (let* ((bs (fuel-syntax--brackets-start))
-             (cl (fuel-syntax--brackets-end))
+             (be (fuel-syntax--brackets-end))
-             (ln (line-number-at-pos))
+             (ln (line-number-at-pos)))
-             (iop (fuel-syntax--indentation-at op)))
+        (when (> ln (line-number-at-pos bs))
-        (when (> ln (line-number-at-pos op))
+          (cond ((and (> be 0)
-          (if (and (> cl 0)
+                      (= (- be (point)) (current-indentation))
-                   (= (- cl (point)) (current-indentation))
+                      (= ln (line-number-at-pos be)))
-                   (= ln (line-number-at-pos cl)))
+                 (fuel-syntax--indentation-at bs))
-              iop
+                ((or (fuel-syntax--is-eol bs)
-            (fuel-syntax--increased-indentation iop)))))))
+                     (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

misc/fuel/fu.el

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

misc/fuel/fuel-autodoc.el

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

misc/fuel/fuel-base.el

@@ -25,8 +25,8 @@
 
 ;;;###autoload
 (defgroup fuel nil
-  "Factor's Ultimate Emacs Library"
+  "Factor's Ultimate Emacs Library."
-  :group 'language)
+  :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))))

misc/fuel/fuel-completion.el

@@ -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)
+(defun fuel-completion--complete (prefix vocabs)
-  (let* ((words (fuel-completion--word-list prefix))
+  (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)))))))

misc/fuel/fuel-connection.el

@@ -46,8 +46,7 @@
         (cons :id (random))
         (cons :string str)
         (cons :continuation cont)
-        (cons :buffer (or sender-buffer (current-buffer)))
+        (cons :buffer (or sender-buffer (current-buffer)))))
-        (cons :output "")))
 
 (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--eot-marker "<~FUEL~>")
-(defconst fuel-con--init-stanza (format "USE: fuel %S write" fuel-con--eot-marker))
+(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)
+          (comint-redirect-send-command (format "%s" str) cbuf nil t))))))
-                                        (fuel-log--buffer) nil t))))))
 
 (defun fuel-con--process-completed-request (req)
-  (let ((str (fuel-con--request-output req))
+  (let ((cont (fuel-con--request-continuation req))
-        (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)
+            (funcall cont (fuel-con--comint-buffer-form))
-            (fuel-log--info "<%s>: processed\n\t%s" id str))
+            (fuel-log--info "<%s>: processed\n\t%s" id req))
-        (error (fuel-log--error "<%s>: continuation failed %S \n\t%s"
+        (error (fuel-log--error
-                                id rstr cerr))))))
+                "<%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) ""))
 
 (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)))))

misc/fuel/fuel-debug-uses.el

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

misc/fuel/fuel-debug.el

@@ -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-file-regex . 'fuel-font-lock-debug-error)
-    (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line)
+    (,fuel-debug--error-line-regex 1 'fuel-font-lock-debug-line)
-    (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column)
+    (,fuel-debug--error-cont-regex 1 'fuel-font-lock-debug-column)
-    (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number)
+    (,fuel-debug--restart-regex (1 'fuel-font-lock-debug-restart-number)
-                                (2 'fuel-debug-font-lock-restart-name))
+                                (2 'fuel-font-lock-debug-restart-name))
-    (,fuel-debug--compiler-info-regex 1 'fuel-debug-font-lock-restart-number)
+    (,fuel-debug--compiler-info-regex 1 'fuel-font-lock-debug-restart-number)
-    ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info)
+    ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-font-lock-debug-info)
-    ("^Error: " . 'fuel-debug-font-lock-error)))
+    ("^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 ()
+(defun fuel-debug--prepare-compilation (file msg)
-  (or (and (buffer-live-p fuel-debug--buffer) fuel-debug--buffer)
+  (let ((inhibit-read-only t))
-      (with-current-buffer
+    (with-current-buffer (fuel-debug--buffer)
-          (setq fuel-debug--buffer (get-buffer-create "*fuel dbg*"))
+      (erase-buffer)
-        (fuel-debug-mode)
+      (insert msg)
-        (current-buffer))))
+      (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)
+        (newline))
-        (let ((hstr (fuel-debug--help-string err file)))
+      (let ((hstr (fuel-debug--help-string err fuel-debug--file)))
         (if fuel-debug-show-short-help
             (insert "-----------\n" hstr "\n")
-            (message "%s" hstr))))
+          (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)
+  (let* ((err (fuel-debug--buffer-error))
-                  (error "No errors reported")))
          (file (or (fuel-debug--buffer-file)
-                   (error "No file associated with error")))
+                   (error "No file associated with compilation")))
-         (l/c (fuel-eval--error-line/column err))
+         (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)
+    (when line
       (goto-line line)
-    (forward-char col)))
+      (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-eval--send/wait `(:fuel ((:factor ,info)))) "")
-             "" (fuel-debug--buffer-file))
       (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

misc/fuel/fuel-eval.el

@@ -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)
+(defun fuel-eval--parse-retort (ret)
-  (save-current-buffer
+  (if (fuel-eval--retort-p ret) ret
-    (condition-case nil
+    (fuel-eval--make-parse-error-retort ret)))
-        (let ((ret (car (read-from-string str))))
-          (if (fuel-eval--retort-p ret) ret (error)))
-      (error (fuel-eval--make-parse-error-retort str)))))
 
 (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)))
 

misc/fuel/fuel-font-lock.el

@@ -13,21 +13,32 @@
 
 ;;; Code:
 
-(require 'fuel-base)
 (require 'fuel-syntax)
+(require 'fuel-base)
 
 (require 'font-lock)
 
 
 ;;; Faces:
 
-(defmacro fuel-font-lock--make-face (prefix def-prefix group face def doc)
+(defgroup fuel-faces nil
-  (let ((face (intern (format "%s-%s" prefix face)))
+  "Faces used by FUEL."
-        (def (intern (format "%s-%s-face" def-prefix def))))
+  :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 'faces)))
+     :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))))
+    `(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 . 'factor-font-lock-declaration)
-    (,fuel-syntax--declaration-words-regex 1 'factor-font-lock-declaration)
     (,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
     (,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
     (,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
@@ -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.")

misc/fuel/fuel-help.el

@@ -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)))
+(fuel-font-lock--defface fuel-font-lock-help-headlines
-  "Face for headlines in help buffers."
+  'bold fuel-hep "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")))
 
 
 ;;; 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 ()
+(fuel-popup--define fuel-help--buffer
-  (with-current-buffer (get-buffer-create "*fuel help*")
+  "*fuel help*" 'fuel-help-mode)
-    (fuel-help-mode)
+
-    (current-buffer)))
 
 (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"
+;;; Help mode definition:
-                "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)))
 
 (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))
 
 

misc/fuel/fuel-listener.el

@@ -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!"))))
 
-
+(defun fuel-listener-nuke ()
-;;; Completion support
+  (interactive)
-
+  (comint-redirect-cleanup)
-(defsubst fuel-listener--current-vocab () nil)
+  (fuel-con--setup-connection fuel-listener--buffer))
-(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))
 
 
 ;;; 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)

misc/fuel/fuel-mode.el

@@ -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)
+(defun fuel-mode--read-file (arg)
-  "Sends the current file to Factor for compilation.
-With prefix argument, ask for the file to run."
-  (interactive "P")
   (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)
+        (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)))))))
+                           `(lambda (r) (fuel--run-file-cont r ,file))))))))
 
 (defun fuel--run-file-cont (ret file)
-  (if (fuel-debug--display-retort ret
+  (if (fuel-debug--display-retort ret (format "%s successfully compiled" file))
-                                  (format "%s successfully compiled" file)
-                                  nil
-                                  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)
+  (let* ((rstr (buffer-substring begin end))
-                              "[\f\n\r\v]+" t))
+         (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
+     arg)))
-     (buffer-file-name))))
 
 (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)))
@@ -116,11 +147,27 @@ 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))))
+         (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)
 
 

misc/fuel/fuel-popup.el

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

misc/fuel/fuel-stack.el

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

misc/fuel/fuel-syntax.el

@@ -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_")
+  (skip-syntax-forward "w_()"))
-  (while (looking-at ":") (forward-char)))
 
-(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" ">>"
+  '(":" "::" ";" "<<" "<PRIVATE" ">>"
-    "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
+    "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:"
+    "TUPLE:" "t" "t?" "TYPEDEF:"
-    "UNION:" "USE:" "USING:" "V{" "VARS:" "W{"))
+    "UNION:" "USE:" "USING:" "VARS:"
+    "call-next-method" "delimiter" "f" "initial:" "read-only"))
 
-(defconst fuel-syntax--parsing-words-ext-regex
+(defconst fuel-syntax--bracers
-  (regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
+  '("B" "BV" "C" "CS" "H" "T" "V" "W"))
-              'words))
+
+(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
+(setq fuel-syntax--syntax-table
-  (let ((i 0)
+  (let ((table (make-syntax-table)))
-        (table (make-syntax-table)))
+    ;; Default is word constituent
-    ;; Default is atom-constituent
+    (dotimes (i 256)
-    (while (< i 256)
+      (modify-syntax-entry i "w" table))
-      (modify-syntax-entry i "_   " table)
-      (setq i (1+ i)))
 
-    ;; Word components.
+    ;; Whitespace (TAB is not whitespace)
-    (setq i ?0)
-    (while (<= i ?9)
-      (modify-syntax-entry i "w   " table)
-      (setq i (1+ i)))
-    (setq i ?A)
-    (while (<= i ?Z)
-      (modify-syntax-entry i "w   " table)
-      (setq i (1+ i)))
-    (setq i ?a)
-    (while (<= i ?z)
-      (modify-syntax-entry i "w   " table)
-      (setq i (1+ i)))
-
-    ;; Whitespace
-    (modify-syntax-entry ?\t " " table)
     (modify-syntax-entry ?\f " " table)
     (modify-syntax-entry ?\r " " table)
-    (modify-syntax-entry ?  " " table)
+    (modify-syntax-entry ?\  " " table)
-
+    (modify-syntax-entry ?\n " " table)
-    ;; (end of) Comments
-    (modify-syntax-entry ?\n ">" table)
-
-    ;; Parenthesis
-    (modify-syntax-entry ?\[ "(]  " table)
-    (modify-syntax-entry ?\] ")[  " table)
-    (modify-syntax-entry ?{ "(}  " table)
-    (modify-syntax-entry ?} "){  " table)
-
-    (modify-syntax-entry ?\( "()" table)
-    (modify-syntax-entry ?\) ")(" table)
 
     ;; Strings
     (modify-syntax-entry ?\" "\"" table)
     (modify-syntax-entry ?\\ "/" table)
-    table)
+
-  "Syntax table used while in Factor mode.")
+    table))
 
 (defconst fuel-syntax--syntactic-keywords
-  `(("\\(#!\\)" (1 "<"))
+  `(("\\_<\\(#?!\\) .*\\(\n\\)" (1 "<") (2 ">"))
-    (" \\(!\\)" (1 "<"))
+    ("\\_<\\(#?!\\)\\(\n\\)" (1 "<") (2 ">"))
-    ("^\\(!\\)" (1 "<"))
+    ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
-    ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
+    ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
-    ("\\([[({]\\)\\([^ \"\n]\\)" (1 "_") (2 "_"))
+    ("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|"))
-    ("\\([^ \"\n]\\)\\([])}]\\)" (1 "_") (2 "_"))))
+    (" \\(|\\) " (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))
+    (when (re-search-forward fuel-syntax--setter-regex
-        (re-search-forward fuel-syntax--setter-regex (line-end-position) t)
+                             (line-end-position)
-      (forward-line -1)
+                             t)
-      (or (fuel-syntax--at-constructor-line)
+      (let* ((to (match-beginning 0))
-          (fuel-syntax--at-setter-line)))))
+             (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:
 

misc/fuel/fuel-xref.el

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

unmaintained/size-of/size-of.factor

@@ -1,39 +0,0 @@
-
-USING: kernel namespaces sequences
-       io io.files io.launcher io.encodings.ascii
-       bake builder.util
-       accessors vars
-       math.parser ;
-
-IN: size-of
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: headers
-
-: include-headers ( -- seq )
-  headers> [ `{ "#include <" , ">" } to-string ] map ;
-
-: size-of-c-program ( type -- lines )
-  `{
-    "#include <stdio.h>"
-    include-headers
-    { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" }
-  }
-  to-strings ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: c-file ( -- path ) "size-of.c" temp-file ;
-
-: exe ( -- path ) "size-of" temp-file ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: size-of ( type -- n )
-  size-of-c-program c-file ascii set-file-lines
-
-  { "gcc" c-file "-o" exe } to-strings
-  [ "Error compiling generated C program" print ] run-or-bail
-
-  exe ascii <process-reader> contents string>number ;

vm/os-unix.c

@@ -216,18 +216,21 @@ void safe_write(int fd, void *data, size_t size)
 		fatal_error("error writing fd",errno);
 }
 
-void safe_read(int fd, void *data, size_t size)
+bool safe_read(int fd, void *data, size_t size)
 {
 	ssize_t bytes = read(fd,data,size);
 	if(bytes < 0)
 	{
 		if(errno == EINTR)
-			safe_read(fd,data,size);
+			return safe_read(fd,data,size);
 		else
+		{
 			fatal_error("error reading fd",errno);
+			return false;
 		}
-	else if(bytes != size)
+	}
-		fatal_error("unexpected eof on fd",bytes);
+	else
+		return (bytes == size);
 }
 
 void *stdin_loop(void *arg)
@@ -237,7 +240,9 @@ void *stdin_loop(void *arg)
 
 	while(loop_running)
 	{
-		safe_read(control_read,buf,1);
+		if(!safe_read(control_read,buf,1))
+			break;
+
 		if(buf[0] != 'X')
 			fatal_error("stdin_loop: bad data on control fd",buf[0]);
 
@@ -258,16 +263,15 @@ void *stdin_loop(void *arg)
 			{
 				safe_write(size_write,&bytes,sizeof(bytes));
 
-				if(write(stdin_write,buf,bytes) != bytes)
+				if(!check_write(stdin_write,buf,bytes))
 					loop_running = false;
 				break;
 			}
 		}
 	}
 
-
 	safe_close(stdin_write);
-	safe_close(control_write);
+	safe_close(control_read);
 
 	return NULL;
 }