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

core/inference/inference-tests.factor

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

core/kernel/kernel-docs.factor

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

extra/http/client/client-tests.factor

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

extra/http/client/client.factor

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

extra/http/http.factor

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

extra/io/ports/ports.factor

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

extra/io/unix/backend/backend.factor

@@ -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 -- )
+M: fd cancel-io ( fd -- )
-    handle>> handle-fd mx get-global
+    dup disposed>> [ drop ] [
-    [ remove-input-callbacks [ t swap resume-with ] each ]
+        fd>>
-    [ remove-output-callbacks [ t swap resume-with ] each ]
+        mx get-global
-    2bi ;
+        [ 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+

extra/io/unix/sockets/secure/secure.factor

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

extra/io/windows/nt/backend/backend.factor

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

extra/openssl/openssl.factor

@@ -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
+M: no-secure-context summary
-    drop "SSL operations must be wrapped in calls to with-ssl-context" ;
+    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

extra/symbols/symbols-tests.factor

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

extra/symbols/symbols.factor

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

unmaintained/regexp2/regexp2-tests.factor

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

unmaintained/regexp2/regexp2.factor

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