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

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

db4
erg 2008-05-20 18:58:19 -05:00
parent 9814021e06 60e197448f
commit 3f315e8b4a
14 changed files with 315 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
core/inference/inference-tests.factor
View File

@ -547,3 +547,12 @@ ERROR: custom-error ;
[ [ missing->r-check ] infer ] must-fail
{ 1 0 } [ [ ] map-children ] must-infer-as
! Corner case
[ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
[ [ erg's-inference-bug ] infer ] must-fail

2
core/kernel/kernel-docs.factor
View File

@ -630,7 +630,7 @@ HELP: tri*
"The following two lines are equivalent:"
{ $code
"[ p ] [ q ] [ r ] tri*"
">r >r q r> q r> r"
">r >r p r> q r> r"
}
} ;

4
extra/http/client/client-tests.factor
View File

@ -17,7 +17,7 @@ tuple-syntax namespaces ;
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
}
] [
[
@ -35,7 +35,7 @@ tuple-syntax namespaces ;
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
}
] [
[

8
extra/http/client/client.factor
View File

@ -4,7 +4,7 @@ USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors math.order
io.encodings.8-bit io.encodings.binary io.streams.duplex
fry debugger inspector ;
fry debugger inspector ascii ;
IN: http.client
: max-redirects 10 ;
@ -37,8 +37,12 @@ SYMBOL: redirects
PRIVATE>
: read-chunk-size ( -- n )
read-crlf ";" split1 drop [ blank? ] right-trim
hex> [ "Bad chunk size" throw ] unless* ;
: read-chunks ( -- )
read-crlf ";" split1 drop hex> dup { f 0 } member?
read-chunk-size dup zero?
[ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
: read-response-body ( response -- response data )

3
extra/http/http.factor
View File

@ -256,7 +256,8 @@ cookies ;
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies
"close" "connection" set-header ;
"close" "connection" set-header
"Factor http.client vocabulary" "user-agent" set-header ;
: query-param ( request key -- value )
swap query>> at ;

6
extra/io/ports/ports.factor
View File

@ -115,11 +115,11 @@ M: buffered-port dispose*
[ [ [ buffer-free ] when* f ] change-buffer drop ]
bi ;
HOOK: cancel-io io-backend ( port -- )
GENERIC: cancel-io ( handle -- )
M: port timed-out cancel-io ;
M: port timed-out handle>> cancel-io ;
M: port dispose* [ cancel-io ] [ handle>> dispose ] bi ;
M: port dispose* handle>> [ cancel-io ] [ dispose ] bi ;
: <ports> ( read-handle write-handle -- input-port output-port )
[

15
extra/io/unix/backend/backend.factor
View File

@ -25,7 +25,7 @@ TUPLE: fd fd disposed ;
M: fd dispose* fd>> close-file ;
M: fd handle-fd fd>> ;
M: fd handle-fd dup check-disposed fd>> ;
! I/O multiplexers
TUPLE: mx fd reads writes ;
@ -62,11 +62,14 @@ GENERIC: wait-for-events ( ms mx -- )
: output-available ( fd mx -- )
remove-output-callbacks [ resume ] each ;
M: unix cancel-io ( port -- )
handle>> handle-fd mx get-global
[ remove-input-callbacks [ t swap resume-with ] each ]
[ remove-output-callbacks [ t swap resume-with ] each ]
2bi ;
M: fd cancel-io ( fd -- )
dup disposed>> [ drop ] [
fd>>
mx get-global
[ remove-input-callbacks [ t swap resume-with ] each ]
[ remove-output-callbacks [ t swap resume-with ] each ]
2bi
] if ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+

3
extra/io/unix/sockets/secure/secure.factor
View File

@ -64,6 +64,9 @@ M: ssl-handle drain
SSL_write
check-write-response ;
M: ssl-handle cancel-io
file>> cancel-io ;
! Client sockets
: <ssl-socket> ( fd -- ssl )
[ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>

4
extra/io/windows/nt/backend/backend.factor
View File

@ -71,8 +71,8 @@ M: winnt add-completion ( win32-handle -- )
resume-callback t
] if ;
M: winnt cancel-io
handle>> handle>> CancelIo drop ;
M: win32-handle cancel-io
handle>> CancelIo drop ;
M: winnt io-multiplex ( ms -- )
handle-overlapped [ 0 io-multiplex ] when ;

8
extra/openssl/openssl.factor
View File

@ -153,13 +153,13 @@ M: openssl-context dispose*
TUPLE: ssl-handle file handle connected disposed ;
ERROR: no-ssl-context ;
ERROR: no-secure-context ;
M: no-ssl-context summary
drop "SSL operations must be wrapped in calls to with-ssl-context" ;
M: no-secure-context summary
drop "Secure socket operations must be wrapped in calls to with-secure-context" ;
: current-ssl-context ( -- ctx )
secure-context get [ no-ssl-context ] unless* ;
secure-context get [ no-secure-context ] unless* ;
: <ssl-handle> ( fd -- ssl )
current-ssl-context handle>> SSL_new dup ssl-error

7
extra/symbols/symbols-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel symbols tools.test parser generic words ;
USING: kernel symbols tools.test parser generic words accessors ;
IN: symbols.tests
[ ] [ SYMBOLS: a b c ; ] unit-test
@ -13,3 +13,8 @@ DEFER: blah
[ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test
[ "IN: symbols.tests USE: symbols SINGLETONS: blah blah blah ;" eval ]
[ error>> error>> def>> \ blah eq? ]
must-fail-with

2
extra/symbols/symbols.factor
View File

@ -10,5 +10,5 @@ IN: symbols
: SINGLETONS:
";" parse-tokens
[ create-class-in dup save-location define-singleton-class ] each ;
[ create-class-in define-singleton-class ] each ;
parsing

5
unmaintained/regexp2/regexp2-tests.factor Normal file
View File

@ -0,0 +1,5 @@
USING: kernel peg regexp2 sequences tools.test ;
IN: regexp2.tests
[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ]
[ "056" 'octal' parse ] unit-test

262
unmaintained/regexp2/regexp2.factor Normal file
View File

@ -0,0 +1,262 @@
USING: assocs combinators.lib kernel math math.parser
namespaces peg unicode.case sequences unicode.categories
memoize peg.parsers math.order ;
USE: io
USE: tools.walker
IN: regexp2
<PRIVATE
SYMBOL: ignore-case?
: char=-quot ( ch -- quot )
ignore-case? get
[ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
curry ;
: char-between?-quot ( ch1 ch2 -- quot )
ignore-case? get
[ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
[ [ between? ] ]
if 2curry ;
: or-predicates ( quots -- quot )
[ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
: literal-action [ nip ] curry action ;
: delay-action [ curry ] curry action ;
PRIVATE>
: ascii? ( n -- ? )
0 HEX: 7f between? ;
: octal-digit? ( n -- ? )
CHAR: 0 CHAR: 7 between? ;
: hex-digit? ( n -- ? )
{
[ dup digit? ]
[ dup CHAR: a CHAR: f between? ]
[ dup CHAR: A CHAR: F between? ]
} || nip ;
: control-char? ( n -- ? )
{ [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ;
: punct? ( n -- ? )
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
: c-identifier-char? ( ch -- ? )
{ [ dup alpha? ] [ dup CHAR: _ = ] } || nip ;
: java-blank? ( n -- ? )
{
CHAR: \s
CHAR: \t CHAR: \n CHAR: \r
HEX: c HEX: 7 HEX: 1b
} member? ;
: java-printable? ( n -- ? )
{ [ dup alpha? ] [ dup punct? ] } || nip ;
MEMO: 'ordinary-char' ( -- parser )
[ "\\^*+?|(){}[$" member? not ] satisfy
[ char=-quot ] action ;
MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
MEMO: 'octal' ( -- parser )
"0" token hide 'octal-digit' 1 3 from-m-to-n 2seq
[ first oct> ] action ;
MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
MEMO: 'hex' ( -- parser )
"x" token hide 'hex-digit' 2 exactly-n 2seq
"u" token hide 'hex-digit' 6 exactly-n 2seq 2choice
[ first hex> ] action ;
: satisfy-tokens ( assoc -- parser )
[ >r token r> literal-action ] { } assoc>map choice ;
MEMO: 'simple-escape-char' ( -- parser )
{
{ "\\" CHAR: \\ }
{ "t" CHAR: \t }
{ "n" CHAR: \n }
{ "r" CHAR: \r }
{ "f" HEX: c }
{ "a" HEX: 7 }
{ "e" HEX: 1b }
} [ char=-quot ] assoc-map satisfy-tokens ;
MEMO: 'predefined-char-class' ( -- parser )
{
{ "d" [ digit? ] }
{ "D" [ digit? not ] }
{ "s" [ java-blank? ] }
{ "S" [ java-blank? not ] }
{ "w" [ c-identifier-char? ] }
{ "W" [ c-identifier-char? not ] }
} satisfy-tokens ;
MEMO: 'posix-character-class' ( -- parser )
{
{ "Lower" [ letter? ] }
{ "Upper" [ LETTER? ] }
{ "ASCII" [ ascii? ] }
{ "Alpha" [ Letter? ] }
{ "Digit" [ digit? ] }
{ "Alnum" [ alpha? ] }
{ "Punct" [ punct? ] }
{ "Graph" [ java-printable? ] }
{ "Print" [ java-printable? ] }
{ "Blank" [ " \t" member? ] }
{ "Cntrl" [ control-char? ] }
{ "XDigit" [ hex-digit? ] }
{ "Space" [ java-blank? ] }
} satisfy-tokens "p{" "}" surrounded-by ;
MEMO: 'simple-escape' ( -- parser )
[
'octal' ,
'hex' ,
"c" token hide [ LETTER? ] satisfy 2seq ,
any-char ,
] choice* [ char=-quot ] action ;
MEMO: 'escape' ( -- parser )
"\\" token hide [
'simple-escape-char' ,
'predefined-char-class' ,
'posix-character-class' ,
'simple-escape' ,
] choice* 2seq ;
MEMO: 'any-char' ( -- parser )
"." token [ drop t ] literal-action ;
MEMO: 'char' ( -- parser )
'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ;
DEFER: 'regexp'
TUPLE: group-result str ;
C: <group-result> group-result
MEMO: 'non-capturing-group' ( -- parser )
"?:" token hide 'regexp' ;
MEMO: 'positive-lookahead-group' ( -- parser )
"?=" token hide 'regexp' [ ensure ] action ;
MEMO: 'negative-lookahead-group' ( -- parser )
"?!" token hide 'regexp' [ ensure-not ] action ;
MEMO: 'simple-group' ( -- parser )
'regexp' [ [ <group-result> ] action ] action ;
MEMO: 'group' ( -- parser )
[
'non-capturing-group' ,
'positive-lookahead-group' ,
'negative-lookahead-group' ,
'simple-group' ,
] choice* "(" ")" surrounded-by ;
MEMO: 'range' ( -- parser )
any-char "-" token hide any-char 3seq
[ first2 char-between?-quot ] action ;
MEMO: 'character-class-term' ( -- parser )
'range'
'escape'
[ "\\]" member? not ] satisfy [ char=-quot ] action
3choice ;
MEMO: 'positive-character-class' ( -- parser )
! todo
"]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq
'character-class-term' repeat1 2choice [ or-predicates ] action ;
MEMO: 'negative-character-class' ( -- parser )
"^" token hide 'positive-character-class' 2seq
[ [ not ] append ] action ;
MEMO: 'character-class' ( -- parser )
'negative-character-class' 'positive-character-class' 2choice
"[" "]" surrounded-by [ satisfy ] action ;
MEMO: 'escaped-seq' ( -- parser )
any-char repeat1
[ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ;
MEMO: 'break' ( quot -- parser )
satisfy ensure
epsilon just 2choice ;
MEMO: 'break-escape' ( -- parser )
"$" token [ "\r\n" member? ] 'break' literal-action
"\\b" token [ blank? ] 'break' literal-action
"\\B" token [ blank? not ] 'break' literal-action
"\\z" token epsilon just literal-action 4choice ;
MEMO: 'simple' ( -- parser )
[
'escaped-seq' ,
'break-escape' ,
'group' ,
'character-class' ,
'char' ,
] choice* ;
MEMO: 'exactly-n' ( -- parser )
'integer' [ exactly-n ] delay-action ;
MEMO: 'at-least-n' ( -- parser )
'integer' "," token hide 2seq [ at-least-n ] delay-action ;
MEMO: 'at-most-n' ( -- parser )
"," token hide 'integer' 2seq [ at-most-n ] delay-action ;
MEMO: 'from-m-to-n' ( -- parser )
'integer' "," token hide 'integer' 3seq
[ first2 from-m-to-n ] delay-action ;
MEMO: 'greedy-interval' ( -- parser )
'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ;
MEMO: 'interval' ( -- parser )
'greedy-interval'
'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action
'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action
3choice "{" "}" surrounded-by ;
MEMO: 'repetition' ( -- parser )
[
! Possessive
! "*+" token [ <!*> ] literal-action ,
! "++" token [ <!+> ] literal-action ,
! "?+" token [ <!?> ] literal-action ,
! Reluctant
! "*?" token [ <(*)> ] literal-action ,
! "+?" token [ <(+)> ] literal-action ,
! "??" token [ <(?)> ] literal-action ,
! Greedy
"*" token [ repeat0 ] literal-action ,
"+" token [ repeat1 ] literal-action ,
"?" token [ optional ] literal-action ,
] choice* ;
MEMO: 'dummy' ( -- parser )
epsilon [ ] literal-action ;
! todo -- check the action
! MEMO: 'term' ( -- parser )
! 'simple'
! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action
! <!+> [ <and-parser> ] action ;