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

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

db4
Slava Pestov 2009-01-09 17:59:19 -06:00
parent 46fdfd2d84 b08e1a0205
commit df2171df1a
26 changed files with 291 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/bootstrap/unicode/unicode.factor
View File

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

6
basis/combinators/smart/smart-docs.factor
View File

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

4
basis/combinators/smart/smart-tests.factor
View File

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

4
basis/combinators/smart/smart.factor
View File

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

24
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -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 ? ]
[
{
[ body-length-bias ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
node-count-bias
loop-nesting get 0 or 2 *
] bi* + + + + + + ;
[ classes-known? 2 0 ? ]
[
{
[ body-length-bias ]
[ "default" word-prop -4 0 ? ]
[ "specializer" word-prop 1 0 ? ]
[ method-body? 1 0 ? ]
} cleave
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 ;

2
basis/io/files/info/unix/freebsd/freebsd.factor
View File

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

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

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

4
basis/io/files/unix/unix-tests.factor
View File

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

2
basis/tools/files/files.factor
View File

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

127
basis/unicode/breaks/breaks.factor
View File

@ -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
Control CR LF 3array graphemes break-around
L L V LV LVT 4array connect-before
V V T 2array connect-before
LV V T 2array connect-before
T T connect
LVT T connect
graphemes Extend connect-after
graphemes SpacingMark connect-after
Prepend graphemes connect-before ;
{ CR } { LF } connect
{ Control CR LF } graphemes disconnect
graphemes { Control CR LF } disconnect
{ L } { L V LV LVT } connect
{ LV V } { V T } connect
{ LVT T } { T } connect
graphemes { Extend } connect
graphemes { SpacingMark } connect
{ Prepend } graphemes connect ;
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
{ wNewline wCR wLF } e words break-around
wALetter dup connect
wALetter { wMidLetter wMidNumLet } e check-letter-after check-before
{ wMidLetter wMidNumLet } e wALetter check-letter-before check-after
wNumeric dup connect
wALetter wNumeric connect
wNumeric wALetter connect
wNumeric { wMidNum wMidNumLet } e check-number-after check-before
{ wMidNum wMidNumLet } e wNumeric check-number-before check-after
wKatakana dup connect
{ wALetter wNumeric wKatakana wExtendNumLet } e wExtendNumLet
[ connect-after ] [ swap connect-before ] 2bi ;
{ wCR } { wLF } connect
{ wNewline wCR wLF } words disconnect
words { wNewline wCR wLF } disconnect
{ wALetter } { wMidLetter wMidNumLet } check-letter-after set-table
{ wMidLetter wMidNumLet } { wALetter } check-letter-before set-table
{ wNumeric wALetter } { wNumeric wALetter } connect
{ wNumeric } { wMidNum wMidNumLet } check-number-after set-table
{ wMidNum wMidNumLet } { wNumeric } check-number-before set-table
{ wKatakana } { wKatakana } connect
{ wALetter wNumeric wKatakana wExtendNumLet } { wExtendNumLet }
[ connect ] [ swap connect ] 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 )
i 1 + str [ format/extended? not ] find-from drop
[ 1+ str [ format/extended? not ] find-from drop ] [ f ] if* ;
: (walk-up) ( str i -- j )
swap [ format/extended? not ] find-from drop ;
:: walk-down ( str i -- j )
i str [ format/extended? not ] find-last-from drop
[ 1- str [ format/extended? not ] find-last-from drop ] [ f ] if* ;
: walk-up ( str i -- j )
dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ;
:: word-break? ( table-entry i str -- ? )
table-entry {
{ t [ f ] }
{ f [ t ] }
: (walk-down) ( str i -- j )
swap [ format/extended? not ] find-last-from drop ;
: 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= ] }
} case ;
[ dupd walk-down wNumeric property-not= ] }
} 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 )
str unclip-slice word-break-prop over <enum>
[ swap str word-break-next ] assoc-find 2drop
nip swap length or 1+ ;
: first-word ( str -- i )
[ unclip-slice word-break-prop over <enum> ] keep
'[ swap _ word-break-next ] assoc-find 2drop
nip swap length or 1+ ; inline
HINTS: first-word string ;
: >words ( str -- words )
[ first-word ] >pieces ;
HINTS: >words string ;

57
basis/unicode/case/case.factor
View File

@ -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
unicode.normalize math unicode.categories combinators unicode.syntax
assocs strings splitting kernel accessors unicode.breaks fry ;
USING: unicode.data sequences sequences.next namespaces
sbufs make unicode.syntax unicode.normalize math hints
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>upper ( ch -- upper ) simple-upper at-default ;
: ch>title ( ch -- title ) simple-title at-default ;
: ch>lower ( ch -- lower ) simple-lower at-default ; inline
: ch>upper ( ch -- upper ) simple-upper at-default ; inline
: 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 )
[
[
[ dup special-casing at ] 2dip
[ [ % ] compose ] [ [ , ] compose ] bi* ?if
] 2curry each
] "" make ; inline
:: map-case ( string string-quot char-quot -- case )
string length <sbuf> :> out
string [
dup special-casing at
[ string-quot call out push-all ]
[ char-quot call out push ] ?if
] 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 ;

6
basis/unicode/data/data.factor
View File

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

2
basis/unicode/normalize/normalize-tests.factor
View File

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

152
basis/unicode/normalize/normalize.factor
View File

@ -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? ;
: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ;
: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ; inline
: 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 ;
: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ;
: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ;
dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ; inline
: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ; inline
: 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 [
string length <sbuf> :> out
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
] dup reorder ;
] if
] 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 ;
: current ( -- ch ) 0 get-str ;
: to ( -- ) ind inc ;
: initial-medial? ( str i -- ? )
{ [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ;
: initial-medial? ( -- ? )
current initial? [ 1 get-str medial? ] [ f ] if ;
: --final? ( str i -- ? )
2 + swap ?nth final? ;
: --final? ( -- ? )
2 get-str final? ;
: imf, ( str i -- str i )
[ tail-slice first3 jamo>hangul , ]
[ 3 + ] 2bi ;
: imf, ( -- )
current to current to current jamo>hangul , ;
: im, ( str i -- str i )
[ tail-slice first2 final-base jamo>hangul , ]
[ 2 + ] 2bi ;
: im, ( -- )
current to current final-base jamo>hangul , ;
: compose-jamo ( str i -- str i )
2dup initial-medial? [
2dup --final? [ imf, ] [ im, ] if
] [ 2dup swap nth , 1+ ] if ;
: compose-jamo ( -- )
initial-medial? [
--final? [ imf, ] [ im, ] if
] [ current , ] if to ;
: pass-combining ( str -- str i )
dup [ non-starter? not ] find drop
[ dup length ] unless*
2dup head-slice % ;
: pass-combining ( -- )
current non-starter? [ current , to pass-combining ] when ;
TUPLE: compose-state i str char after last-class ;
:: try-compose ( last-class new-char current-class -- new-class )
last-class current-class = [ new-char after get push last-class ] [
char get new-char combine-chars
[ char set last-class ]
[ new-char after get push current-class ] if*
] if ;
: get-str ( state i -- ch )
swap [ i>> + ] [ str>> ] bi ?nth ; inline
: current ( state -- ch ) 0 get-str ; inline
: to ( state -- state ) [ 1+ ] change-i ; inline
: push-after ( ch state -- state ) [ ?push ] change-after ; inline
:: 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 -- )
char get swap combine-chars
[ char set to f compose-iter ] when* ;
: try-noncombining ( char state -- state )
tuck char>> swap combine-chars
[ >>char to f >>last-class compose-iter ] when* ; inline
: compose-iter ( last-class -- )
current [
: compose-iter ( state -- state )
dup current [
dup combining-class {
{ f [ 2drop ] }
{ 0 [ swap [ drop ] [ try-noncombining ] if ] }
{ f [ drop ] }
{ 0 [
over last-class>>
[ drop ] [ swap try-noncombining ] if ] }
[ try-compose to compose-iter ]
} case
] [ drop ] if* ;
] when* ; inline recursive
: ?new-after ( -- )
after [ dup empty? [ drop SBUF" " clone ] unless ] change ;
: compose-combining ( ch str i -- str i )
compose-state new
swap >>i
swap >>str
swap >>char
compose-iter
{ [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; inline
: compose-combining ( ch -- )
char set to ?new-after
f compose-iter
char get , after get % ;
: (compose) ( -- )
current [
dup jamo? [ drop compose-jamo ] [
1 get-str combining-class
[ compose-combining ] [ , to ] if
:: (compose) ( str i -- )
i str ?nth [
dup jamo? [ drop str i compose-jamo ] [
i 1+ str ?nth combining-class
[ str i 1+ compose-combining ] [ , str i 1+ ] if
] if (compose)
] when* ;
] when* ; inline recursive
: combine ( str -- comp )
[
main-str set
0 ind set
SBUF" " clone after set
pass-combining (compose)
] "" make ;
[ pass-combining (compose) ] "" make ;
HINTS: combine string ;
PRIVATE>

6
basis/unix/groups/groups-docs.factor
View File

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

2
basis/unix/groups/groups-tests.factor
View File

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

19
basis/unix/groups/groups.factor
View File

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

2
basis/unix/statfs/freebsd/freebsd.factor
View File

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

2
basis/unix/statfs/linux/linux.factor
View File

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

3
basis/unix/statfs/macosx/macosx.factor
View File

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

2
basis/unix/statfs/openbsd/openbsd.factor
View File

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

1
basis/values/values-docs.factor
View File

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

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

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

5
misc/fuel/fuel-autodoc.el
View File

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

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

@ -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
(or fuel-con--connection
(setq fuel-con--connection
(fuel-con--setup-connection buffer/proc))))))
(with-current-buffer buffer/proc fuel-con--connection)))
;;; 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
(setq fuel-con--connection conn)
(fuel-con--connection-start-timer conn))))
(fuel-con--establish-connection conn buffer)))
(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
(error "FUEL: couldn't find connection"))
(unless con (error fuel-con--error-message))
(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))
(req (fuel-con--send-string buffer/proc str cont sbuf))
(id (and req (fuel-con--request-id req)))
(time (or timeout fuel-connection-timeout))
(step 100)
(waitsecs (/ step 1000.0)))
(when id
(condition-case nil
(while (and (> time 0)
(not (fuel-con--connection-completed-p con id)))
(accept-process-output nil waitsecs)
(setq time (- time step)))
(error (setq time 0)))
(or (> time 0)
(fuel-con--request-deactivate req)
nil)))))
(let ((con (fuel-con--get-connection buffer/proc)))
(unless con (error fuel-con--error-message))
(let* ((req (fuel-con--send-string buffer/proc str cont sbuf))
(id (and req (fuel-con--request-id req)))
(time (or timeout fuel-connection-timeout))
(step 100)
(waitsecs (/ step 1000.0)))
(when id
(condition-case nil
(while (and (> time 0)
(not (fuel-con--connection-completed-p con id)))
(accept-process-output nil waitsecs)
(setq time (- time step)))
(error (setq time 0)))
(or (> time 0)
(fuel-con--request-deactivate req)
nil))))))
(provide 'fuel-connection)

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

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