Fix conflict
Slava Pestov
commit
52f1ff3a95
|
|
@ -273,3 +273,6 @@ TUPLE: id obj ;
|
|||
] if ;
|
||||
|
||||
[ 4.0 ] [ 2.0 blah ] unit-test
|
||||
|
||||
[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
|
||||
[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -228,12 +228,12 @@ M:: ppc %fixnum-mul ( src1 src2 -- )
|
|||
"no-overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
src1 src1 tag-bits get SRAWI
|
||||
scratch-reg src1 src2 MULLWO.
|
||||
scratch-reg src1 tag-bits get SRAWI
|
||||
scratch-reg scratch-reg src2 MULLWO.
|
||||
scratch-reg ds-reg 0 STW
|
||||
"no-overflow" get BNO
|
||||
src2 src2 tag-bits get SRAWI
|
||||
src1 src2 move>args
|
||||
scratch-reg src2 move>args
|
||||
%prepare-alien-invoke
|
||||
"overflow_fixnum_multiply" f %alien-invoke
|
||||
"no-overflow" resolve-label ;
|
||||
|
|
@ -242,14 +242,14 @@ M:: ppc %fixnum-mul-tail ( src1 src2 -- )
|
|||
"overflow" define-label
|
||||
0 0 LI
|
||||
0 MTXER
|
||||
src1 src1 tag-bits get SRAWI
|
||||
scratch-reg src1 src2 MULLWO.
|
||||
scratch-reg src1 tag-bits get SRAWI
|
||||
scratch-reg scratch-reg src2 MULLWO.
|
||||
"overflow" get BO
|
||||
scratch-reg ds-reg 0 STW
|
||||
BLR
|
||||
"overflow" resolve-label
|
||||
src2 src2 tag-bits get SRAWI
|
||||
src1 src2 move>args
|
||||
scratch-reg src2 move>args
|
||||
%prepare-alien-invoke
|
||||
"overflow_fixnum_multiply" f %alien-invoke-tail ;
|
||||
|
||||
|
|
|
|||
|
|
@ -204,8 +204,25 @@ HELP: on-bits
|
|||
"64 on-bits .h"
|
||||
"ffffffffffffffff"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: toggle-bit
|
||||
{ $values
|
||||
{ "m" integer }
|
||||
{ "n" integer }
|
||||
{ "m'" integer }
|
||||
}
|
||||
;
|
||||
{ $description "Toggles the nth bit of an integer." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"0 3 toggle-bit .b"
|
||||
"1000"
|
||||
}
|
||||
{ $example "USING: math.bitwise kernel prettyprint ;"
|
||||
"BIN: 1000 3 toggle-bit .b"
|
||||
"0"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: set-bit
|
||||
{ $values
|
||||
|
|
|
|||
|
|
@ -29,3 +29,6 @@ IN: math.bitwise.tests
|
|||
\ foo must-infer
|
||||
|
||||
[ 1 ] [ { 1 } flags ] unit-test
|
||||
|
||||
[ 8 ] [ 0 3 toggle-bit ] unit-test
|
||||
[ 0 ] [ 8 3 toggle-bit ] unit-test
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ IN: math.bitwise
|
|||
: bits ( m n -- m' ) 2^ wrap ; inline
|
||||
: mask-bit ( m n -- m' ) 2^ mask ; inline
|
||||
: on-bits ( n -- m ) 2^ 1- ; inline
|
||||
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline
|
||||
|
||||
: shift-mod ( n s w -- n )
|
||||
[ shift ] dip 2^ wrap ; inline
|
||||
|
|
|
|||
|
|
@ -5,12 +5,13 @@ IN: regexp.backend
|
|||
|
||||
TUPLE: regexp
|
||||
raw
|
||||
{ stack vector }
|
||||
parse-tree
|
||||
{ options hashtable }
|
||||
stack
|
||||
parse-tree
|
||||
nfa-table
|
||||
dfa-table
|
||||
minimized-table
|
||||
matchers
|
||||
{ nfa-traversal-flags hashtable }
|
||||
{ dfa-traversal-flags hashtable }
|
||||
{ state integer }
|
||||
|
|
|
|||
|
|
@ -1,12 +1,25 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math math.order symbols regexp.parser
|
||||
USING: accessors kernel math math.order symbols
|
||||
words regexp.utils unicode.categories combinators.short-circuit ;
|
||||
IN: regexp.classes
|
||||
|
||||
SINGLETONS: any-char any-char-no-nl
|
||||
letter-class LETTER-class Letter-class digit-class
|
||||
alpha-class non-newline-blank-class
|
||||
ascii-class punctuation-class java-printable-class blank-class
|
||||
control-character-class hex-digit-class java-blank-class c-identifier-class
|
||||
unmatchable-class terminator-class word-boundary-class ;
|
||||
|
||||
SINGLETONS: beginning-of-input beginning-of-line
|
||||
end-of-input end-of-line ;
|
||||
|
||||
MIXIN: node
|
||||
TUPLE: character-class-range from to ; INSTANCE: character-class-range node
|
||||
|
||||
GENERIC: class-member? ( obj class -- ? )
|
||||
|
||||
M: word class-member? ( obj class -- ? ) 2drop f ;
|
||||
M: t class-member? ( obj class -- ? ) 2drop f ;
|
||||
|
||||
M: integer class-member? ( obj class -- ? ) 2drop f ;
|
||||
|
||||
|
|
@ -18,7 +31,7 @@ M: any-char class-member? ( obj class -- ? )
|
|||
|
||||
M: any-char-no-nl class-member? ( obj class -- ? )
|
||||
drop CHAR: \n = not ;
|
||||
|
||||
|
||||
M: letter-class class-member? ( obj class -- ? )
|
||||
drop letter? ;
|
||||
|
||||
|
|
@ -70,3 +83,9 @@ M: terminator-class class-member? ( obj class -- ? )
|
|||
[ CHAR: \u002028 = ]
|
||||
[ CHAR: \u002029 = ]
|
||||
} 1|| ;
|
||||
|
||||
M: beginning-of-line class-member? ( obj class -- ? )
|
||||
2drop f ;
|
||||
|
||||
M: end-of-line class-member? ( obj class -- ? )
|
||||
2drop f ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays assocs grouping kernel regexp.backend
|
||||
locals math namespaces regexp.parser sequences fry quotations
|
||||
math.order math.ranges vectors unicode.categories regexp.utils
|
||||
regexp.transition-tables words sets ;
|
||||
regexp.transition-tables words sets regexp.classes unicode.case ;
|
||||
IN: regexp.nfa
|
||||
|
||||
SYMBOL: negation-mode
|
||||
|
|
@ -22,8 +22,13 @@ SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag
|
|||
SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag
|
||||
SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag
|
||||
|
||||
: add-global-flag ( flag -- )
|
||||
current-regexp get nfa-table>> flags>> conjoin ;
|
||||
: options ( -- obj ) current-regexp get options>> ;
|
||||
|
||||
: option? ( obj -- ? ) options key? ;
|
||||
|
||||
: option-on ( obj -- ) options conjoin ;
|
||||
|
||||
: option-off ( obj -- ) options delete-at ;
|
||||
|
||||
: next-state ( regexp -- state )
|
||||
[ state>> ] [ [ 1+ ] change-state drop ] bi ;
|
||||
|
|
@ -106,6 +111,7 @@ M: kleene-star nfa-node ( node -- )
|
|||
|
||||
M: concatenation nfa-node ( node -- )
|
||||
seq>>
|
||||
reversed-regexp option? [ <reversed> ] when
|
||||
[ [ nfa-node ] each ]
|
||||
[ length 1- [ concatenate-nodes ] times ] bi ;
|
||||
|
||||
|
|
@ -115,16 +121,59 @@ M: alternation nfa-node ( node -- )
|
|||
[ length 1- [ alternate-nodes ] times ] bi ;
|
||||
|
||||
M: constant nfa-node ( node -- )
|
||||
char>> literal-transition add-simple-entry ;
|
||||
case-insensitive option? [
|
||||
dup char>> [ ch>lower ] [ ch>upper ] bi
|
||||
2dup = [
|
||||
2drop
|
||||
char>> literal-transition add-simple-entry
|
||||
] [
|
||||
[ literal-transition add-simple-entry ] bi@
|
||||
alternate-nodes drop
|
||||
] if
|
||||
] [
|
||||
char>> literal-transition add-simple-entry
|
||||
] if ;
|
||||
|
||||
M: epsilon nfa-node ( node -- )
|
||||
drop eps literal-transition add-simple-entry ;
|
||||
|
||||
M: word nfa-node ( node -- )
|
||||
M: word nfa-node ( node -- ) class-transition add-simple-entry ;
|
||||
|
||||
M: any-char nfa-node ( node -- )
|
||||
[ dotall option? ] dip any-char-no-nl ?
|
||||
class-transition add-simple-entry ;
|
||||
|
||||
! M: beginning-of-text nfa-node ( node -- ) ;
|
||||
|
||||
M: beginning-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
|
||||
|
||||
M: end-of-line nfa-node ( node -- ) class-transition add-simple-entry ;
|
||||
|
||||
: choose-letter-class ( node -- node' )
|
||||
case-insensitive option? Letter-class rot ? ;
|
||||
|
||||
M: letter-class nfa-node ( node -- )
|
||||
choose-letter-class class-transition add-simple-entry ;
|
||||
|
||||
M: LETTER-class nfa-node ( node -- )
|
||||
choose-letter-class class-transition add-simple-entry ;
|
||||
|
||||
M: character-class-range nfa-node ( node -- )
|
||||
class-transition add-simple-entry ;
|
||||
case-insensitive option? [
|
||||
dup [ from>> ] [ to>> ] bi
|
||||
2dup [ Letter? ] bi@ and [
|
||||
rot drop
|
||||
[ [ ch>lower ] bi@ character-class-range boa ]
|
||||
[ [ ch>upper ] bi@ character-class-range boa ] 2bi
|
||||
[ class-transition add-simple-entry ] bi@
|
||||
alternate-nodes
|
||||
] [
|
||||
2drop
|
||||
class-transition add-simple-entry
|
||||
] if
|
||||
] [
|
||||
class-transition add-simple-entry
|
||||
] if ;
|
||||
|
||||
M: capture-group nfa-node ( node -- )
|
||||
eps literal-transition add-simple-entry
|
||||
|
|
@ -141,26 +190,6 @@ M: non-capture-group nfa-node ( node -- )
|
|||
M: reluctant-kleene-star nfa-node ( node -- )
|
||||
term>> <kleene-star> nfa-node ;
|
||||
|
||||
M: beginning-of-line nfa-node ( node -- )
|
||||
drop
|
||||
eps literal-transition add-simple-entry
|
||||
beginning-of-line add-global-flag ;
|
||||
|
||||
M: end-of-line nfa-node ( node -- )
|
||||
drop
|
||||
eps literal-transition add-simple-entry
|
||||
end-of-line add-global-flag ;
|
||||
|
||||
M: beginning-of-input nfa-node ( node -- )
|
||||
drop
|
||||
eps literal-transition add-simple-entry
|
||||
beginning-of-input add-global-flag ;
|
||||
|
||||
M: end-of-input nfa-node ( node -- )
|
||||
drop
|
||||
eps literal-transition add-simple-entry
|
||||
end-of-input add-global-flag ;
|
||||
|
||||
M: negation nfa-node ( node -- )
|
||||
negation-mode inc
|
||||
term>> nfa-node
|
||||
|
|
@ -182,6 +211,10 @@ M: lookbehind nfa-node ( node -- )
|
|||
lookbehind-off add-traversal-flag
|
||||
2 [ concatenate-nodes ] times ;
|
||||
|
||||
M: option nfa-node ( node -- )
|
||||
[ option>> ] [ on?>> ] bi [ option-on ] [ option-off ] if
|
||||
eps literal-transition add-simple-entry ;
|
||||
|
||||
: construct-nfa ( regexp -- )
|
||||
[
|
||||
reset-regexp
|
||||
|
|
|
|||
|
|
@ -19,8 +19,8 @@ IN: regexp.parser
|
|||
[ ] [ "(?:a)" test-regexp ] unit-test
|
||||
[ ] [ "(?i:a)" test-regexp ] unit-test
|
||||
[ ] [ "(?-i:a)" test-regexp ] unit-test
|
||||
[ "(?z:a)" test-regexp ] [ bad-option? ] must-fail-with
|
||||
[ "(?-z:a)" test-regexp ] [ bad-option? ] must-fail-with
|
||||
[ "(?z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
|
||||
[ "(?-z:a)" test-regexp ] [ unknown-regexp-option? ] must-fail-with
|
||||
|
||||
[ ] [ "(?=a)" test-regexp ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -4,12 +4,11 @@ USING: accessors arrays assocs combinators io io.streams.string
|
|||
kernel math math.parser namespaces qualified sets
|
||||
quotations sequences splitting symbols vectors math.order
|
||||
unicode.categories strings regexp.backend regexp.utils
|
||||
unicode.case words locals ;
|
||||
unicode.case words locals regexp.classes ;
|
||||
IN: regexp.parser
|
||||
|
||||
FROM: math.ranges => [a,b] ;
|
||||
|
||||
MIXIN: node
|
||||
TUPLE: concatenation seq ; INSTANCE: concatenation node
|
||||
TUPLE: alternation seq ; INSTANCE: alternation node
|
||||
TUPLE: kleene-star term ; INSTANCE: kleene-star node
|
||||
|
|
@ -40,38 +39,31 @@ INSTANCE: independent-group parentheses-group
|
|||
TUPLE: comment-group term ; INSTANCE: comment-group node
|
||||
INSTANCE: comment-group parentheses-group
|
||||
|
||||
TUPLE: character-class-range from to ; INSTANCE: character-class-range node
|
||||
SINGLETON: epsilon INSTANCE: epsilon node
|
||||
SINGLETON: any-char INSTANCE: any-char node
|
||||
SINGLETON: any-char-no-nl INSTANCE: any-char-no-nl node
|
||||
SINGLETON: beginning-of-input INSTANCE: beginning-of-input node
|
||||
SINGLETON: end-of-input INSTANCE: end-of-input node
|
||||
SINGLETON: beginning-of-line INSTANCE: beginning-of-line node
|
||||
SINGLETON: end-of-line INSTANCE: end-of-line node
|
||||
|
||||
TUPLE: option-on option ; INSTANCE: option-on node
|
||||
TUPLE: option-off option ; INSTANCE: option-off node
|
||||
TUPLE: option option on? ; INSTANCE: option node
|
||||
|
||||
SINGLETONS: unix-lines dotall multiline comments case-insensitive
|
||||
unicode-case reversed-regexp ;
|
||||
|
||||
SINGLETONS: letter-class LETTER-class Letter-class digit-class
|
||||
alpha-class non-newline-blank-class
|
||||
ascii-class punctuation-class java-printable-class blank-class
|
||||
control-character-class hex-digit-class java-blank-class c-identifier-class
|
||||
unmatchable-class terminator-class word-boundary-class ;
|
||||
|
||||
SINGLETONS: beginning-of-group end-of-group
|
||||
beginning-of-character-class end-of-character-class
|
||||
SINGLETONS: beginning-of-character-class end-of-character-class
|
||||
left-parenthesis pipe caret dash ;
|
||||
|
||||
: get-option ( option -- ? ) current-regexp get options>> at ;
|
||||
: get-unix-lines ( -- ? ) unix-lines get-option ;
|
||||
: get-dotall ( -- ? ) dotall get-option ;
|
||||
: get-multiline ( -- ? ) multiline get-option ;
|
||||
: get-comments ( -- ? ) comments get-option ;
|
||||
: get-case-insensitive ( -- ? ) case-insensitive get-option ;
|
||||
: get-unicode-case ( -- ? ) unicode-case get-option ;
|
||||
: get-reversed-regexp ( -- ? ) reversed-regexp get-option ;
|
||||
: push1 ( obj -- ) input-stream get stream>> push ;
|
||||
: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
|
||||
: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
|
||||
: drop1 ( -- ) read1 drop ;
|
||||
|
||||
: stack ( -- obj ) current-regexp get stack>> ;
|
||||
: change-whole-stack ( quot -- )
|
||||
current-regexp get
|
||||
[ stack>> swap call ] keep (>>stack) ; inline
|
||||
: push-stack ( obj -- ) stack push ;
|
||||
: pop-stack ( -- obj ) stack pop ;
|
||||
: cut-out ( vector n -- vector' vector ) cut rest ;
|
||||
ERROR: cut-stack-error ;
|
||||
: cut-stack ( obj vector -- vector' vector )
|
||||
tuck last-index [ cut-stack-error ] unless* cut-out swap ;
|
||||
|
||||
: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
|
||||
: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;
|
||||
|
|
@ -80,18 +72,11 @@ left-parenthesis pipe caret dash ;
|
|||
|
||||
: <negation> ( obj -- negation ) negation boa ;
|
||||
: <concatenation> ( seq -- concatenation )
|
||||
>vector get-reversed-regexp [ reverse ] when
|
||||
[ epsilon ] [ concatenation boa ] if-empty ;
|
||||
>vector [ epsilon ] [ concatenation boa ] if-empty ;
|
||||
: <alternation> ( seq -- alternation ) >vector alternation boa ;
|
||||
: <capture-group> ( obj -- capture-group ) capture-group boa ;
|
||||
: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
|
||||
: <constant> ( obj -- constant )
|
||||
dup Letter? get-case-insensitive and [
|
||||
[ ch>lower ] [ ch>upper ] bi
|
||||
[ constant boa ] bi@ 2array <alternation>
|
||||
] [
|
||||
constant boa
|
||||
] if ;
|
||||
: <constant> ( obj -- constant ) constant boa ;
|
||||
|
||||
: first|concatenation ( seq -- first/concatenation )
|
||||
dup length 1 = [ first ] [ <concatenation> ] if ;
|
||||
|
|
@ -100,21 +85,14 @@ left-parenthesis pipe caret dash ;
|
|||
dup length 1 = [ first ] [ <alternation> ] if ;
|
||||
|
||||
: <character-class-range> ( from to -- obj )
|
||||
2dup [ Letter? ] bi@ or get-case-insensitive and [
|
||||
[ [ ch>lower ] bi@ character-class-range boa ]
|
||||
[ [ ch>upper ] bi@ character-class-range boa ] 2bi
|
||||
2array [ [ from>> ] [ to>> ] bi < ] filter
|
||||
[ unmatchable-class ] [ first|alternation ] if-empty
|
||||
] [
|
||||
2dup <
|
||||
[ character-class-range boa ] [ 2drop unmatchable-class ] if
|
||||
] if ;
|
||||
2dup <
|
||||
[ character-class-range boa ] [ 2drop unmatchable-class ] if ;
|
||||
|
||||
ERROR: unmatched-parentheses ;
|
||||
|
||||
ERROR: bad-option ch ;
|
||||
ERROR: unknown-regexp-option option ;
|
||||
|
||||
: option ( ch -- singleton )
|
||||
: ch>option ( ch -- singleton )
|
||||
{
|
||||
{ CHAR: i [ case-insensitive ] }
|
||||
{ CHAR: d [ unix-lines ] }
|
||||
|
|
@ -124,13 +102,21 @@ ERROR: bad-option ch ;
|
|||
{ CHAR: s [ dotall ] }
|
||||
{ CHAR: u [ unicode-case ] }
|
||||
{ CHAR: x [ comments ] }
|
||||
[ bad-option ]
|
||||
[ unknown-regexp-option ]
|
||||
} case ;
|
||||
|
||||
: option-on ( option -- ) current-regexp get options>> conjoin ;
|
||||
: option-off ( option -- ) current-regexp get options>> delete-at ;
|
||||
: option>ch ( option -- string )
|
||||
{
|
||||
{ case-insensitive [ CHAR: i ] }
|
||||
{ multiline [ CHAR: m ] }
|
||||
{ reversed-regexp [ CHAR: r ] }
|
||||
{ dotall [ CHAR: s ] }
|
||||
[ unknown-regexp-option ]
|
||||
} case ;
|
||||
|
||||
: toggle-option ( ch ? -- )
|
||||
[ ch>option ] dip option boa push-stack ;
|
||||
|
||||
: toggle-option ( ch ? -- ) [ option ] dip [ option-on ] [ option-off ] if ;
|
||||
: (parse-options) ( string ? -- ) [ toggle-option ] curry each ;
|
||||
|
||||
: parse-options ( string -- )
|
||||
|
|
@ -176,7 +162,7 @@ DEFER: (parse-regexp)
|
|||
[ drop1 (parse-special-group) ]
|
||||
[ capture-group f nested-parse-regexp ] if ;
|
||||
|
||||
: handle-dot ( -- ) get-dotall any-char any-char-no-nl ? push-stack ;
|
||||
: handle-dot ( -- ) any-char push-stack ;
|
||||
: handle-pipe ( -- ) pipe push-stack ;
|
||||
: (handle-star) ( obj -- kleene-star )
|
||||
peek1 {
|
||||
|
|
@ -234,11 +220,8 @@ ERROR: invalid-range a b ;
|
|||
[ [ nip at-most-n ] [ at-least-n ] if* ] if
|
||||
] [ drop 0 max exactly-n ] if ;
|
||||
|
||||
: handle-front-anchor ( -- )
|
||||
get-multiline beginning-of-line beginning-of-input ? push-stack ;
|
||||
|
||||
: handle-back-anchor ( -- )
|
||||
get-multiline end-of-line end-of-input ? push-stack ;
|
||||
: handle-front-anchor ( -- ) beginning-of-line push-stack ;
|
||||
: handle-back-anchor ( -- ) end-of-line push-stack ;
|
||||
|
||||
ERROR: bad-character-class obj ;
|
||||
ERROR: expected-posix-class ;
|
||||
|
|
@ -247,8 +230,8 @@ ERROR: expected-posix-class ;
|
|||
read1 CHAR: { = [ expected-posix-class ] unless
|
||||
"}" read-until [ bad-character-class ] unless
|
||||
{
|
||||
{ "Lower" [ get-case-insensitive Letter-class letter-class ? ] }
|
||||
{ "Upper" [ get-case-insensitive Letter-class LETTER-class ? ] }
|
||||
{ "Lower" [ letter-class ] }
|
||||
{ "Upper" [ LETTER-class ] }
|
||||
{ "Alpha" [ Letter-class ] }
|
||||
{ "ASCII" [ ascii-class ] }
|
||||
{ "Digit" [ digit-class ] }
|
||||
|
|
@ -412,7 +395,8 @@ DEFER: handle-left-bracket
|
|||
[ first|concatenation ] map first|alternation ;
|
||||
|
||||
: handle-right-parenthesis ( -- )
|
||||
stack dup [ parentheses-group "members" word-prop member? ] find-last -rot cut rest
|
||||
stack dup [ parentheses-group "members" word-prop member? ] find-last
|
||||
-rot cut rest
|
||||
[ [ push ] keep current-regexp get (>>stack) ]
|
||||
[ finish-regexp-parse push-stack ] bi* ;
|
||||
|
||||
|
|
@ -429,12 +413,9 @@ DEFER: handle-left-bracket
|
|||
{ CHAR: [ [ handle-left-bracket t ] }
|
||||
{ CHAR: \ [ handle-escape t ] }
|
||||
[
|
||||
dup CHAR: $ = peek1 f = and [
|
||||
drop
|
||||
handle-back-anchor f
|
||||
] [
|
||||
push-constant t
|
||||
] if
|
||||
dup CHAR: $ = peek1 f = and
|
||||
[ drop handle-back-anchor f ]
|
||||
[ push-constant t ] if
|
||||
]
|
||||
} case ;
|
||||
|
||||
|
|
@ -451,7 +432,6 @@ DEFER: handle-left-bracket
|
|||
parse-regexp-beginning (parse-regexp)
|
||||
] with-input-stream
|
||||
] unless-empty
|
||||
current-regexp get
|
||||
stack finish-regexp-parse
|
||||
>>parse-tree drop
|
||||
current-regexp get [ finish-regexp-parse ] change-stack
|
||||
dup stack>> >>parse-tree drop
|
||||
] with-variable ;
|
||||
|
|
|
|||
|
|
@ -238,7 +238,7 @@ IN: regexp-tests
|
|||
|
||||
[ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
|
||||
[ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
|
||||
[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/r matches? ] unit-test
|
||||
[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test
|
||||
|
||||
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
|
||||
|
|
@ -307,17 +307,30 @@ IN: regexp-tests
|
|||
! Bug in parsing word
|
||||
[ t ] [ "a" R' a' matches? ] unit-test
|
||||
|
||||
! Convert to lowercase until E
|
||||
[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
|
||||
[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test
|
||||
|
||||
! Convert to uppercase until E
|
||||
[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test
|
||||
[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test
|
||||
|
||||
! [ "{Lower}" <regexp> ] [ invalid-range? ] must-fail-with
|
||||
|
||||
[ t ] [ "a" R/ ^a/ matches? ] unit-test
|
||||
[ f ] [ "\na" R/ ^a/ matches? ] unit-test
|
||||
[ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
|
||||
[ f ] [ "\ra" R/ ^a/ matches? ] unit-test
|
||||
! [ t ] [ "a" R/ ^a/ matches? ] unit-test
|
||||
! [ f ] [ "\na" R/ ^a/ matches? ] unit-test
|
||||
! [ f ] [ "\r\na" R/ ^a/ matches? ] unit-test
|
||||
! [ f ] [ "\ra" R/ ^a/ matches? ] unit-test
|
||||
|
||||
[ t ] [ "a" R/ a$/ matches? ] unit-test
|
||||
[ f ] [ "a\n" R/ a$/ matches? ] unit-test
|
||||
[ f ] [ "a\r" R/ a$/ matches? ] unit-test
|
||||
[ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
|
||||
! [ t ] [ "a" R/ a$/ matches? ] unit-test
|
||||
! [ f ] [ "a\n" R/ a$/ matches? ] unit-test
|
||||
! [ f ] [ "a\r" R/ a$/ matches? ] unit-test
|
||||
! [ f ] [ "a\r\n" R/ a$/ matches? ] unit-test
|
||||
|
||||
! [ t ] [ "a" R/ a$|b$/ matches? ] unit-test
|
||||
! [ t ] [ "b" R/ a$|b$/ matches? ] unit-test
|
||||
! [ t ] [ "ab" R/ a$|b$/ matches? ] unit-test
|
||||
! [ t ] [ "ba" R/ ba$|b$/ matches? ] unit-test
|
||||
|
||||
! [ t ] [ "a" R/ \Aa/ matches? ] unit-test
|
||||
! [ f ] [ "\na" R/ \Aaa/ matches? ] unit-test
|
||||
|
|
@ -347,14 +360,6 @@ IN: regexp-tests
|
|||
! [ t ] [ "\r\na" R/ ^a/m matches? ] unit-test
|
||||
! [ t ] [ "\ra" R/ ^a/m matches? ] unit-test
|
||||
|
||||
! Convert to lowercase until E
|
||||
[ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test
|
||||
[ t ] [ "aa" R/ \LAA\E/ matches? ] unit-test
|
||||
|
||||
! Convert to uppercase until E
|
||||
[ t ] [ "AA" R/ \Uaa\E/ matches? ] unit-test
|
||||
[ f ] [ "aa" R/ \Uaa\E/ matches? ] unit-test
|
||||
|
||||
! [ t ] [ "a" "a$" R/ a$/m matches? ] unit-test
|
||||
! [ t ] [ "a\n" "a$" R/ a$/m matches? ] unit-test
|
||||
! [ t ] [ "a\r" "a$" R/ a$/m matches? ] unit-test
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@ IN: regexp
|
|||
H{ } clone >>nfa-traversal-flags
|
||||
H{ } clone >>dfa-traversal-flags
|
||||
H{ } clone >>options
|
||||
H{ } clone >>matchers
|
||||
reset-regexp ;
|
||||
|
||||
: construct-regexp ( regexp -- regexp' )
|
||||
|
|
@ -93,26 +94,6 @@ IN: regexp
|
|||
{ "R| " "|" }
|
||||
} swap [ subseq? not nip ] curry assoc-find drop ;
|
||||
|
||||
ERROR: unknown-regexp-option option ;
|
||||
|
||||
: option>ch ( option -- string )
|
||||
{
|
||||
{ case-insensitive [ CHAR: i ] }
|
||||
{ multiline [ CHAR: m ] }
|
||||
{ reversed-regexp [ CHAR: r ] }
|
||||
{ dotall [ CHAR: s ] }
|
||||
[ unknown-regexp-option ]
|
||||
} case ;
|
||||
|
||||
: ch>option ( ch -- option )
|
||||
{
|
||||
{ CHAR: i [ case-insensitive ] }
|
||||
{ CHAR: m [ multiline ] }
|
||||
{ CHAR: r [ reversed-regexp ] }
|
||||
{ CHAR: s [ dotall ] }
|
||||
[ unknown-regexp-option ]
|
||||
} case ;
|
||||
|
||||
: string>options ( string -- options )
|
||||
[ ch>option dup ] H{ } map>assoc ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,18 +20,19 @@ TUPLE: default ;
|
|||
|
||||
: <literal-transition> ( from to obj -- transition )
|
||||
literal-transition make-transition ;
|
||||
|
||||
: <class-transition> ( from to obj -- transition )
|
||||
class-transition make-transition ;
|
||||
|
||||
: <default-transition> ( from to -- transition )
|
||||
t default-transition make-transition ;
|
||||
|
||||
TUPLE: transition-table transitions start-state final-states flags ;
|
||||
TUPLE: transition-table transitions start-state final-states ;
|
||||
|
||||
: <transition-table> ( -- transition-table )
|
||||
transition-table new
|
||||
H{ } clone >>transitions
|
||||
H{ } clone >>final-states
|
||||
H{ } clone >>flags ;
|
||||
H{ } clone >>final-states ;
|
||||
|
||||
: maybe-initialize-key ( key hashtable -- )
|
||||
2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
|
||||
|
|
|
|||
|
|
@ -26,23 +26,6 @@ IN: regexp.utils
|
|||
: ?insert-at ( value key hash/f -- hash )
|
||||
[ H{ } clone ] unless* [ insert-at ] keep ;
|
||||
|
||||
: last-state ( regexp -- range ) stack>> peek first2 [a,b] ;
|
||||
: push1 ( obj -- ) input-stream get stream>> push ;
|
||||
: peek1 ( -- obj ) input-stream get stream>> [ f ] [ peek ] if-empty ;
|
||||
: pop3 ( seq -- obj1 obj2 obj3 ) [ pop ] [ pop ] [ pop ] tri spin ;
|
||||
: drop1 ( -- ) read1 drop ;
|
||||
|
||||
: stack ( -- obj ) current-regexp get stack>> ;
|
||||
: change-whole-stack ( quot -- )
|
||||
current-regexp get
|
||||
[ stack>> swap call ] keep (>>stack) ; inline
|
||||
: push-stack ( obj -- ) stack push ;
|
||||
: pop-stack ( -- obj ) stack pop ;
|
||||
: cut-out ( vector n -- vector' vector ) cut rest ;
|
||||
ERROR: cut-stack-error ;
|
||||
: cut-stack ( obj vector -- vector' vector )
|
||||
tuck last-index [ cut-stack-error ] unless* cut-out swap ;
|
||||
|
||||
ERROR: bad-octal number ;
|
||||
ERROR: bad-hex number ;
|
||||
: check-octal ( octal -- octal ) dup 255 > [ bad-octal ] when ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel sequences strings ;
|
||||
USING: help.markup help.syntax kernel sequences byte-arrays
|
||||
strings ;
|
||||
IN: tools.hexdump
|
||||
|
||||
HELP: hexdump.
|
||||
{ $values { "seq" sequence } }
|
||||
{ $values { "byte-array" byte-array } }
|
||||
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
|
||||
|
||||
HELP: hexdump
|
||||
{ $values { "seq" sequence } { "str" string } }
|
||||
{ $values { "byte-array" byte-array } { "str" string } }
|
||||
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
|
||||
{ $see-also hexdump. } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: tools.hexdump kernel sequences tools.test ;
|
||||
USING: tools.hexdump kernel sequences tools.test byte-arrays ;
|
||||
IN: tools.hexdump.tests
|
||||
|
||||
[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
|
||||
[ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
|
||||
[ t ] [ B{ } hexdump "Length: 0, 0h\n" = ] unit-test
|
||||
[ t ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a qrstuvwxyz\n" = ] unit-test
|
||||
|
||||
[ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
|
||||
[ t ] [ 256 [ ] B{ } map-as hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
|
||||
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays io io.streams.string kernel math math.parser
|
||||
namespaces sequences splitting grouping strings ascii ;
|
||||
namespaces sequences splitting grouping strings ascii byte-arrays ;
|
||||
IN: tools.hexdump
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -28,9 +28,11 @@ IN: tools.hexdump
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: hexdump. ( seq -- )
|
||||
GENERIC: hexdump. ( byte-array -- )
|
||||
|
||||
M: byte-array hexdump.
|
||||
[ length write-header ]
|
||||
[ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
|
||||
|
||||
: hexdump ( seq -- str )
|
||||
: hexdump ( byte-array -- str )
|
||||
[ hexdump. ] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -1,21 +1,6 @@
|
|||
USING: help.markup help.syntax ;
|
||||
USING: help.markup help.syntax io quotations ;
|
||||
IN: io.encodings
|
||||
|
||||
ABOUT: "io.encodings"
|
||||
|
||||
ARTICLE: "io.encodings" "I/O encodings"
|
||||
"Bytes can't be understood in isolation as text. They must be interpreted under a certain encoding. Factor provides utilities for dealing with encoded text by declaring that a stream has a particular encoding, and utilities to encode and decode strings."
|
||||
{ $subsection "encodings-descriptors" }
|
||||
{ $subsection "encodings-constructors" }
|
||||
{ $subsection "io.encodings.string" }
|
||||
"New types of encodings can be defined:"
|
||||
{ $subsection "encodings-protocol" } ;
|
||||
|
||||
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
|
||||
"The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors."
|
||||
{ $subsection <encoder> }
|
||||
{ $subsection <decoder> } ;
|
||||
|
||||
HELP: <encoder>
|
||||
{ $values { "stream" "an output stream" }
|
||||
{ "encoding" "an encoding descriptor" }
|
||||
|
|
@ -30,8 +15,66 @@ HELP: <decoder>
|
|||
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: decode-char
|
||||
{ $values { "stream" "an underlying input stream" }
|
||||
{ "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
|
||||
{ $contract "Reads a single code point from the underlying stream, interpreting it by the encoding. Returns " { $link f } " if the stream is reached." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: encode-char
|
||||
{ $values { "char" "a character" }
|
||||
{ "stream" "an underlying output stream" }
|
||||
{ "encoding" "an encoding descriptor" } }
|
||||
{ $contract "Writes the code point to the underlying stream in the given encoding." }
|
||||
$low-level-note ;
|
||||
|
||||
{ encode-char decode-char } related-words
|
||||
|
||||
HELP: decode-input
|
||||
{ $values
|
||||
{ "encoding" "an encoding descriptor" }
|
||||
}
|
||||
{ $description "Changes the encoding of the current input stream stored in the " { $link input-stream } " variable." } ;
|
||||
|
||||
HELP: encode-output
|
||||
{ $values
|
||||
{ "encoding" "an encoding descriptor" }
|
||||
}
|
||||
{ $description "Changes the encoding of the current output stream stored in the " { $link output-stream } " variable." } ;
|
||||
|
||||
HELP: re-decode
|
||||
{ $values
|
||||
{ "stream" "a stream" } { "encoding" "an encoding descriptor" }
|
||||
{ "newstream" "a new stream" }
|
||||
}
|
||||
{ $description "Creates a new decoding stream with the supplied encoding descriptor from an existing stream by calling the " { $link <decoder> } " word." } ;
|
||||
|
||||
HELP: re-encode
|
||||
{ $values
|
||||
{ "stream" "a stream" } { "encoding" "an encoding descriptor" }
|
||||
{ "newstream" "a new stream" }
|
||||
}
|
||||
{ $description "Creates a new encoding stream with the supplied encoding descriptor from an existing stream by calling the " { $link <encoder> } " word." } ;
|
||||
|
||||
{ re-decode re-encode } related-words
|
||||
|
||||
HELP: with-decoded-input
|
||||
{ $values
|
||||
{ "encoding" "an encoding descriptor" } { "quot" quotation }
|
||||
}
|
||||
{ $description "Creates a new decoding stream with the given encoding descriptor and calls the quotation with this stream set to the " { $link input-stream } " variable. The original decoder stream is restored after the quotation returns and the stream is kept open for future input operations." } ;
|
||||
|
||||
HELP: with-encoded-output
|
||||
{ $values
|
||||
{ "encoding" "an encoding descriptor" } { "quot" quotation }
|
||||
}
|
||||
{ $description "Creates a new encoder with the given encoding descriptor and calls the quotation using this encoder. The original encoder object is restored after the quotation returns and the stream is kept open for future output operations." } ;
|
||||
|
||||
HELP: replacement-char
|
||||
{ $description "A code point that replaces input that could not be decoded. The presence of this character in the decoded data usually signifies an error." } ;
|
||||
|
||||
ARTICLE: "encodings-descriptors" "Encoding descriptors"
|
||||
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
|
||||
"An encoding descriptor is something which can be used for input or output streams to encode or decode bytes stored in a certain representation. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
|
||||
{ $subsection "io.encodings.binary" }
|
||||
{ $subsection "io.encodings.utf8" }
|
||||
{ $subsection "io.encodings.utf16" }
|
||||
|
|
@ -50,17 +93,26 @@ ARTICLE: "encodings-protocol" "Encoding protocol"
|
|||
{ $subsection encode-char }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
HELP: decode-char
|
||||
{ $values { "stream" "an underlying input stream" }
|
||||
{ "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
|
||||
{ $contract "Reads a single code point from the underlying stream, interpreting it by the encoding." }
|
||||
$low-level-note ;
|
||||
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
|
||||
"The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and call these constructors internally."
|
||||
{ $subsection <encoder> }
|
||||
{ $subsection <decoder> } ;
|
||||
|
||||
HELP: encode-char
|
||||
{ $values { "char" "a character" }
|
||||
{ "stream" "an underlying output stream" }
|
||||
{ "encoding" "an encoding descriptor" } }
|
||||
{ $contract "Writes the code point in the encoding to the underlying stream given." }
|
||||
$low-level-note ;
|
||||
ARTICLE: "io.encodings" "I/O encodings"
|
||||
"The " { $vocab-link "io.encodings" } " vocabulary provides utilities for encoding and decoding bytes that represent text. Both strings and streams may be encoded."
|
||||
{ $subsection "encodings-descriptors" }
|
||||
{ $subsection "encodings-constructors" }
|
||||
{ $subsection "io.encodings.string" }
|
||||
"New types of encodings can be defined:"
|
||||
{ $subsection "encodings-protocol" }
|
||||
"Setting encodings on the current streams:"
|
||||
{ $subsection encode-output }
|
||||
{ $subsection decode-input }
|
||||
"Setting encodings on streams:"
|
||||
{ $subsection re-encode }
|
||||
{ $subsection re-decode }
|
||||
"Combinators to change the encoding:"
|
||||
{ $subsection with-encoded-output }
|
||||
{ $subsection with-decoded-input } ;
|
||||
|
||||
{ encode-char decode-char } related-words
|
||||
ABOUT: "io.encodings"
|
||||
|
|
|
|||
|
|
@ -114,6 +114,9 @@ HELP: input-stream
|
|||
HELP: output-stream
|
||||
{ $var-description "Holds an output stream for various implicit stream operations. Rebound using " { $link with-output-stream } " and " { $link with-output-stream* } "." } ;
|
||||
|
||||
HELP: error-stream
|
||||
{ $var-description "Holds an error stream." } ;
|
||||
|
||||
HELP: readln
|
||||
{ $values { "str/f" "a string or " { $link f } } }
|
||||
{ $description "Reads a line of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." }
|
||||
|
|
|
|||
|
|
@ -2,7 +2,32 @@ USING: help.markup help.syntax io io.ports kernel math
|
|||
io.files.unique.private math.parser io.files ;
|
||||
IN: io.files.unique
|
||||
|
||||
ARTICLE: "unique" "Making and using unique files"
|
||||
HELP: make-unique-file ( prefix suffix -- path )
|
||||
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
||||
{ "path" "a pathname string" } }
|
||||
{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
|
||||
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." }
|
||||
{ $see-also with-unique-file } ;
|
||||
|
||||
HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- )
|
||||
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
||||
{ "quot" "a quotation" } }
|
||||
{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
|
||||
{ $notes "The unique file will be deleted after calling this word." } ;
|
||||
|
||||
HELP: make-unique-directory ( -- path )
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
|
||||
{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." }
|
||||
{ $see-also with-unique-directory } ;
|
||||
|
||||
HELP: with-unique-directory ( quot -- )
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-directory } " combinator. The quotation can access the " { $link current-directory } " symbol for the name of the temporary directory." }
|
||||
{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation." } ;
|
||||
|
||||
ARTICLE: "io.files.unique" "Temporary files"
|
||||
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
|
||||
"Files:"
|
||||
{ $subsection make-unique-file }
|
||||
{ $subsection with-unique-file }
|
||||
|
|
@ -10,28 +35,4 @@ ARTICLE: "unique" "Making and using unique files"
|
|||
{ $subsection make-unique-directory }
|
||||
{ $subsection with-unique-directory } ;
|
||||
|
||||
ABOUT: "unique"
|
||||
|
||||
HELP: make-unique-file ( prefix suffix -- path )
|
||||
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
||||
{ "path" "a pathname string" } }
|
||||
{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
|
||||
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
|
||||
{ $see-also with-unique-file } ;
|
||||
|
||||
HELP: make-unique-directory ( -- path )
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
|
||||
{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
|
||||
{ $see-also with-unique-directory } ;
|
||||
|
||||
HELP: with-unique-file ( prefix suffix quot -- )
|
||||
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
||||
{ "quot" "a quotation" } }
|
||||
{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
|
||||
{ $notes "The unique file will be deleted after calling this word." } ;
|
||||
|
||||
HELP: with-unique-directory ( quot -- )
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack." }
|
||||
{ $notes "The directory will be deleted after calling this word." } ;
|
||||
ABOUT: "io.files.unique"
|
||||
|
|
|
|||
|
|
@ -1,13 +1,20 @@
|
|||
USING: io.encodings.ascii sequences strings io io.files accessors
|
||||
tools.test kernel io.files.unique ;
|
||||
tools.test kernel io.files.unique namespaces continuations ;
|
||||
IN: io.files.unique.tests
|
||||
|
||||
[ 123 ] [
|
||||
"core" ".test" [
|
||||
[
|
||||
ascii [
|
||||
123 CHAR: a <repetition> >string write
|
||||
] with-file-writer
|
||||
] keep file-info size>>
|
||||
[ [ 123 CHAR: a <repetition> ] dip ascii set-file-contents ]
|
||||
[ file-info size>> ] bi
|
||||
] with-unique-file
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ current-directory get file-info directory? ] with-unique-directory
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
current-directory get
|
||||
[ [ "FAILDOG" throw ] with-unique-directory ] [ drop ] recover
|
||||
current-directory get =
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -3,10 +3,17 @@
|
|||
USING: kernel math math.bitwise combinators.lib math.parser
|
||||
random sequences sequences.lib continuations namespaces
|
||||
io.files io arrays io.files.unique.backend system
|
||||
combinators vocabs.loader ;
|
||||
combinators vocabs.loader fry ;
|
||||
IN: io.files.unique
|
||||
|
||||
SYMBOL: unique-length
|
||||
SYMBOL: unique-retries
|
||||
|
||||
10 unique-length set-global
|
||||
10 unique-retries set-global
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: random-letter ( -- ch )
|
||||
26 random { CHAR: a CHAR: A } random + ;
|
||||
|
||||
|
|
@ -17,29 +24,27 @@ IN: io.files.unique
|
|||
: random-name ( n -- string )
|
||||
[ random-ch ] "" replicate-as ;
|
||||
|
||||
: unique-length ( -- n ) 10 ; inline
|
||||
: unique-retries ( -- n ) 10 ; inline
|
||||
PRIVATE>
|
||||
|
||||
: make-unique-file ( prefix suffix -- path )
|
||||
temporary-path -rot
|
||||
[
|
||||
unique-length random-name swap 3append append-path
|
||||
unique-length get random-name swap 3append append-path
|
||||
dup (make-unique-file)
|
||||
] 3curry unique-retries retry ;
|
||||
] 3curry unique-retries get retry ;
|
||||
|
||||
: with-unique-file ( prefix suffix quot -- )
|
||||
>r make-unique-file r> keep delete-file ; inline
|
||||
: with-unique-file ( prefix suffix quot: ( path -- ) -- )
|
||||
[ make-unique-file ] dip [ delete-file ] bi ; inline
|
||||
|
||||
: make-unique-directory ( -- path )
|
||||
[
|
||||
temporary-path unique-length random-name append-path
|
||||
temporary-path unique-length get random-name append-path
|
||||
dup make-directory
|
||||
] unique-retries retry ;
|
||||
] unique-retries get retry ;
|
||||
|
||||
: with-unique-directory ( quot -- )
|
||||
>r make-unique-directory r>
|
||||
[ with-directory ] curry keep delete-tree ; inline
|
||||
: with-unique-directory ( quot: ( -- ) -- )
|
||||
[ make-unique-directory ] dip
|
||||
'[ _ with-directory ] [ delete-tree ] bi ; inline
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "io.unix.files.unique" ] }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test math.floating-point ;
|
||||
USING: tools.test math.floating-point math.constants kernel ;
|
||||
IN: math.floating-point.tests
|
||||
|
||||
[ t ] [ pi >double< >double pi = ] unit-test
|
||||
[ t ] [ -1.0 >double< >double -1.0 = ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,20 +1,20 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences prettyprint math.parser io
|
||||
math.functions ;
|
||||
math.functions math.bitwise ;
|
||||
IN: math.floating-point
|
||||
|
||||
: (double-sign) ( bits -- n ) -63 shift ; inline
|
||||
: double-sign ( double -- n ) double>bits (double-sign) ;
|
||||
|
||||
: (double-exponent-bits) ( bits -- n )
|
||||
-52 shift 11 2^ 1- bitand ; inline
|
||||
-52 shift 11 on-bits mask ; inline
|
||||
|
||||
: double-exponent-bits ( double -- n )
|
||||
double>bits (double-exponent-bits) ;
|
||||
|
||||
: (double-mantissa-bits) ( double -- n )
|
||||
52 2^ 1- bitand ;
|
||||
52 on-bits mask ;
|
||||
|
||||
: double-mantissa-bits ( double -- n )
|
||||
double>bits (double-mantissa-bits) ;
|
||||
|
|
@ -37,4 +37,3 @@ IN: math.floating-point
|
|||
(double-mantissa-bits) >bin 52 CHAR: 0 pad-left
|
||||
11 [ bl ] times print
|
||||
] tri ;
|
||||
|
||||
|
|
|
|||
|
|
@ -102,3 +102,5 @@ USING: math.matrices math.vectors tools.test math ;
|
|||
[ { 0 0 -1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test
|
||||
[ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test
|
||||
[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
|
||||
|
||||
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
|
||||
|
|
|
|||
Loading…
Reference in New Issue