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

basis/bootstrap/unicode/unicode.factor

@@ -1,5 +0,0 @@
-USING: strings.parser kernel namespaces unicode unicode.data ;
-IN: bootstrap.unicode
-
-[ name>char [ "Invalid character" throw ] unless* ]
-name>char-hook set-global

basis/combinators/smart/smart-docs.factor

@@ -48,7 +48,7 @@ HELP: output>sequence
     }
 } ;
 
-HELP: reduce-output
+HELP: reduce-outputs
 { $values
      { "quot" quotation } { "operation" quotation }
      { "newquot" quotation }
@@ -57,7 +57,7 @@ HELP: reduce-output
 { $examples
     { $example
         "USING: combinators.smart kernel math prettyprint ;"
-        "3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-output ."
+        "3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-outputs ."
         "-9"
     }
 } ;
@@ -84,7 +84,7 @@ ARTICLE: "combinators.smart" "Smart combinators"
 { $subsection output>sequence }
 { $subsection output>array }
 "Reducing the output of a quotation:"
-{ $subsection reduce-output }
+{ $subsection reduce-outputs }
 "Summing the output of a quotation:"
 { $subsection sum-outputs } ;
 

basis/combinators/smart/smart-tests.factor

@@ -14,8 +14,8 @@ IN: combinators.smart.tests
 
 
 
-[ 6 ] [ [ 1 2 3 ] [ + ] reduce-output ] unit-test
+[ 6 ] [ [ 1 2 3 ] [ + ] reduce-outputs ] unit-test
 
-[ [ 1 2 3 ] [ + ] reduce-output ] must-infer
+[ [ 1 2 3 ] [ + ] reduce-outputs ] must-infer
 
 [ 6 ] [ [ 1 2 3 ] sum-outputs ] unit-test

basis/combinators/smart/smart.factor

@@ -15,8 +15,8 @@ MACRO: input<sequence ( quot -- newquot )
     [ infer in>> ] keep
     '[ _ firstn @ ] ;
 
-MACRO: reduce-output ( quot operation -- newquot )
+MACRO: reduce-outputs ( quot operation -- newquot )
     [ dup infer out>> 1 [-] ] dip n*quot compose ;
 
 : sum-outputs ( quot -- n )
-    [ + ] reduce-output ; inline
+    [ + ] reduce-outputs ; inline

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel arrays sequences math math.order
 math.partial-dispatch generic generic.standard generic.math
 classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations classes fry
+words namespaces continuations classes fry combinators.smart
 compiler.tree
 compiler.tree.builder
 compiler.tree.recursive
@@ -134,17 +134,19 @@ DEFER: (flat-length)
     over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
 
 : inlining-rank ( #call word -- n )
-    [ classes-known? 2 0 ? ]
     [
-        {
+        [ classes-known? 2 0 ? ]
-            [ body-length-bias ]
+        [
-            [ "default" word-prop -4 0 ? ]
+            {
-            [ "specializer" word-prop 1 0 ? ]
+                [ body-length-bias ]
-            [ method-body? 1 0 ? ]
+                [ "default" word-prop -4 0 ? ]
-        } cleave
+                [ "specializer" word-prop 1 0 ? ]
-        node-count-bias
+                [ method-body? 1 0 ? ]
-        loop-nesting get 0 or 2 *
+            } cleave
-    ] bi* + + + + + + ;
+            node-count-bias
+            loop-nesting get 0 or 2 *
+        ] bi*
+    ] sum-outputs ;
 
 : should-inline? ( #call word -- ? )
     dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;

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

@@ -3,7 +3,7 @@
 USING: accessors alien.c-types alien.syntax combinators
 io.backend io.files io.files.info io.files.unix kernel math system unix
 unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
-sequences grouping alien.strings io.encodings.utf8
+sequences grouping alien.strings io.encodings.utf8 unix.types
 specialized-arrays.direct.uint arrays io.files.info.unix ;
 IN: io.files.info.unix.freebsd
 

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

@@ -5,7 +5,7 @@ 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 io.files.links
 specialized-arrays.direct.uint arrays io.files.info.unix assocs
-io.pathnames ;
+io.pathnames unix.types ;
 IN: io.files.info.unix.linux
 
 TUPLE: linux-file-system-info < unix-file-system-info

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

@@ -117,12 +117,12 @@ prepare-test-file
 [ ] [ test-file f f 2array set-file-times ] unit-test
 
 
-[ ] [ test-file real-username set-file-user ] unit-test
+[ ] [ test-file real-user-name set-file-user ] unit-test
 [ ] [ test-file real-user-id set-file-user ] unit-test
 [ ] [ test-file real-group-name set-file-group ] unit-test
 [ ] [ test-file real-group-id set-file-group ] unit-test
 
-[ t ] [ test-file file-username real-username = ] unit-test
+[ t ] [ test-file file-user-name real-user-name = ] unit-test
 [ t ] [ test-file file-group-name real-group-name = ] unit-test
 
 [ ]

basis/tools/files/files.factor

@@ -65,7 +65,7 @@ percent-used percent-free ;
     [ [ unparse ] map ] bi prefix simple-table. ;
 
 : file-systems. ( -- )
-    { device-name free-space used-space total-space percent-used mount-point }
+    { device-name available-space free-space used-space total-space percent-used mount-point }
     print-file-systems ;
 
 {

basis/unicode/breaks/breaks.factor

@@ -4,7 +4,8 @@ USING: combinators.short-circuit unicode.categories kernel math
 combinators splitting sequences math.parser io.files io assocs
 arrays namespaces make math.ranges unicode.normalize.private values
 io.encodings.ascii unicode.syntax unicode.data compiler.units fry
-alien.syntax sets accessors interval-maps memoize locals words ;
+alien.syntax sets accessors interval-maps memoize locals words
+strings hints ;
 IN: unicode.breaks
 
 <PRIVATE
@@ -58,38 +59,31 @@ SYMBOL: table
 : finish-table ( -- table )
     table get [ [ 1 = ] map ] map ;
 
-: set-table ( class1 class2 val -- )
+: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
+
+: (set-table) ( class1 class2 val -- )
     -rot table get nth [ swap or ] change-nth ;
 
+: set-table ( classes1 classes2 val -- )
+    [ [ eval-seq ] bi@ ] dip
+    [ [ (set-table) ] curry with each ] 2curry each ;
+
 : connect ( class1 class2 -- ) 1 set-table ;
 : disconnect ( class1 class2 -- ) 0 set-table ;
-
-: check-before ( class classes value -- )
-    [ set-table ] curry with each ;
-
-: check-after ( classes class value -- )
-    [ set-table ] 2curry each ;
-
-: connect-before ( class classes -- )
-    1 check-before ;
-
-: connect-after ( classes class -- )
-    1 check-after ;
   
 : break-around ( classes1 classes2 -- )
-    [ [ 2dup disconnect swap disconnect ] with each ] curry each ;
+    [ disconnect ] [ swap disconnect ] 2bi ;
 
 : make-grapheme-table ( -- )
-    CR LF connect
+    { CR } { LF } connect
-    Control CR LF 3array graphemes break-around
+    { Control CR LF } graphemes disconnect
-    L L V LV LVT 4array connect-before
+    graphemes { Control CR LF } disconnect
-    V V T 2array connect-before
+    { L } { L V LV LVT } connect
-    LV V T 2array connect-before
+    { LV V } { V T } connect
-    T T connect
+    { LVT T } { T } connect
-    LVT T connect
+    graphemes { Extend } connect
-    graphemes Extend connect-after
+    graphemes { SpacingMark } connect
-    graphemes SpacingMark connect-after
+    { Prepend } graphemes connect ;
-    Prepend graphemes connect-before ;
 
 VALUE: grapheme-table
 
@@ -99,14 +93,11 @@ VALUE: grapheme-table
 : chars ( i str n -- str[i] str[i+n] )
     swap [ dupd + ] dip [ ?nth ] curry bi@ ;
 
-: find-index ( seq quot -- i ) find drop ; inline
-: find-last-index ( seq quot -- i ) find-last drop ; inline
-
 PRIVATE>
 
 : first-grapheme ( str -- i )
     unclip-slice grapheme-class over
-    [ grapheme-class tuck grapheme-break? ] find-index
+    [ grapheme-class tuck grapheme-break? ] find drop
     nip swap length or 1+ ;
 
 <PRIVATE
@@ -125,7 +116,7 @@ PRIVATE>
 
 : last-grapheme ( str -- i )
     unclip-last-slice grapheme-class swap
-    [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
+    [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
 
 <PRIVATE
 
@@ -156,27 +147,23 @@ wMidNum wMidNumLet wNumeric wExtendNumLet words ;
     word-break-table interval-at
     word-break-classes at [ wOther ] unless* ;
 
-: e ( seq -- seq ) [ execute ] map ;
-
 SYMBOL: check-letter-before
 SYMBOL: check-letter-after
 SYMBOL: check-number-before
 SYMBOL: check-number-after
 
 : make-word-table ( -- )
-    wCR wLF connect
+    { wCR } { wLF } connect
-    { wNewline wCR wLF } e words break-around
+    { wNewline wCR wLF } words disconnect
-    wALetter dup connect
+    words { wNewline wCR wLF } disconnect
-    wALetter { wMidLetter wMidNumLet } e check-letter-after check-before
+    { wALetter } { wMidLetter wMidNumLet } check-letter-after set-table
-    { wMidLetter wMidNumLet } e wALetter check-letter-before check-after
+    { wMidLetter wMidNumLet } { wALetter } check-letter-before set-table
-    wNumeric dup connect
+    { wNumeric wALetter } { wNumeric wALetter } connect
-    wALetter wNumeric connect
+    { wNumeric } { wMidNum wMidNumLet } check-number-after set-table
-    wNumeric wALetter connect
+    { wMidNum wMidNumLet } { wNumeric } check-number-before set-table
-    wNumeric { wMidNum wMidNumLet } e check-number-after check-before
+    { wKatakana } { wKatakana } connect
-    { wMidNum wMidNumLet } e wNumeric check-number-before check-after
+    { wALetter wNumeric wKatakana wExtendNumLet } { wExtendNumLet }
-    wKatakana dup connect
+    [ connect ] [ swap connect ] 2bi ;
-    { wALetter wNumeric wKatakana wExtendNumLet } e wExtendNumLet
-    [ connect-after ] [ swap connect-before ] 2bi ;
 
 VALUE: word-table
 
@@ -192,7 +179,7 @@ to: word-table
 : word-table-nth ( class1 class2 -- ? )
     word-table nth nth ;
 
-:: property-not= ( i str property -- ? )
+:: property-not= ( str i property -- ? )
     i [
         i str ?nth [ word-break-prop property = not ]
         [ f ] if*
@@ -201,41 +188,49 @@ to: word-table
 : format/extended? ( ch -- ? )
     word-break-prop { 4 5 } member? ;
 
-:: walk-up ( str i -- j )
+: (walk-up) ( str i -- j )
-    i 1 + str [ format/extended? not ] find-from drop
+    swap [ format/extended? not ] find-from drop ;
-    [ 1+ str [ format/extended? not ] find-from drop ] [ f ] if* ;
 
-:: walk-down ( str i -- j )
+: walk-up ( str i -- j )
-    i str [ format/extended? not ] find-last-from drop
+    dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ;
-    [ 1- str [ format/extended? not ] find-last-from drop ] [ f ] if* ;
 
-:: word-break? ( table-entry i str -- ? )
+: (walk-down) ( str i -- j )
-    table-entry {
+    swap [ format/extended? not ] find-last-from drop ;
-        { t [ f ] }
+
-        { f [ t ] }
+: walk-down ( str i -- j )
+    dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ;
+
+: word-break? ( table-entry i str -- ? )
+    spin {
+        { t [ 2drop f ] }
+        { f [ 2drop t ] }
         { check-letter-after
-            [ str i walk-up str wALetter property-not= ] }
+            [ dupd walk-up wALetter property-not= ] }
         { check-letter-before
-            [ str i walk-down str wALetter property-not= ] }
+            [ dupd walk-down wALetter property-not= ] }
         { check-number-after
-            [ str i walk-up str wNumeric property-not= ] }
+            [ dupd walk-up wNumeric property-not= ] }
         { check-number-before
-            [ str i walk-down str wNumeric property-not= ] }
+            [ dupd walk-down wNumeric property-not= ] }
-    } case ;
+    } case ; inline
 
 :: word-break-next ( old-class new-char i str -- next-class ? )
     new-char dup format/extended?
     [ drop old-class dup { 1 2 3 } member? ] [
         word-break-prop old-class over word-table-nth
         i str word-break?
-    ] if ;
+    ] if ; inline
 
 PRIVATE>
 
-:: first-word ( str -- i )
+: first-word ( str -- i )
-    str unclip-slice word-break-prop over <enum>
+    [ unclip-slice word-break-prop over <enum> ] keep
-    [ swap str word-break-next ] assoc-find 2drop
+    '[ swap _ word-break-next ] assoc-find 2drop
-    nip swap length or 1+ ;
+    nip swap length or 1+ ; inline
+
+HINTS: first-word string ;
 
 : >words ( str -- words )
     [ first-word ] >pieces ;
+
+HINTS: >words string ;

basis/unicode/case/case.factor

@@ -1,16 +1,18 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: unicode.data sequences sequences.next namespaces make
+USING: unicode.data sequences sequences.next namespaces
-unicode.normalize math unicode.categories combinators unicode.syntax
+sbufs make unicode.syntax unicode.normalize math hints
-assocs strings splitting kernel accessors unicode.breaks fry ;
+unicode.categories combinators unicode.syntax assocs
+strings splitting kernel accessors unicode.breaks fry locals ;
+QUALIFIED: ascii
 IN: unicode.case
 
 <PRIVATE
-: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
+: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; inline
 
-: ch>lower ( ch -- lower ) simple-lower at-default ;
+: ch>lower ( ch -- lower ) simple-lower at-default ; inline
-: ch>upper ( ch -- upper ) simple-upper at-default ;
+: ch>upper ( ch -- upper ) simple-upper at-default ; inline
-: ch>title ( ch -- title ) simple-title at-default ;
+: ch>title ( ch -- title ) simple-title at-default ; inline
 PRIVATE>
 
 SYMBOL: locale ! Just casing locale, or overall?
@@ -21,7 +23,7 @@ SYMBOL: locale ! Just casing locale, or overall?
     [ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ;
 
 : replace ( old new str -- newstr )
-    [ split-subseq ] dip join ;
+    [ split-subseq ] dip join ; inline
 
 : i-dot? ( -- ? )
     locale get { "tr" "az" } member? ;
@@ -44,24 +46,24 @@ SYMBOL: locale ! Just casing locale, or overall?
     [ [ "" ] [
         dup first mark-above?
         [ CHAR: combining-dot-above prefix ] when
-    ] if-empty ] with-rest ;
+    ] if-empty ] with-rest ; inline
 
 : lithuanian>lower ( string -- lower )
     "i" split add-dots "i" join
-    "j" split add-dots "i" join ;
+    "j" split add-dots "i" join ; inline
 
 : turk>upper ( string -- upper-i )
-    "i" "I\u000307" replace ;
+    "i" "I\u000307" replace ; inline
 
 : turk>lower ( string -- lower-i )
     "I\u000307" "i" replace
-    "I" "\u000131" replace ;
+    "I" "\u000131" replace ; inline
 
 : fix-sigma-end ( string -- string )
     [ "" ] [
         dup peek CHAR: greek-small-letter-sigma =
         [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
-    ] if-empty ;
+    ] if-empty ; inline
 
 : sigma-map ( string -- string )
     { CHAR: greek-capital-letter-sigma } split [ [
@@ -70,19 +72,20 @@ SYMBOL: locale ! Just casing locale, or overall?
             CHAR: greek-small-letter-final-sigma
             CHAR: greek-small-letter-sigma ? prefix
         ] if-empty
-    ] map ] with-rest concat fix-sigma-end ;
+    ] map ] with-rest concat fix-sigma-end ; inline
 
 : final-sigma ( string -- string )
     CHAR: greek-capital-letter-sigma
-    over member? [ sigma-map ] when ;
+    over member? [ sigma-map ] when
+    "" like ; inline
 
-: map-case ( string string-quot char-quot -- case )
+:: map-case ( string string-quot char-quot -- case )
-    [
+    string length <sbuf> :> out
-        [
+    string [
-            [ dup special-casing at ] 2dip
+        dup special-casing at
-            [ [ % ] compose ] [ [ , ] compose ] bi* ?if
+        [ string-quot call out push-all ]
-        ] 2curry each
+        [ char-quot call out push ] ?if
-    ] "" make ; inline
+    ] each out "" like ; inline
 
 PRIVATE>
 
@@ -90,24 +93,30 @@ PRIVATE>
     i-dot? [ turk>lower ] when final-sigma
     [ lower>> ] [ ch>lower ] map-case ;
 
+HINTS: >lower string ;
+
 : >upper ( string -- upper )
     i-dot? [ turk>upper ] when
     [ upper>> ] [ ch>upper ] map-case ;
 
+HINTS: >upper string ;
+
 <PRIVATE
 
 : (>title) ( string -- title )
     i-dot? [ turk>upper ] when
-    [ title>> ] [ ch>title ] map-case ;
+    [ title>> ] [ ch>title ] map-case ; inline
 
 : title-word ( string -- title )
-    unclip 1string [ >lower ] [ (>title) ] bi* prepend ;
+    unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline
 
 PRIVATE>
 
 : >title ( string -- title )
     final-sigma >words [ title-word ] map concat ;
 
+HINTS: >title string ;
+
 : >case-fold ( string -- fold )
     >upper >lower ;
 

basis/unicode/data/data.factor

@@ -4,7 +4,8 @@ USING: combinators.short-circuit assocs math kernel sequences
 io.files hashtables quotations splitting grouping arrays io
 math.parser hash2 math.order byte-arrays words namespaces words
 compiler.units parser io.encodings.ascii values interval-maps
-ascii sets combinators locals math.ranges sorting make io.encodings.utf8 ;
+ascii sets combinators locals math.ranges sorting make
+strings.parser io.encodings.utf8 ;
 IN: unicode.data
 
 VALUE: simple-lower
@@ -218,3 +219,6 @@ SYMBOL: interned
 
 : load-script ( filename -- table )
     ascii <file-reader> parse-script process-script ;
+
+[ name>char [ "Invalid character" throw ] unless* ]
+name>char-hook set-global

basis/unicode/normalize/normalize-tests.factor

@@ -3,6 +3,8 @@ unicode.data io.encodings.utf8 io.files splitting math.parser
 locals math quotations assocs combinators unicode.normalize.private ;
 IN: unicode.normalize.tests
 
+{ nfc nfkc nfd nfkd } [ must-infer ] each
+
 [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test
 
 [ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test

basis/unicode/normalize/normalize.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences namespaces make unicode.data kernel math arrays
+USING: ascii sequences namespaces make unicode.data kernel math arrays
 locals sorting.insertion accessors assocs math.order combinators
-unicode.syntax strings sbufs ;
+unicode.syntax strings sbufs hints combinators.short-circuit vectors ;
 IN: unicode.normalize
 
 <PRIVATE
@@ -19,16 +19,16 @@ CONSTANT: medial-count 21
 CONSTANT: final-count 28
 
 : ?between? ( n/f from to -- ? )
-    pick [ between? ] [ 3drop f ] if ;
+    pick [ between? ] [ 3drop f ] if ; inline
 
-: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ;
+: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ; inline
-: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ;
+: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ; inline
 
 ! These numbers come from UAX 29
 : initial? ( ch -- ? )
-    dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ;
+    dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ; inline
-: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ;
+: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ; inline
-: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ;
+: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ; inline
 
 : hangul>jamo ( hangul -- jamo-string )
     hangul-base - final-count /mod final-base +
@@ -48,16 +48,16 @@ CONSTANT: final-count 28
 
 : reorder-slice ( string start -- slice done? )
     2dup swap [ non-starter? not ] find-from drop
-    [ [ over length ] unless* rot <slice> ] keep not ;
+    [ [ over length ] unless* rot <slice> ] keep not ; inline
 
 : reorder-next ( string i -- new-i done? )
     over [ non-starter? ] find-from drop [
         reorder-slice
         [ dup [ combining-class ] insertion-sort to>> ] dip
-    ] [ length t ] if* ;
+    ] [ length t ] if* ; inline
 
 : reorder-loop ( string start -- )
-    dupd reorder-next [ 2drop ] [ reorder-loop ] if ;
+    dupd reorder-next [ 2drop ] [ reorder-loop ] if ; inline recursive
 
 : reorder ( string -- )
     0 reorder-loop ;
@@ -66,12 +66,14 @@ CONSTANT: final-count 28
     over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ;
 
 :: decompose ( string quot -- decomposed )
-    [let | out [ string length <sbuf> ] |
+    string length <sbuf> :> out
-        string [
+    string [
+        >fixnum dup ascii? [ out push ] [
             dup hangul? [ hangul>jamo out push-all ]
             [ dup quot call [ out push-all ] [ out push ] ?if ] if
-        ] each out >string
+        ] if
-    ] dup reorder ;
+    ] each
+    out "" like dup reorder ; inline
 
 : with-string ( str quot -- str )
     over aux>> [ call ] [ drop ] if ; inline
@@ -79,9 +81,13 @@ CONSTANT: final-count 28
 : (nfd) ( string -- nfd )
     [ canonical-entry ] decompose ;
 
+HINTS: (nfd) string ;
+
 : (nfkd) ( string -- nfkd )
     [ compatibility-entry ] decompose ;
 
+HINTS: (nfkd) string ;
+
 PRIVATE>
 
 : nfd ( string -- nfd )
@@ -95,83 +101,91 @@ PRIVATE>
     0 over ?nth non-starter?
     [ length dupd reorder-back ] [ drop ] if ;
 
+HINTS: string-append string string ;
+
 <PRIVATE
 
 ! Normalization -- Composition
-SYMBOL: main-str
-SYMBOL: ind
-SYMBOL: after
-SYMBOL: char
 
-: get-str ( i -- ch ) ind get + main-str get ?nth ;
+: initial-medial? ( str i -- ? )
-: current ( -- ch ) 0 get-str ;
+    { [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ;
-: to ( -- ) ind inc ;
 
-: initial-medial? ( -- ? )
+: --final? ( str i -- ? )
-    current initial? [ 1 get-str medial? ] [ f ] if ;
+    2 + swap ?nth final? ;
 
-: --final? ( -- ? )
+: imf, ( str i -- str i )
-    2 get-str final? ;
+    [ tail-slice first3 jamo>hangul , ]
+    [ 3 + ] 2bi ;
 
-: imf, ( -- )
+: im, ( str i -- str i )
-    current to current to current jamo>hangul , ;
+    [ tail-slice first2 final-base jamo>hangul , ]
+    [ 2 + ] 2bi ;
 
-: im, ( -- )
+: compose-jamo ( str i -- str i )
-    current to current final-base jamo>hangul , ;
+    2dup initial-medial? [
+        2dup --final? [ imf, ] [ im, ] if
+    ] [ 2dup swap nth , 1+ ] if ;
 
-: compose-jamo ( -- )
+: pass-combining ( str -- str i )
-    initial-medial? [
+    dup [ non-starter? not ] find drop
-        --final? [ imf, ] [ im, ] if
+    [ dup length ] unless*
-    ] [ current , ] if to ;
+    2dup head-slice % ;
 
-: pass-combining ( -- )
+TUPLE: compose-state i str char after last-class ;
-    current non-starter? [ current , to pass-combining ] when ;
 
-:: try-compose ( last-class new-char current-class -- new-class )
+: get-str ( state i -- ch )
-    last-class current-class = [ new-char after get push last-class ] [
+    swap [ i>> + ] [ str>> ] bi ?nth ; inline
-        char get new-char combine-chars
+: current ( state -- ch ) 0 get-str ; inline
-        [ char set last-class ]
+: to ( state -- state ) [ 1+ ] change-i ; inline
-        [ new-char after get push current-class ] if*
+: push-after ( ch state -- state ) [ ?push ] change-after ; inline
-    ] if ;
+
+:: try-compose ( state new-char current-class -- state )
+    state last-class>> current-class =
+    [ new-char state push-after ] [
+        state char>> new-char combine-chars
+        [ state swap >>char ] [
+            new-char state push-after
+            current-class >>last-class
+        ] if*
+    ] if ; inline
 
 DEFER: compose-iter
 
-: try-noncombining ( char -- )
+: try-noncombining ( char state -- state )
-    char get swap combine-chars
+    tuck char>> swap combine-chars
-    [ char set to f compose-iter ] when* ;
+    [ >>char to f >>last-class compose-iter ] when* ; inline
 
-: compose-iter ( last-class -- )
+: compose-iter ( state -- state )
-    current [
+    dup current [
         dup combining-class {
-            { f [ 2drop ] }
+            { f [ drop ] }
-            { 0 [ swap [ drop ] [ try-noncombining ] if ] }
+            { 0 [
+                over last-class>>
+                [ drop ] [ swap try-noncombining ] if ] }
             [ try-compose to compose-iter ]
         } case
-    ] [ drop ] if* ;
+    ] when* ; inline recursive
 
-: ?new-after ( -- )
+: compose-combining ( ch str i -- str i )
-    after [ dup empty? [ drop SBUF" " clone ] unless ] change ;
+    compose-state new
+        swap >>i
+        swap >>str
+        swap >>char
+    compose-iter
+    { [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; inline
 
-: compose-combining ( ch -- )
+:: (compose) ( str i -- )
-    char set to ?new-after
+    i str ?nth [
-    f compose-iter
+        dup jamo? [ drop str i compose-jamo ] [
-    char get , after get % ;
+            i 1+ str ?nth combining-class
-
+            [ str i 1+ compose-combining ] [ , str i 1+ ] if
-: (compose) ( -- )
-    current [
-        dup jamo? [ drop compose-jamo ] [
-            1 get-str combining-class
-            [ compose-combining ] [ , to ] if
         ] if (compose)
-    ] when* ;
+    ] when* ; inline recursive
 
 : combine ( str -- comp )
-    [
+    [ pass-combining (compose) ] "" make ;
-        main-str set
+
-        0 ind set
+HINTS: combine string ;
-        SBUF" " clone after set
-        pass-combining (compose)
-    ] "" make ;
 
 PRIVATE>
 

basis/unix/groups/groups-docs.factor

@@ -24,8 +24,8 @@ HELP: group-cache
 HELP: group-id
 { $values
      { "string" string }
-     { "id" integer } }
+     { "id/f" "an integer or f" } }
-{ $description "Returns the group id given a group name." } ;
+{ $description "Returns the group id given a group name. Returns " { $link f } " if the group does not exist." } ;
 
 HELP: group-name
 { $values
@@ -36,7 +36,7 @@ HELP: group-name
 HELP: group-struct
 { $values
      { "obj" object }
-     { "group" "a group struct" } }
+     { "group/f" "a group struct or f" } }
 { $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
 
 HELP: real-group-id

basis/unix/groups/groups-tests.factor

@@ -27,3 +27,5 @@ IN: unix.groups.tests
 [ ] [ real-group-id group-name drop ] unit-test
 
 [ "888888888888888" ] [ 888888888888888 group-name ] unit-test
+[ f ]
+[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test

basis/unix/groups/groups.factor

@@ -13,7 +13,7 @@ TUPLE: group id name passwd members ;
 
 SYMBOL: group-cache
 
-GENERIC: group-struct ( obj -- group )
+GENERIC: group-struct ( obj -- group/f )
 
 <PRIVATE
 
@@ -24,11 +24,14 @@ GENERIC: group-struct ( obj -- group )
     "group" <c-object> tuck 4096
     [ <byte-array> ] keep f <void*> ;
 
-M: integer group-struct ( id -- group )
+: check-group-struct ( group-struct ptr -- group-struct/f )
-    (group-struct) getgrgid_r io-error ;
+    *void* [ drop f ] unless ;
 
-M: string group-struct ( string -- group )
+M: integer group-struct ( id -- group/f )
-    (group-struct) getgrnam_r 0 = [ (io-error) ] unless ;
+    (group-struct) [ getgrgid_r io-error ] keep check-group-struct ;
+
+M: string group-struct ( string -- group/f )
+    (group-struct) [ getgrnam_r io-error ] keep check-group-struct ;
 
 : group-struct>group ( group-struct -- group )
     [ \ group new ] dip
@@ -45,12 +48,12 @@ PRIVATE>
     dup group-cache get [
         dupd at* [ name>> nip ] [ drop number>string ] if
     ] [
-        group-struct group-gr_name
+        group-struct [ group-gr_name ] [ f ] if*
     ] if*
     [ nip ] [ number>string ] if* ;
 
-: group-id ( string -- id )
+: group-id ( string -- id/f )
-    group-struct group-gr_gid ;
+    group-struct [ group-gr_gid ] [ f ] if* ;
 
 <PRIVATE
 

basis/unix/statfs/freebsd/freebsd.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax unix.types unix.stat ;
 IN: unix.statfs.freebsd
 
 CONSTANT: MFSNAMELEN      16            ! length of type name including null */

basis/unix/statfs/linux/linux.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax unix.types unix.stat ;
 IN: unix.statfs.linux
 
 C-STRUCT: statfs64

basis/unix/statfs/macosx/macosx.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types io.encodings.utf8 io.encodings.string
 kernel sequences unix.stat accessors unix combinators math
-grouping system alien.strings math.bitwise alien.syntax ;
+grouping system alien.strings math.bitwise alien.syntax
+unix.types ;
 IN: unix.statfs.macosx
 
 CONSTANT: MNT_RDONLY  HEX: 00000001

basis/unix/statfs/openbsd/openbsd.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax unix.types unix.stat ;
 IN: unix.statfs.openbsd
 
 CONSTANT: MFSNAMELEN 16

basis/values/values-docs.factor

@@ -19,6 +19,7 @@ HELP: VALUE:
 { $examples
   { $example
     "USING: values math prettyprint ;"
+    "IN: scratchpad"
     "VALUE: x"
     "2 2 + to: x"
     "x ."

misc/fuel/factor-mode.el

@@ -241,7 +241,7 @@ code in the buffer."
 (defun factor-mode-insert-and-indent (n)
   (interactive "p")
   (self-insert-command n)
-  (indent-for-tab-command))
+  (indent-according-to-mode))
 
 (defvar factor-mode-map
   (let ((map (make-sparse-keymap)))

misc/fuel/fuel-autodoc.el

@@ -57,7 +57,10 @@
 (defun fuel-autodoc--eldoc-function ()
   (or (and fuel-autodoc--fallback-function
            (funcall fuel-autodoc--fallback-function))
-      (fuel-autodoc--word-synopsis)))
+      (condition-case e
+          (fuel-autodoc--word-synopsis)
+        (error (format "Autodoc not available (%s)"
+                       (error-message-string e))))))
 
 
 ;;; Autodoc mode:

misc/fuel/fuel-connection.el

@@ -29,10 +29,7 @@
 (defun fuel-con--get-connection (buffer/proc)
   (if (processp buffer/proc)
       (fuel-con--get-connection (process-buffer buffer/proc))
-    (with-current-buffer buffer/proc
+    (with-current-buffer buffer/proc fuel-con--connection)))
-      (or fuel-con--connection
-          (setq fuel-con--connection
-                (fuel-con--setup-connection buffer/proc))))))
 
 
 ;;; Request and connection datatypes:
@@ -126,19 +123,20 @@
 (defun fuel-con--setup-connection (buffer)
   (set-buffer buffer)
   (fuel-con--cleanup-connection fuel-con--connection)
+  (setq fuel-con--connection nil)
   (let ((conn (fuel-con--make-connection buffer)))
     (fuel-con--setup-comint)
-    (prog1
+    (fuel-con--establish-connection conn buffer)))
-        (setq fuel-con--connection conn)
-      (fuel-con--connection-start-timer conn))))
 
 (defconst fuel-con--prompt-regex "( .+ ) ")
 (defconst fuel-con--eot-marker "<~FUEL~>")
 (defconst fuel-con--init-stanza "USE: fuel fuel-retort")
 
-(defconst fuel-con--comint-finished-regex
+(defconst fuel-con--comint-finished-regex-connected
   (format "^%s$" fuel-con--eot-marker))
 
+(defvar fuel-con--comint-finished-regex fuel-con--prompt-regex)
+
 (defun fuel-con--setup-comint ()
   (set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
   (add-hook 'comint-redirect-filter-functions
@@ -154,17 +152,43 @@
     (setq comint-redirect-finished-regexp fuel-con--prompt-regex))
   str)
 
+(defun fuel-con--establish-connection (conn buffer)
+  (with-current-buffer (fuel-con--comint-buffer) (erase-buffer))
+  (with-current-buffer buffer
+    (setq fuel-con--connection conn)
+    (setq fuel-con--comint-finished-regex fuel-con--prompt-regex)
+    (fuel-con--send-string/wait buffer
+                                fuel-con--init-stanza
+                                'fuel-con--establish-connection-cont
+                                20000)
+    conn))
+
+(defun fuel-con--establish-connection-cont (ignore)
+  (let ((str (with-current-buffer (fuel-con--comint-buffer) (buffer-string))))
+    (if (string-match fuel-con--eot-marker str)
+        (progn
+          (setq fuel-con--comint-finished-regex
+                fuel-con--comint-finished-regex-connected)
+          (fuel-con--connection-start-timer conn)
+          (message "FUEL listener up and running!"))
+      (fuel-con--connection-clean-current-request fuel-con--connection)
+      (setq fuel-con--connection nil)
+      (message "An error occurred initialising FUEL's Factor library!")
+      (pop-to-buffer (fuel-con--comint-buffer)))))
+
 
 ;;; Requests handling:
 
 (defsubst fuel-con--comint-buffer ()
   (get-buffer-create " *fuel connection retort*"))
 
-(defsubst fuel-con--comint-buffer-form ()
+(defun fuel-con--comint-buffer-form ()
   (with-current-buffer (fuel-con--comint-buffer)
     (goto-char (point-min))
     (condition-case nil
-        (read (current-buffer))
+        (let ((form (read (current-buffer))))
+          (if (listp form) form
+            (list 'fuel-con-error (buffer-string))))
       (error (list 'fuel-con-error (buffer-string))))))
 
 (defun fuel-con--process-next (con)
@@ -208,11 +232,12 @@
 
 ;;; Message sending interface:
 
+(defconst fuel-con--error-message "FUEL connection not active")
+
 (defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
   (save-current-buffer
     (let ((con (fuel-con--get-connection buffer/proc)))
-      (unless con
+      (unless con (error fuel-con--error-message))
-        (error "FUEL: couldn't find connection"))
       (let ((req (fuel-con--make-request str cont sender-buffer)))
         (fuel-con--connection-queue-request con req)
         (fuel-con--process-next con)
@@ -223,22 +248,23 @@
 
 (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
   (save-current-buffer
-    (let* ((con (fuel-con--get-connection buffer/proc))
+    (let ((con (fuel-con--get-connection buffer/proc)))
-           (req (fuel-con--send-string buffer/proc str cont sbuf))
+      (unless con (error fuel-con--error-message))
-           (id (and req (fuel-con--request-id req)))
+      (let* ((req (fuel-con--send-string buffer/proc str cont sbuf))
-           (time (or timeout fuel-connection-timeout))
+             (id (and req (fuel-con--request-id req)))
-           (step 100)
+             (time (or timeout fuel-connection-timeout))
-           (waitsecs (/ step 1000.0)))
+             (step 100)
-      (when id
+             (waitsecs (/ step 1000.0)))
-        (condition-case nil
+        (when id
-            (while (and (> time 0)
+          (condition-case nil
-                        (not (fuel-con--connection-completed-p con id)))
+              (while (and (> time 0)
-              (accept-process-output nil waitsecs)
+                          (not (fuel-con--connection-completed-p con id)))
-              (setq time (- time step)))
+                (accept-process-output nil waitsecs)
-          (error (setq time 0)))
+                (setq time (- time step)))
-        (or (> time 0)
+            (error (setq time 0)))
-            (fuel-con--request-deactivate req)
+          (or (> time 0)
-            nil)))))
+              (fuel-con--request-deactivate req)
+              nil))))))
 
 
 (provide 'fuel-connection)

misc/fuel/fuel-listener.el

@@ -78,11 +78,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--setup-connection (current-buffer))))
-    (fuel-con--send-string/wait (current-buffer)
-                                fuel-con--init-stanza
-                                '(lambda (s) (message "FUEL listener up and running!"))
-                                20000)))
 
 (defun fuel-listener--process (&optional start)
   (or (and (buffer-live-p (fuel-listener--buffer))