diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 46d1049a11..dc037d4a59 100755 --- a/core/inference/inference-tests.factor +++ b/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 diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index e4100557e1..60151d9f55 100755 --- a/core/kernel/kernel-docs.factor +++ b/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" } } ; diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 9ad805b81b..db90f746ac 100755 --- a/extra/http/client/client-tests.factor +++ b/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" } } } ] [ [ diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index cec1bb931a..c455c8c5f1 100755 --- a/extra/http/client/client.factor +++ b/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 ) diff --git a/extra/http/http.factor b/extra/http/http.factor index bc79424552..7587cb0fe9 100755 --- a/extra/http/http.factor +++ b/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 ; diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index b82797354f..e3c873e9d0 100755 --- a/extra/io/ports/ports.factor +++ b/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 ; : ( read-handle write-handle -- input-port output-port ) [ diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 8f5b6c7540..723ce8b255 100755 --- a/extra/io/unix/backend/backend.factor +++ b/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 -- ) - 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+ diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 35f72a5d16..f3931ae397 100755 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/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 : ( fd -- ssl ) [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 5cc0751c55..27fe558642 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/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 - handle>> handle>> CancelIo drop ; +M: win32-handle cancel-io + handle>> CancelIo drop ; M: winnt io-multiplex ( ms -- ) handle-overlapped [ 0 io-multiplex ] when ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index a7ba2eab0f..df285d26c2 100755 --- a/extra/openssl/openssl.factor +++ b/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 - 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* ; : ( fd -- ssl ) current-ssl-context handle>> SSL_new dup ssl-error diff --git a/extra/symbols/symbols-tests.factor b/extra/symbols/symbols-tests.factor index 0eacbbfd38..1ae4a38cb7 100755 --- a/extra/symbols/symbols-tests.factor +++ b/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 + diff --git a/extra/symbols/symbols.factor b/extra/symbols/symbols.factor index 50733a620e..20cf16e640 100755 --- a/extra/symbols/symbols.factor +++ b/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 diff --git a/unmaintained/regexp2/regexp2-tests.factor b/unmaintained/regexp2/regexp2-tests.factor new file mode 100644 index 0000000000..1fb3f61f29 --- /dev/null +++ b/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 diff --git a/unmaintained/regexp2/regexp2.factor b/unmaintained/regexp2/regexp2.factor new file mode 100644 index 0000000000..f7023c74bf --- /dev/null +++ b/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 + +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 + +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' [ [ ] 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 + ! [ ] action ; +