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

basis/db/tester/tester.factor

@@ -46,12 +46,17 @@ test-2 "TEST2" {
 
 : db-tester2 ( test-db -- )
     [
-        [ test-1 recreate-table ] with-db
-    ] [
         [
-            2 [
+            test-1 ensure-table
-                    10 random 100 random 100 random 100 random test-1 boa
+            test-2 ensure-table
-                    insert-tuple yield
-            ] parallel-each
         ] with-db
+    ] [
+        <db-pool> [
+            10 [
+                10 [
+                    f 100 random 100 random 100 random test-1 boa
+                    insert-tuple yield
+                ] times
+            ] parallel-each
+        ] with-pooled-db
     ] bi ;

basis/html/templates/chloe/chloe-tests.factor

@@ -1,7 +1,8 @@
 USING: html.templates html.templates.chloe
 tools.test io.streams.string kernel sequences ascii boxes
 namespaces xml html.components html.forms
-splitting unicode.categories furnace accessors ;
+splitting unicode.categories furnace accessors
+html.templates.chloe.compiler ;
 IN: html.templates.chloe.tests
 
 : run-template
@@ -163,3 +164,9 @@ TUPLE: person first-name last-name ;
         "test12" test-template call-template
     ] run-template
 ] unit-test
+
+[
+    [
+        "test13" test-template call-template
+    ] run-template
+] [ error>> T{ unknown-chloe-tag f "this-tag-does-not-exist" } = ] must-fail-with

basis/html/templates/chloe/compiler/compiler.factor

@@ -76,10 +76,13 @@ DEFER: compile-element
         [ drop tag-stack get pop* ]
     } cleave ;
 
+ERROR: unknown-chloe-tag tag ;
+
 : compile-chloe-tag ( tag -- )
-    ! "Unknown chloe tag: " prepend throw
     dup main>> dup tags get at
-    [ curry assert-depth ] [ 2drop ] ?if ;
+    [ curry assert-depth ]
+    [ unknown-chloe-tag ]
+    ?if ;
 
 : compile-element ( element -- )
     {

basis/html/templates/chloe/test/test13.xml

@@ -0,0 +1,7 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+  <t:this-tag-does-not-exist />
+
+</t:chloe>

basis/http/http.factor

@@ -45,8 +45,8 @@ IN: http
 
 : check-header-string ( str -- str )
     #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
-    dup "\r\n\"" intersect empty?
+    dup "\r\n\"" intersects?
-    [ "Header injection attack" throw ] unless ;
+    [ "Header injection attack" throw ] when ;
 
 : write-header ( assoc -- )
     >alist sort-keys [
@@ -97,8 +97,8 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
     ] { } make ;
 
 : check-cookie-string ( string -- string' )
-    dup "=;'\"\r\n" intersect empty?
+    dup "=;'\"\r\n" intersects?
-    [ "Bad cookie name or value" throw ] unless ;
+    [ "Bad cookie name or value" throw ] when ;
 
 : unparse-cookie-value ( key value -- )
     {

basis/io/directories/directories-docs.factor

@@ -50,6 +50,10 @@ HELP: with-directory-files
 { $values { "path" "a pathname string" } { "quot" quotation } }
 { $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ".  Restores the current directory after the quotation is called." } ;
 
+HELP: with-directory-entries
+{ $values { "path" "a pathname string" } { "quot" quotation } }
+{ $description "Calls the quotation with the directory entries on the stack and with the directory set as the " { $link current-directory } ".  Restores the current directory after the quotation is called." } ;
+
 HELP: delete-file
 { $values { "path" "a pathname string" } }
 { $description "Deletes a file." }
@@ -122,6 +126,7 @@ ARTICLE: "io.directories.listing" "Directory listing"
 "Directory listing:"
 { $subsection directory-entries }
 { $subsection directory-files }
+{ $subsection with-directory-entries }
 { $subsection with-directory-files } ;
 
 ARTICLE: "io.directories.create" "Creating directories"

basis/io/directories/directories.factor

@@ -41,6 +41,9 @@ HOOK: (directory-entries) os ( path -- seq )
 : directory-files ( path -- seq )
     directory-entries [ name>> ] map ;
 
+: with-directory-entries ( path quot -- )
+    '[ "" directory-entries @ ] with-directory ; inline
+
 : with-directory-files ( path quot -- )
     '[ "" directory-files @ ] with-directory ; inline
 

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

@@ -114,30 +114,6 @@ M: file-info file-mode? [ permissions>> ] dip mask? ;
 
 PRIVATE>
 
-: ch>file-type ( ch -- type )
-    {
-        { CHAR: b [ +block-device+ ] }
-        { CHAR: c [ +character-device+ ] }
-        { CHAR: d [ +directory+ ] }
-        { CHAR: l [ +symbolic-link+ ] }
-        { CHAR: s [ +socket+ ] }
-        { CHAR: p [ +fifo+ ] }
-        { CHAR: - [ +regular-file+ ] }
-        [ drop +unknown+ ]
-    } case ;
-
-: file-type>ch ( type -- string )
-    {
-        { +block-device+ [ CHAR: b ] }
-        { +character-device+ [ CHAR: c ] }
-        { +directory+ [ CHAR: d ] }
-        { +symbolic-link+ [ CHAR: l ] }
-        { +socket+ [ CHAR: s ] }
-        { +fifo+ [ CHAR: p ] }
-        { +regular-file+ [ CHAR: - ] }
-        [ drop CHAR: - ]
-    } case ;
-
 : UID           OCT: 0004000 ; inline
 : GID           OCT: 0002000 ; inline
 : STICKY        OCT: 0001000 ; inline
@@ -251,3 +227,47 @@ M: string set-file-group ( path string -- )
 
 : file-group-name ( path -- string )
     file-group-id group-name ;
+
+: ch>file-type ( ch -- type )
+    {
+        { CHAR: b [ +block-device+ ] }
+        { CHAR: c [ +character-device+ ] }
+        { CHAR: d [ +directory+ ] }
+        { CHAR: l [ +symbolic-link+ ] }
+        { CHAR: s [ +socket+ ] }
+        { CHAR: p [ +fifo+ ] }
+        { CHAR: - [ +regular-file+ ] }
+        [ drop +unknown+ ]
+    } case ;
+
+: file-type>ch ( type -- ch )
+    {
+        { +block-device+ [ CHAR: b ] }
+        { +character-device+ [ CHAR: c ] }
+        { +directory+ [ CHAR: d ] }
+        { +symbolic-link+ [ CHAR: l ] }
+        { +socket+ [ CHAR: s ] }
+        { +fifo+ [ CHAR: p ] }
+        { +regular-file+ [ CHAR: - ] }
+        [ drop CHAR: - ]
+    } case ;
+
+<PRIVATE
+
+: file-type>executable ( directory-entry -- string )
+    name>> any-execute? "*" "" ? ;
+
+PRIVATE>
+
+: file-type>trailing ( directory-entry -- string )
+    dup type>>
+    {
+        { +directory+ [ drop "/" ] }
+        { +symbolic-link+ [ drop "@" ] }
+        { +fifo+ [ drop "|" ] }
+        { +socket+ [ drop "=" ] }
+        { +whiteout+ [ drop "%" ] }
+        { +unknown+ [ file-type>executable ] }
+        { +regular-file+ [ file-type>executable ] }
+        [ drop file-type>executable ]
+    } case ;

basis/regexp/dfa/dfa.factor

@@ -57,7 +57,7 @@ IN: regexp.dfa
     dup
     [ nfa-table>> final-states>> keys ]
     [ dfa-table>> transitions>> states ] bi
-    [ intersect empty? not ] with filter
+    [ intersects? ] with filter
 
     swap dfa-table>> final-states>>
     [ conjoin ] curry each ;

basis/smtp/smtp.factor

@@ -68,8 +68,8 @@ ERROR: bad-email-address email ;
 
 : validate-address ( string -- string' )
     #! Make sure we send funky stuff to the server by accident.
-    dup "\r\n>" intersect empty?
+    dup "\r\n>" intersects?
-    [ bad-email-address ] unless ;
+    [ bad-email-address ] when ;
 
 : mail-from ( fromaddr -- )
     validate-address
@@ -170,8 +170,8 @@ M: plain-auth send-auth
 ERROR: invalid-header-string string ;
 
 : validate-header ( string -- string' )
-    dup "\r\n" intersect empty?
+    dup "\r\n" intersects?
-    [ invalid-header-string ] unless ;
+    [ invalid-header-string ] when ;
 
 : write-header ( key value -- )
     [ validate-header write ]

basis/sorting/slots/slots-docs.factor

@@ -6,17 +6,17 @@ IN: sorting.slots
 
 HELP: compare-slots
 { $values
-     { "sort-specs" "a sequence of accessor/comparator pairs" }
+     { "sort-specs" "a sequence of accessors ending with a comparator" }
      { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
 }
 { $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
 
 HELP: sort-by-slots
 { $values
-     { "seq" sequence } { "sort-specs" "a sequence of accessor/comparator pairs" }
+     { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
      { "seq'" sequence }
 }
-{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." }
+{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
 { $examples
     "Sort by slot c, then b descending:"
     { $example
@@ -32,6 +32,13 @@ HELP: sort-by-slots
     }
 } ;
 
+HELP: split-by-slots
+{ $values
+     { "accessor-seqs" "a sequence of sequences of tuple accessors" }
+     { "quot" quotation }
+}
+{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
+
 ARTICLE: "sorting.slots" "Sorting by slots"
 "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
 "Comparing two objects by a sequence of slots:"

basis/sorting/slots/slots-tests.factor

@@ -1,10 +1,12 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math.order sorting.slots tools.test
-sorting.human ;
+sorting.human arrays sequences kernel assocs multiline ;
 IN: sorting.literals.tests
 
-TUPLE: sort-test a b c ;
+TUPLE: sort-test a b c tuple2 ;
+
+TUPLE: tuple2 d ;
 
 [
     {
@@ -43,8 +45,101 @@ TUPLE: sort-test a b c ;
 ] unit-test
 
 [
-    { }
+    {
+        {
+            T{ sort-test { a 1 } { b 1 } { c 10 } }
+            T{ sort-test { a 1 } { b 1 } { c 11 } }
+        }
+        { T{ sort-test { a 1 } { b 3 } { c 9 } } }
+        {
+            T{ sort-test { a 2 } { b 5 } { c 3 } }
+            T{ sort-test { a 2 } { b 5 } { c 2 } }
+        }
+    }
 ] [
-    { }
+    {
-    { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+        T{ sort-test f 1 3 9 }
+        T{ sort-test f 1 1 10 }
+        T{ sort-test f 1 1 11 }
+        T{ sort-test f 2 5 3 }
+        T{ sort-test f 2 5 2 }
+    }
+    { { a>> human-<=> } { b>> <=> } } [ sort-by-slots ] keep
+    [ but-last-slice ] map split-by-slots [ >array ] map
+] unit-test
+
+: split-test ( seq -- seq' )
+    { { a>> } { b>> } } split-by-slots ;
+
+[ split-test ] must-infer
+
+[ { } ]
+[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
+
+[
+    {
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
+        T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
+    }
+] [
+    {
+        T{ sort-test f 6 f f T{ tuple2 f 1 } }
+        T{ sort-test f 5 f f T{ tuple2 f 4 } }
+        T{ sort-test f 6 f f T{ tuple2 f 3 } }
+        T{ sort-test f 6 f f T{ tuple2 f 3 } }
+        T{ sort-test f 5 f f T{ tuple2 f 3 } }
+        T{ sort-test f 6 f f T{ tuple2 f 2 } }
+    } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots
+] unit-test
+
+[
+    {
+        {
+            T{ sort-test
+                { a 6 }
+                { tuple2 T{ tuple2 { d 1 } } }
+            }
+        }
+        {
+            T{ sort-test
+                { a 6 }
+                { tuple2 T{ tuple2 { d 2 } } }
+            }
+        }
+        {
+            T{ sort-test
+                { a 5 }
+                { tuple2 T{ tuple2 { d 3 } } }
+            }
+        }
+        {
+            T{ sort-test
+                { a 6 }
+                { tuple2 T{ tuple2 { d 3 } } }
+            }
+            T{ sort-test
+                { a 6 }
+                { tuple2 T{ tuple2 { d 3 } } }
+            }
+        }
+        {
+            T{ sort-test
+                { a 5 }
+                { tuple2 T{ tuple2 { d 4 } } }
+            }
+        }
+    }
+] [
+    {
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
+        T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
+        T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
+    } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
 ] unit-test

basis/sorting/slots/slots.factor

@@ -1,19 +1,30 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators.short-circuit fry kernel macros math.order
-sequences words sorting ;
+sequences words sorting sequences.deep assocs splitting.monotonic
+math ;
 IN: sorting.slots
 
 <PRIVATE
 
-: slot-comparator ( accessor comparator -- quot )
+: slot-comparator ( seq -- quot )
-    '[ [ _ execute ] bi@ _ execute dup +eq+ eq? [ drop f ] when ] ;
+    [
+        but-last-slice
+        [ '[ [ _ execute ] bi@ ] ] map concat
+    ] [
+        peek
+        '[ @ _ execute dup +eq+ eq? [ drop f ] when ]
+    ] bi ;
 
 PRIVATE>
 
 MACRO: compare-slots ( sort-specs -- <=> )
-    #! sort-spec: { accessor comparator }
+    #! sort-spec: { accessors comparator }
-    [ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ;
+    [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
 
 : sort-by-slots ( seq sort-specs -- seq' )
     '[ _ compare-slots ] sort ;
+
+MACRO: split-by-slots ( accessor-seqs -- quot )
+    [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
+    '[ [ _ 2&& ] slice monotonic-slice ] ;

basis/validators/validators.factor

@@ -69,8 +69,8 @@ IN: validators
 
 : v-one-line ( str -- str )
     v-required
-    dup "\r\n" intersect empty?
+    dup "\r\n" intersects?
-    [ "must be a single line" throw ] unless ;
+    [ "must be a single line" throw ] when ;
 
 : v-one-word ( str -- str )
     v-required

core/sets/sets-docs.factor

@@ -13,6 +13,8 @@ $nl
 { $subsection diff }
 { $subsection intersect }
 { $subsection union }
+"Set-theoretic predicates:"
+{ $subsection intersects? }
 { $subsection subset? }
 { $subsection set= }
 "A word used to implement the above:"
@@ -104,9 +106,15 @@ HELP: union
 
 { diff intersect union } related-words
 
+HELP: intersects?
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "seq1" } " and " { $snippet "seq2" } " have any elements in common." }
+{ $notes "If one of the sequences is empty, the result is always " { $link f } "." } ;
+
 HELP: subset?
 { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
-{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
+{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." }
+{ $notes "If " { $snippet "seq1" } " is empty, the result is always " { $link t } "." } ;
 
 HELP: set=
 { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }

core/sets/sets-tests.factor

@@ -21,3 +21,11 @@ IN: sets.tests
 
 [ V{ 1 2 3 } ]
 [ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
+
+[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test
+
+[ f ] [ { } { 1 } intersects? ] unit-test
+
+[ f ] [ { 1 } { } intersects? ] unit-test

core/sets/sets.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs hashtables kernel sequences vectors ;
 IN: sets
@@ -31,17 +31,26 @@ IN: sets
 : all-unique? ( seq -- ? )
     dup length <hashtable> [ (all-unique?) ] curry all? ;
 
+<PRIVATE
+
+: tester ( seq -- quot ) unique [ key? ] curry ; inline
+
+PRIVATE>
+
 : intersect ( seq1 seq2 -- newseq )
-    unique [ key? ] curry filter ;
+    tester filter ;
+
+: intersects? ( seq1 seq2 -- ? )
+    tester contains? ;
 
 : diff ( seq1 seq2 -- newseq )
-    unique [ key? not ] curry filter ;
+    tester [ not ] compose filter ;
 
 : union ( seq1 seq2 -- newseq )
     append prune ;
 
 : subset? ( seq1 seq2 -- ? )
-    unique [ key? ] curry all? ;
+    tester all? ;
 
 : set= ( seq1 seq2 -- ? )
     [ unique ] bi@ = ;

core/splitting/splitting.factor

@@ -48,12 +48,12 @@ IN: splitting
 : split ( seq separators -- pieces ) [ split, ] { } make ;
 
 : string-lines ( str -- seq )
-    dup "\r\n" intersect empty? [
+    dup "\r\n" intersects? [
-        1array
-    ] [
         "\n" split [
             but-last-slice [
                 "\r" ?tail drop "\r" split
             ] map
         ] keep peek "\r" split suffix concat
+    ] [
+        1array
     ] if ;

extra/fuel/authors.txt

@@ -1,2 +1 @@
 Jose Antonio Ortega Ruiz
-Eduardo Cavazos

extra/fuel/fuel.factor

@@ -148,6 +148,8 @@ MEMO: fuel-get-article-title ( name -- )
 
 : fuel-word-see ( name -- ) (fuel-word-see) fuel-eval-set-result ;
 
+: fuel-word-def ( name -- ) (fuel-word-def) fuel-eval-set-result ;
+
 : fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ;
 
 : fuel-vocab-summary ( name -- )
@@ -171,3 +173,4 @@ MEMO: fuel-get-article-title ( name -- )
     (normalize-path) fuel-eval-set-result ;
 
 : fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
+

extra/fuel/help/help.factor

@@ -87,13 +87,16 @@ SYMBOL: vocab-list
 
 PRIVATE>
 
-: (fuel-word-help) ( object -- object )
+: (fuel-word-help) ( name -- elem )
     fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ;
 
 : (fuel-word-see) ( word -- elem )
     [ name>> \ article swap ]
     [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
 
+: (fuel-word-def) ( name -- str )
+    fuel-find-word [ [ def>> pprint ] with-string-writer ] when* ; inline
+
 : (fuel-vocab-summary) ( name -- str ) >vocab-link summary ; inline
 
 : (fuel-vocab-help) ( name -- str )

extra/webapps/calculator/calculator.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: furnace.actions furnace.redirection
+USING: furnace furnace.actions furnace.redirection
 http.server.dispatchers html.forms validators urls accessors
 math ;
 IN: webapps.calculator

extra/webapps/calculator/calculator.xml

@@ -2,6 +2,7 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
+<html>
 	<head> <title>Calculator</title> </head>
 
 	<body>
@@ -24,5 +25,6 @@
 
 		</t:form>
 	</body>
+</html>
 
 </t:chloe>

extra/webapps/counter/counter.xml

@@ -2,12 +2,13 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-
+<html>
 	<body>
 		<h1><t:label t:name="counter" /></h1>
 
 		<t:button t:action="$counter-app/inc">++</t:button>
 		<t:button t:action="$counter-app/dec">--</t:button>
 	</body>
+</html>
 
 </t:chloe>

misc/fuel/README

@@ -41,6 +41,12 @@ beast.
 
   To start the listener, try M-x run-factor.
 
+  By default, FUEL will try to use the binary and image files in the
+  factor installation directory. You can customize them with:
+
+    (setq fuel-listener-factor-binary <full path to factor>)
+    (setq fuel-listener-factor-image <full path to factor image>)
+
   Many aspects of the environment can be customized:
   M-x customize-group fuel will show you how many.
 
@@ -74,7 +80,8 @@ beast.
     - C-cz : switch to listener
     - C-co : cycle between code, tests and docs factor files
 
-    - M-. : edit word at point in Emacs
+    - M-. : edit word at point in Emacs (see fuel-edit-word-method custom var)
+    - M-, : go back to where M-. was last invoked
     - M-TAB : complete word at point
     - C-cC-eu : update USING: line
     - C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary)
@@ -98,6 +105,7 @@ beast.
 
     - C-cC-xs : extract innermost sexp (up to point)  as a separate word
     - C-cC-xr : extract region as a separate word
+    - C-cC-xi : replace word at point by its definition
     - C-cC-xv : extract region as a separate vocabulary
 
 *** In the listener:

misc/fuel/factor-mode.el

@@ -144,8 +144,7 @@ code in the buffer."
     (cond ((or (fuel-syntax--at-end-of-def)
                (fuel-syntax--at-setter-line))
            (fuel-syntax--decreased-indentation))
-          ((and (fuel-syntax--at-begin-of-def)
+          ((fuel-syntax--at-begin-of-indent-def)
-                (not (fuel-syntax--at-using)))
            (fuel-syntax--increased-indentation))
           (t (current-indentation)))))
 

misc/fuel/fu.el

@@ -8,7 +8,11 @@
 
 ;;; Code:
 
-(add-to-list 'load-path (file-name-directory load-file-name))
+(setq fuel-factor-fuel-dir (file-name-directory load-file-name))
+
+(setq fuel-factor-root-dir (expand-file-name "../../" fuel-factor-fuel-dir))
+
+(add-to-list 'load-path fuel-factor-fuel-dir)
 
 (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
 (autoload 'factor-mode "factor-mode.el"

misc/fuel/fuel-debug-uses.el

@@ -72,7 +72,7 @@
  (defvar fuel-debug--uses-restarts nil))
 
 (defsubst fuel-debug--uses-insert-title ()
-  (insert "Infering USING: stanza for " fuel-debug--uses-file ".\n\n"))
+  (insert "Inferring USING: stanza for " fuel-debug--uses-file ".\n\n"))
 
 (defun fuel-debug--uses-prepare (file)
   (fuel--with-popup (fuel-debug--uses-buffer)
@@ -173,7 +173,7 @@
     map))
 
 (defconst fuel-debug--uses-header-regex
-  (format "^%s.*$" (regexp-opt '("Infering USING: stanza for "
+  (format "^%s.*$" (regexp-opt '("Inferring USING: stanza for "
                                  "Current USING: is already fine!"
                                  "Current vocabulary list:"
                                  "Correct vocabulary list:"

misc/fuel/fuel-edit.el

@@ -17,6 +17,19 @@
 (require 'fuel-eval)
 (require 'fuel-base)
 
+(require 'etags)
+
+
+;;; Customization
+
+(defcustom fuel-edit-word-method nil
+  "How the new buffer is opened when invoking
+\\[fuel-edit-word-at-point]."
+  :group 'fuel
+  :type '(choice (const :tag "Other window" window)
+                 (const :tag "Other frame" frame)
+                 (const :tag "Current window" nil)))
+
 
 ;;; Auxiliar functions:
 
@@ -27,7 +40,9 @@
       (error "Couldn't find edit location"))
     (unless (file-readable-p (car loc))
       (error "Couldn't open '%s' for read" (car loc)))
-    (find-file-other-window (car loc))
+    (cond ((eq fuel-edit-word-method 'window) (find-file-other-window (car loc)))
+          ((eq fuel-edit-word-method 'frame) (find-file-other-frame (car loc)))
+          (t (find-file (car loc))))
     (goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
 
 (defun fuel-edit--read-vocabulary-name (refresh)
@@ -46,6 +61,7 @@
 
 (defvar fuel-edit--word-history nil)
 (defvar fuel-edit--vocab-history nil)
+(defvar fuel-edit--previous-location nil)
 
 (defun fuel-edit-vocabulary (&optional refresh vocab)
   "Visits vocabulary file in Emacs.
@@ -74,10 +90,12 @@ 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)))
+         (marker (and (not arg) (point-marker))))
     (condition-case nil
         (fuel-edit--try-edit (fuel-eval--send/wait cmd))
-      (error (fuel-edit-vocabulary nil word)))))
+      (error (fuel-edit-vocabulary nil word)))
+    (when marker (ring-insert find-tag-marker-ring marker))))
 
 (defun fuel-edit-word-doc-at-point (&optional arg word)
   "Opens a new window visiting the documentation file for the word at point.
@@ -86,7 +104,8 @@ With prefix, asks for the word to edit."
   (let* ((word (or word
                    (and (not arg) (fuel-syntax-symbol-at-point))
                    (fuel-completion--read-word "Edit word: ")))
-         (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location))))
+         (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location)))
+         (marker (and (not arg) (point-marker))))
     (condition-case nil
         (fuel-edit--try-edit (fuel-eval--send/wait cmd))
       (error
@@ -95,10 +114,19 @@ With prefix, asks for the word to edit."
                   (y-or-n-p (concat "No documentation found. "
                                     "Do you want to open the vocab's "
                                     "doc file? ")))
+         (when marker (ring-insert find-tag-marker-ring marker))
          (find-file-other-window
           (format "%s-docs.factor"
                   (file-name-sans-extension (buffer-file-name)))))))))
 
+(defun fuel-edit-pop-edit-word-stack ()
+  "Pop back to where \\[fuel-edit-word-at-point] or \\[fuel-edit-word-doc-at-point]
+was last invoked."
+  (interactive)
+  (condition-case nil
+      (pop-tag-mark)
+    (error "No previous location for find word or vocab invokation")))
+
 
 (provide 'fuel-edit)
 ;;; fuel-edit.el ends here

misc/fuel/fuel-font-lock.el

@@ -66,16 +66,17 @@
   (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")))
+  (word function-name "word, generic or method being defined")
+  (invalid-syntax warning "syntactically invalid constructs")))
 
 
 ;;; Font lock:
 
 (defconst fuel-font-lock--font-lock-keywords
-  `((,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)
+  `((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
+    (,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--vocab-ref-regexp  2 'factor-font-lock-vocabulary-name)
     (,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration)
     (,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
@@ -92,8 +93,8 @@
     (,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--symbol-definition-regex 2 'factor-font-lock-symbol)
-  "Font lock keywords definition for Factor mode.")
+    (,fuel-syntax--bad-string-regex . 'factor-font-lock-invalid-syntax)))
 
 (defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
   (set (make-local-variable 'comment-start) "! ")

misc/fuel/fuel-listener.el

@@ -30,12 +30,14 @@
   "Interacting with a Factor listener inside Emacs."
   :group 'fuel)
 
-(defcustom fuel-listener-factor-binary "~/factor/factor"
+(defcustom fuel-listener-factor-binary
+  (expand-file-name "factor" fuel-factor-root-dir)
   "Full path to the factor executable to use when starting a listener."
   :type '(file :must-match t)
   :group 'fuel-listener)
 
-(defcustom fuel-listener-factor-image "~/factor/factor.image"
+(defcustom fuel-listener-factor-image
+  (expand-file-name "factor.image" fuel-factor-root-dir)
   "Full path to the factor image to use when starting a listener."
   :type '(file :must-match t)
   :group 'fuel-listener)

misc/fuel/fuel-mode.el

@@ -181,6 +181,7 @@ interacting with a factor listener is at your disposal.
 (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 "\M-," 'fuel-edit-pop-edit-word-stack)
 (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)
@@ -197,6 +198,7 @@ interacting with a factor listener is at your disposal.
 (fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp)
 (fuel-mode--key ?x ?r 'fuel-refactor-extract-region)
 (fuel-mode--key ?x ?v 'fuel-refactor-extract-vocab)
+(fuel-mode--key ?x ?i 'fuel-refactor-inline-word)
 
 (fuel-mode--key ?d ?> 'fuel-show-callees)
 (fuel-mode--key ?d ?< 'fuel-show-callers)

misc/fuel/fuel-refactor.el

@@ -18,36 +18,106 @@
 (require 'fuel-syntax)
 (require 'fuel-base)
 
+
+;;; Word definitions in buffer
+
+(defconst fuel-refactor--next-defun-regex
+  (format "^\\(:\\|MEMO:\\|MACRO:\\):? +\\(\\w+\\)\\(%s\\)\\([^;]+?\\) ;\\_>"
+          fuel-syntax--stack-effect-regex))
+
+(defun fuel-refactor--previous-defun ()
+  (let ((pos) (result))
+    (while (and (not result)
+                (setq pos (fuel-syntax--beginning-of-defun)))
+      (setq result (looking-at fuel-refactor--next-defun-regex)))
+    (when (and result pos)
+      (let ((name (match-string-no-properties 2))
+            (body (match-string-no-properties 4))
+            (end (match-end 0)))
+        (list (split-string body nil t) name pos end)))))
+
+(defun fuel-refactor--find (code to)
+  (let ((candidate) (result))
+    (while (and (not result)
+                (setq candidate (fuel-refactor--previous-defun))
+                (> (point) to))
+      (when (equal (car candidate) code)
+        (setq result (cdr candidate))))
+    result))
+
+(defun fuel-refactor--reuse-p (word)
+  (save-excursion
+    (mark-defun)
+    (move-overlay fuel-stack--overlay (1+ (point)) (mark))
+    (unwind-protect
+        (and (y-or-n-p (format "Use existing word '%s'? " word)) word)
+      (delete-overlay fuel-stack--overlay))))
+
+(defun fuel-refactor--code-rx (code)
+  (let ((words (split-string code nil t)))
+    (mapconcat 'regexp-quote words "[ \n\f\r]+")))
+
 
 ;;; Extract word:
 
-(defun fuel-refactor--extract (begin end)
+(defun fuel-refactor--reuse-existing (code)
-  (let* ((word (read-string "New word name: "))
+  (save-excursion
-         (code (buffer-substring begin end))
+    (mark-defun)
-         (code-str (fuel--region-to-string begin end))
+    (let ((code (split-string (substring-no-properties code) nil t))
-         (stack-effect (or (fuel-stack--infer-effect code-str)
+          (down (mark))
-                           (read-string "Stack effect: "))))
+          (found)
-    (unless (< begin end) (error "No proper region to extract"))
+          (result))
-    (goto-char begin)
+      (while (and (not result)
-    (delete-region begin end)
+                  (setq found (fuel-refactor--find code (point-min))))
-    (insert word)
+        (when found (setq result (fuel-refactor--reuse-p (car found)))))
-    (indent-region begin (point))
+      (goto-char (point-max))
-    (set-mark (point))
+      (while (and (not result)
+                  (setq found (fuel-refactor--find code down)))
+        (when found (setq result (fuel-refactor--reuse-p (car found)))))
+      (and result found))))
+
+(defun fuel-refactor--insert-word (word stack-effect code)
   (let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point)))
         (end (save-excursion
                (re-search-backward fuel-syntax--end-of-def-regex nil t)
                (forward-line 1)
-                 (skip-syntax-forward "-")
+               (skip-syntax-forward "-"))))
-                 (point))))
+    (let ((start (goto-char (max beg end))))
-      (goto-char (max beg end)))
       (open-line 1)
-    (let ((start (point)))
       (insert ": " word " " stack-effect "\n" code " ;\n")
       (indent-region start (point))
-      (move-overlay fuel-stack--overlay start (point))
+      (move-overlay fuel-stack--overlay start (point)))))
-      (goto-char (mark))
+
-      (sit-for fuel-stack-highlight-period)
+(defun fuel-refactor--extract-other (start end code)
-      (delete-overlay fuel-stack--overlay))))
+  (unwind-protect
+      (when (y-or-n-p "Apply refactoring to rest of buffer? ")
+        (save-excursion
+          (let ((rx (fuel-refactor--code-rx code))
+                (end (point)))
+            (query-replace-regexp rx word t (point-min) start)
+            (query-replace-regexp rx word t end (point-max)))))
+    (delete-overlay fuel-stack--overlay)))
+
+(defun fuel-refactor--extract (begin end)
+  (unless (< begin end) (error "No proper region to extract"))
+  (let* ((code (buffer-substring begin end))
+         (existing (fuel-refactor--reuse-existing code))
+         (code-str (or existing (fuel--region-to-string begin end)))
+         (stack-effect (or existing
+                           (fuel-stack--infer-effect code-str)
+                           (read-string "Stack effect: ")))
+         (word (or (car existing) (read-string "New word name: "))))
+    (goto-char begin)
+    (delete-region begin end)
+    (insert word)
+    (indent-region begin (point))
+    (save-excursion
+      (let ((start (or (cadr existing) (point))))
+        (unless existing
+          (fuel-refactor--insert-word word stack-effect code))
+        (fuel-refactor--extract-other start
+                                      (or (car (cddr existing)) (point))
+                                      code)))))
 
 (defun fuel-refactor-extract-region (begin end)
   "Extracts current region as a separate word."
@@ -71,6 +141,29 @@ word."
                                 (if (looking-at-p ";") (point)
                                   (fuel-syntax--end-of-symbol-pos))))
 
+
+;;; Inline word:
+
+(defun fuel-refactor--word-def (word)
+  (let ((def (fuel-eval--retort-result
+              (fuel-eval--send/wait `(:fuel* (,word fuel-word-def) "fuel")))))
+    (when def
+      (substring (substring def 2) 0 -2))))
+
+(defun fuel-refactor-inline-word ()
+  "Inserts definition of word at point."
+  (interactive)
+  (let ((word (fuel-syntax-symbol-at-point)))
+    (unless word (error "No word at point"))
+    (let ((code (fuel-refactor--word-def word)))
+      (unless code (error "Word's definition not found"))
+      (fuel-syntax--beginning-of-symbol)
+      (kill-word 1)
+      (let ((start (point)))
+        (insert code)
+        (save-excursion (font-lock-fontify-region start (point)))
+        (indent-region start (point))))))
+
 
 ;;; Extract vocab:
 

misc/fuel/fuel-syntax.el

@@ -93,6 +93,9 @@
 (defconst fuel-syntax--float-regex
   "\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>")
 
+(defconst fuel-syntax--bad-string-regex
+  "\"[^\"]*$")
+
 (defconst fuel-syntax--word-definition-regex
   (fuel-syntax--second-word-regex
    '(":" "::" "GENERIC:" "DEFER:" "HOOK:" "MAIN:" "MATH:" "POSTPONE:"
@@ -132,16 +135,28 @@
 
 (defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
 
-(defconst fuel-syntax--definition-start-regex
+(defconst fuel-syntax--indent-def-starts '("" ":"
-  (format "^\\(%s:\\) " (regexp-opt '("" ":"
                                            "FROM"
                                            "INTERSECTION:"
-                                      "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD"
+                                           "M" "MACRO" "MACRO:"
+                                           "MEMO" "MEMO:" "METHOD"
                                            "PREDICATE" "PRIMITIVE"
-                                      "SINGLETONS" "SYMBOLS"
+                                           "UNION"))
+
+(defconst fuel-syntax--no-indent-def-starts '("SINGLETONS"
+                                              "SYMBOLS"
                                               "TUPLE"
-                                      "UNION"
+                                              "VARS"))
-                                      "VARS"))))
+
+(defconst fuel-syntax--indent-def-start-regex
+  (format "^\\(%s:\\) " (regexp-opt fuel-syntax--indent-def-starts)))
+
+(defconst fuel-syntax--no-indent-def-start-regex
+  (format "^\\(%s:\\) " (regexp-opt fuel-syntax--no-indent-def-starts)))
+
+(defconst fuel-syntax--definition-start-regex
+  (format "^\\(%s:\\) " (regexp-opt (append fuel-syntax--no-indent-def-starts
+                                            fuel-syntax--indent-def-starts))))
 
 (defconst fuel-syntax--definition-end-regex
   (format "\\(\\(^\\| +\\);\\( *%s\\)*\\($\\| +\\)\\)"
@@ -199,8 +214,7 @@
     (modify-syntax-entry ?\  " " table)
     (modify-syntax-entry ?\n " " table)
 
-    ;; Strings
+    ;; Char quote
-    (modify-syntax-entry ?\" "\"" table)
     (modify-syntax-entry ?\\ "/" table)
 
     table))
@@ -211,6 +225,8 @@
     ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
     ;; CHARs:
     ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
+    ;; Strings
+    ("\\(\"\\)[^\n\r\f]*\\(\"\\)" (1 "\"") (2 "\""))
     ;; Let and lambda:
     ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
     ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
@@ -256,6 +272,9 @@
 (defsubst fuel-syntax--at-begin-of-def ()
   (looking-at fuel-syntax--begin-of-def-regex))
 
+(defsubst fuel-syntax--at-begin-of-indent-def ()
+  (looking-at fuel-syntax--indent-def-start-regex))
+
 (defsubst fuel-syntax--at-end-of-def ()
   (looking-at fuel-syntax--end-of-def-regex))