Merge branch 'master' of factorcode.org:/git/factor
Eduardo Cavazos
commit
92ce3b9c3d
|
|
@ -89,11 +89,6 @@ set_md5sum() {
|
|||
set_gcc() {
|
||||
case $OS in
|
||||
openbsd) ensure_program_installed egcc; CC=egcc;;
|
||||
netbsd) if [[ $WORD -eq 64 ]] ; then
|
||||
CC=/usr/pkg/gcc34/bin/gcc
|
||||
else
|
||||
CC=gcc
|
||||
fi ;;
|
||||
*) CC=gcc;;
|
||||
esac
|
||||
}
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ M: relative-overflow summary
|
|||
drop "Superfluous items pushed to data stack" ;
|
||||
|
||||
: assert-depth ( quot -- )
|
||||
>r datastack r> swap slip >r datastack r>
|
||||
>r datastack r> dip >r datastack r>
|
||||
2dup [ length ] compare {
|
||||
{ +lt+ [ trim-datastacks nip relative-underflow ] }
|
||||
{ +eq+ [ 2drop ] }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -57,6 +57,8 @@ DEFER: if
|
|||
|
||||
: dip ( obj quot -- obj ) swap slip ; inline
|
||||
|
||||
: 2dip ( obj1 obj2 quot -- obj1 obj2 ) -rot 2slip ; inline
|
||||
|
||||
! Keepers
|
||||
: keep ( x quot -- x ) over slip ; inline
|
||||
|
||||
|
|
@ -88,14 +90,14 @@ DEFER: if
|
|||
|
||||
! Spreaders
|
||||
: bi* ( x y p q -- )
|
||||
>r swap slip r> call ; inline
|
||||
>r dip r> call ; inline
|
||||
|
||||
: tri* ( x y z p q r -- )
|
||||
>r rot >r bi* r> r> call ; inline
|
||||
|
||||
! Double spreaders
|
||||
: 2bi* ( w x y z p q -- )
|
||||
>r -rot 2slip r> call ; inline
|
||||
>r 2dip r> call ; inline
|
||||
|
||||
! Appliers
|
||||
: bi@ ( x y quot -- )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ IN: alarms
|
|||
USING: help.markup help.syntax calendar quotations ;
|
||||
|
||||
HELP: alarm
|
||||
{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ;
|
||||
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
|
||||
|
||||
HELP: add-alarm
|
||||
{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } }
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ M: mailbox dispose* threads>> notify-all ;
|
|||
|
||||
: while-mailbox-empty ( mailbox quot -- )
|
||||
over mailbox-empty? [
|
||||
dup >r swap slip r> while-mailbox-empty
|
||||
dup >r dip r> while-mailbox-empty
|
||||
] [
|
||||
2drop
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -1,8 +0,0 @@
|
|||
IN: db.pooling.tests
|
||||
USING: db.pooling tools.test ;
|
||||
|
||||
\ <pool> must-infer
|
||||
|
||||
{ 2 0 } [ [ ] with-db-pool ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ ] with-pooled-connection ] must-infer-as
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays namespaces sequences continuations
|
||||
destructors db ;
|
||||
IN: db.pooling
|
||||
|
||||
TUPLE: pool db params connections ;
|
||||
|
||||
: <pool> ( db params -- pool )
|
||||
V{ } clone pool boa ;
|
||||
|
||||
M: pool dispose [ dispose-each f ] change-connections drop ;
|
||||
|
||||
: with-db-pool ( db params quot -- )
|
||||
>r <pool> r> [ pool swap with-variable ] curry with-disposal ; inline
|
||||
|
||||
TUPLE: return-connection db pool ;
|
||||
|
||||
: return-connection ( db pool -- )
|
||||
connections>> push ;
|
||||
|
||||
: new-connection ( pool -- )
|
||||
[ [ db>> ] [ params>> ] bi make-db db-open ] keep
|
||||
return-connection ;
|
||||
|
||||
: acquire-connection ( pool -- db )
|
||||
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
|
||||
connections>> pop ;
|
||||
|
||||
: (with-pooled-connection) ( db pool quot -- )
|
||||
[ >r drop db r> with-variable ]
|
||||
[ drop return-connection ]
|
||||
3bi ; inline
|
||||
|
||||
: with-pooled-connection ( pool quot -- )
|
||||
>r [ acquire-connection ] keep r>
|
||||
[ (with-pooled-connection) ] [ ] [ 2drop dispose ] cleanup ; inline
|
||||
|
||||
M: return-connection dispose
|
||||
[ db>> ] [ pool>> ] bi return-connection ;
|
||||
|
||||
: return-connection-later ( db pool -- )
|
||||
\ return-connection boa &dispose drop ;
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
IN: db.pools.tests
|
||||
USING: db.pools tools.test ;
|
||||
|
||||
\ <db-pool> must-infer
|
||||
|
||||
{ 2 0 } [ [ ] with-db-pool ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays namespaces sequences continuations
|
||||
io.pools db ;
|
||||
IN: db.pools
|
||||
|
||||
TUPLE: db-pool < pool db params ;
|
||||
|
||||
: <db-pool> ( db params -- pool )
|
||||
db-pool <pool>
|
||||
swap >>params
|
||||
swap >>db ;
|
||||
|
||||
: with-db-pool ( db params quot -- )
|
||||
>r <db-pool> r> with-pool ; inline
|
||||
|
||||
M: db-pool make-connection ( pool -- )
|
||||
[ db>> ] [ params>> ] bi make-db db-open ;
|
||||
|
||||
: with-pooled-db ( pool quot -- )
|
||||
[ db swap with-variable ] curry with-pooled-connection ; inline
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien alien.c-types kernel math sequences strings
|
||||
USING: unix alien alien.c-types kernel math sequences strings
|
||||
io.unix.backend splitting ;
|
||||
IN: hardware-info.linux
|
||||
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
}
|
||||
] [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: db db.pooling http.server http.server.sessions kernel
|
||||
accessors continuations namespaces destructors ;
|
||||
USING: db db.pools io.pools http.server http.server.sessions
|
||||
kernel accessors continuations namespaces destructors ;
|
||||
IN: http.server.db
|
||||
|
||||
TUPLE: db-persistence < filter-responder pool ;
|
||||
|
||||
: <db-persistence> ( responder db params -- responder' )
|
||||
<pool> db-persistence boa ;
|
||||
<db-pool> db-persistence boa ;
|
||||
|
||||
M: db-persistence call-responder*
|
||||
[
|
||||
|
|
|
|||
|
|
@ -147,7 +147,7 @@ M: process timeout timeout>> ;
|
|||
|
||||
M: process set-timeout set-process-timeout ;
|
||||
|
||||
M: process timed-out kill-process ;
|
||||
M: process cancel-operation kill-process ;
|
||||
|
||||
M: object run-pipeline-element
|
||||
[ >process swap >>stdout swap >>stdin run-detached ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: io io.pipes io.streams.string io.encodings.utf8
|
||||
io.streams.duplex io.encodings io.timeouts namespaces
|
||||
continuations tools.test kernel calendar destructors ;
|
||||
continuations tools.test kernel calendar destructors
|
||||
accessors debugger math ;
|
||||
IN: io.pipes.tests
|
||||
|
||||
[ "Hello" ] [
|
||||
|
|
@ -31,3 +32,13 @@ IN: io.pipes.tests
|
|||
stream-readln
|
||||
] with-disposal
|
||||
] must-fail
|
||||
|
||||
[ ] [
|
||||
1000 [
|
||||
utf8 <pipe> [
|
||||
[ in>> dispose ]
|
||||
[ out>> "hi" over stream-write dispose ]
|
||||
bi
|
||||
] curry ignore-errors
|
||||
] times
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
IN: io.pools
|
||||
USING: help.markup help.syntax destructors quotations ;
|
||||
|
||||
HELP: pool
|
||||
{ $class-description "A connection pool. Instances of this class are not intended to be instantiated directly, only subclasses should be instantiated, for example " { $link datagram-pool } "." } ;
|
||||
|
||||
HELP: <pool>
|
||||
{ $values { "class" "a subclass of " { $link pool } } { "pool" pool } }
|
||||
{ $description "Creates a new connection pool." }
|
||||
{ $notes "To avoid resource leaks, pools must be disposed of by calling " { $link dispose } " when no longer in use." } ;
|
||||
|
||||
HELP: with-pool
|
||||
{ $values { "pool" pool } { "quot" quotation } }
|
||||
{ $description "Calls a quotation in a new dynamic scope with the " { $link pool } " variable set to " { $snippet "pool" } ". The pool is disposed of after the quotation returns, or if an error is thrown." } ;
|
||||
|
||||
HELP: acquire-connection
|
||||
{ $values { "pool" pool } { "conn" "a connection" } }
|
||||
{ $description "Outputs a connection from the pool, preferring to take an existing one, creating a new one with " { $link make-connection } " if the pool is empty." } ;
|
||||
|
||||
HELP: return-connection
|
||||
{ $values { "conn" "a connection" } { "pool" pool } }
|
||||
{ $description "Returns a connection to the pool." } ;
|
||||
|
||||
HELP: with-pooled-connection
|
||||
{ $values { "pool" pool } { "quot" "a quotation with stack effect " { $snippet "( conn -- )" } } }
|
||||
{ $description "Calls a quotation with a pooled connection on the stack. If the quotation returns successfully, the connection is returned to the pool; if the quotation throws an error, the connection is disposed of with " { $link dispose } "." } ;
|
||||
|
||||
HELP: make-connection
|
||||
{ $values { "pool" pool } { "conn" "a connection" } }
|
||||
{ $contract "Makes a connection for the pool." } ;
|
||||
|
||||
HELP: datagram-pool
|
||||
{ $class-description "A pool of datagram sockets bound to the address stored in the " { $snippet "addrspec" } " slot." } ;
|
||||
|
||||
HELP: <datagram-pool>
|
||||
{ $values { "addrspec" "an address specifier" } { "pool" datagram-pool } }
|
||||
{ $description "Creates a new " { $link datagram-pool } ". The port number of the " { $snippet "addrspec" } " should be 0, otherwise creation of more than one datagram socket will raise an error." }
|
||||
{ $examples
|
||||
{ $code "f 0 <inet4> <datagram-pool>" }
|
||||
} ;
|
||||
|
||||
ARTICLE: "io.pools" "Connection pools"
|
||||
"Connection pools are implemented in the " { $snippet "io.pools" } " vocabulary. They are used to reuse sockets and connections which may be potentially expensive to create and destroy."
|
||||
$nl
|
||||
"The class of connection pools:"
|
||||
{ $subsection pool }
|
||||
"Creating connection pools:"
|
||||
{ $subsection <pool> }
|
||||
"A utility combinator:"
|
||||
{ $subsection with-pool }
|
||||
"Acquiring and returning connections, and a utility combinator:"
|
||||
{ $subsection acquire-connection }
|
||||
{ $subsection return-connection }
|
||||
{ $subsection with-pooled-connection }
|
||||
"Pools are not created directly, instead one uses subclasses which implement a generic word:"
|
||||
{ $subsection make-connection }
|
||||
"One example is a datagram socket pool:"
|
||||
{ $subsection datagram-pool }
|
||||
{ $subsection <datagram-pool> } ;
|
||||
|
||||
ABOUT: "io.pools"
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays namespaces sequences continuations
|
||||
destructors io.sockets ;
|
||||
IN: io.pools
|
||||
|
||||
TUPLE: pool connections disposed ;
|
||||
|
||||
: <pool> ( class -- pool )
|
||||
new V{ } clone >>connections ; inline
|
||||
|
||||
M: pool dispose* connections>> dispose-each ;
|
||||
|
||||
: with-pool ( pool quot -- )
|
||||
[ pool swap with-variable ] curry with-disposal ; inline
|
||||
|
||||
TUPLE: return-connection conn pool ;
|
||||
|
||||
: return-connection ( conn pool -- )
|
||||
dup check-disposed connections>> push ;
|
||||
|
||||
GENERIC: make-connection ( pool -- conn )
|
||||
|
||||
: new-connection ( pool -- )
|
||||
[ make-connection ] keep return-connection ;
|
||||
|
||||
: acquire-connection ( pool -- conn )
|
||||
dup check-disposed
|
||||
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
|
||||
connections>> pop ;
|
||||
|
||||
: (with-pooled-connection) ( conn pool quot -- )
|
||||
[ nip call ] [ drop return-connection ] 3bi ; inline
|
||||
|
||||
: with-pooled-connection ( pool quot -- )
|
||||
>r [ acquire-connection ] keep r>
|
||||
[ (with-pooled-connection) ] [ ] [ 2drop dispose ] cleanup ; inline
|
||||
|
||||
M: return-connection dispose
|
||||
[ conn>> ] [ pool>> ] bi return-connection ;
|
||||
|
||||
: return-connection-later ( db pool -- )
|
||||
\ return-connection boa &dispose drop ;
|
||||
|
||||
TUPLE: datagram-pool < pool addrspec ;
|
||||
|
||||
: <datagram-pool> ( addrspec -- pool )
|
||||
datagram-pool <pool> swap >>addrspec ;
|
||||
|
||||
M: datagram-pool make-connection addrspec>> <datagram> ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Abstract connection pooling
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -100,6 +100,10 @@ M: output-port stream-write
|
|||
|
||||
HOOK: (wait-to-write) io-backend ( port -- )
|
||||
|
||||
GENERIC: shutdown ( handle -- )
|
||||
|
||||
M: object shutdown drop ;
|
||||
|
||||
: port-flush ( port -- )
|
||||
dup buffer>> buffer-empty?
|
||||
[ drop ] [ dup (wait-to-write) port-flush ] if ;
|
||||
|
|
@ -108,21 +112,23 @@ M: output-port stream-flush ( port -- )
|
|||
[ check-disposed ] [ port-flush ] bi ;
|
||||
|
||||
M: output-port dispose*
|
||||
[ port-flush ] [ call-next-method ] bi ;
|
||||
[
|
||||
[ handle>> &dispose drop ]
|
||||
[ port-flush ]
|
||||
[ handle>> shutdown ]
|
||||
tri
|
||||
] with-destructors ;
|
||||
|
||||
M: buffered-port dispose*
|
||||
[ call-next-method ]
|
||||
[ [ [ buffer-free ] when* f ] change-buffer drop ]
|
||||
bi ;
|
||||
|
||||
HOOK: cancel-io io-backend ( port -- )
|
||||
M: port cancel-operation handle>> cancel-operation ;
|
||||
|
||||
M: port timed-out cancel-io ;
|
||||
|
||||
M: port dispose* [ cancel-io ] [ handle>> dispose ] bi ;
|
||||
|
||||
: <ports> ( read-handle write-handle -- input-port output-port )
|
||||
M: port dispose*
|
||||
[
|
||||
[ <input-port> |dispose ]
|
||||
[ <output-port> |dispose ] bi*
|
||||
[ handle>> &dispose drop ]
|
||||
[ handle>> shutdown ]
|
||||
bi
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,125 @@
|
|||
IN: io.sockets.secure
|
||||
USING: help.markup help.syntax calendar quotations io.sockets ;
|
||||
|
||||
HELP: secure-socket-timeout
|
||||
{ $var-description "Timeout for operations not associated with a constructed port instance, such as SSL handshake and shutdown. Represented as a " { $link duration } "." } ;
|
||||
|
||||
HELP: SSLv2
|
||||
{ $description "Possible value for the " { $snippet "method" } " slot of a " { $link secure-config } "."
|
||||
$nl
|
||||
"Note that the SSLv2 protocol is vulnerable to truncation attacks and its use is discouraged (" { $url "http://www.gnu.org/software/gnutls/manual/html_node/On-SSL-2-and-older-protocols.html" } ")." } ;
|
||||
|
||||
HELP: SSLv3
|
||||
{ $description "Possible value for the " { $snippet "method" } " slot of a " { $link secure-config } "."
|
||||
$nl
|
||||
"SSLv3 is widely used, however it is being supersceded by TLSv1." } ;
|
||||
|
||||
HELP: SSLv23
|
||||
{ $description "Possible value for the " { $snippet "method" } " slot of a " { $link secure-config } "."
|
||||
$nl
|
||||
"This value indicates that either SSLv2 or SSLv3 is acceptable." } ;
|
||||
|
||||
HELP: TLSv1
|
||||
{ $description "Possible value for the " { $snippet "method" } " slot of a " { $link secure-config } "."
|
||||
$nl
|
||||
"TLSv1 is the newest protocol for secure socket communications." } ;
|
||||
|
||||
ARTICLE: "ssl-methods" "SSL/TLS methods"
|
||||
"The " { $snippet "method" } " slot of a " { $link secure-config } " can be set to one of the following values:"
|
||||
{ $subsection SSLv2 }
|
||||
{ $subsection SSLv23 }
|
||||
{ $subsection SSLv3 }
|
||||
{ $subsection TLSv1 }
|
||||
"The default value is " { $link SSLv23 } "." ;
|
||||
|
||||
HELP: secure-config
|
||||
{ $class-description "Instances represent secure socket configurations." } ;
|
||||
|
||||
HELP: <secure-config>
|
||||
{ $values { "config" secure-config } }
|
||||
{ $description "Creates a new secure socket configration with default values." } ;
|
||||
|
||||
ARTICLE: "ssl-key-file" "The key file and password"
|
||||
"The " { $snippet "key-file" } " and " { $snippet "password" } " slots of a " { $link secure-config } " can be set to a private key file in PEM format. These slots are required for secure servers, and also for clients when client-side authentication is used." ;
|
||||
|
||||
ARTICLE: "ssl-ca-file" "The CA file and path"
|
||||
"The " { $snippet "ca-file" } " slot of a " { $link secure-config } " can contain the path of a file with a list of trusted certificates in PEM format. The " { $snippet "ca-path" } " slot can contain the path of a directory of trusted certifications."
|
||||
$nl
|
||||
"One of these slots are required to be specified so that secure client sockets can verify server certificates."
|
||||
$nl
|
||||
"See " { $url "http://www.openssl.org/docs/ssl/SSL_CTX_load_verify_locations.html" } " for details." ;
|
||||
|
||||
ARTICLE: "ssl-dh-file" "Diffie-Hellman parameter file"
|
||||
"The " { $snippet "dh-file" } " slot of a " { $link secure-config } " can contain the path of a file with Diffie-Hellman key exchange parameters."
|
||||
$nl
|
||||
"This slot is required for secure server sockets." ;
|
||||
|
||||
ARTICLE: "ssl-ephemeral-rsa" "Ephemeral RSA key bits"
|
||||
"The " { $snippet "ephemeral-key-bits" } " slot of a " { $link secure-config } " contains the length of the empheral RSA key, in bits."
|
||||
$nl
|
||||
"The default value is 1024, and anything less than that is considered insecure. This slot is required for secure server sockets." ;
|
||||
|
||||
ARTICLE: "ssl-config" "Secure socket configuration"
|
||||
"Secure sockets require some configuration, particularly for server sockets. A class represents secure socket configuration parameters:"
|
||||
{ $subsection secure-config }
|
||||
"Creating new instances:"
|
||||
{ $subsection <secure-config> }
|
||||
"Configuration parameters:"
|
||||
{ $subsection "ssl-methods" }
|
||||
{ $subsection "ssl-key-file" }
|
||||
{ $subsection "ssl-ca-file" }
|
||||
{ $subsection "ssl-dh-file" }
|
||||
{ $subsection "ssl-ephemeral-rsa" } ;
|
||||
|
||||
HELP: <secure-context>
|
||||
{ $values { "config" secure-config } { "context" secure-context } }
|
||||
{ $description "Creates a new " { $link secure-context } ". This word should not usually be called directly, use " { $link with-secure-context } " instead." } ;
|
||||
|
||||
HELP: with-secure-context
|
||||
{ $values { "config" secure-config } { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new dynamic scope where a " { $link secure-context } " constructed from the specified configuration is available." } ;
|
||||
|
||||
ARTICLE: "ssl-contexts" "Secure socket contexts"
|
||||
"All secure socket operations must be performed in a secure socket context. A context is created from a secure socket configuration. An implicit context with the default configuration is always available, however server sockets require a certificate to be set together with other parameters, and the default configuration is insufficient, so a context must be explicitly created in that case."
|
||||
{ $subsection with-secure-context } ;
|
||||
|
||||
HELP: secure
|
||||
{ $class-description "The class of secure socket addresses." } ;
|
||||
|
||||
HELP: <secure> ( addrspec -- secure )
|
||||
{ $values { "addrspec" "an address specifier" } { "secure" secure } }
|
||||
{ $description "Creates a new secure socket address, which can then be passed to " { $link <client> } " or " { $link <server> } "." } ;
|
||||
|
||||
ARTICLE: "ssl-addresses" "Secure socket addresses"
|
||||
"Secure socket connections are established by passing a secure socket address to " { $link <client> } " or " { $link <server> } "."
|
||||
$nl
|
||||
"Secure socket addresses form a class:"
|
||||
{ $subsection secure }
|
||||
"Constructing secure socket addresses:"
|
||||
{ $subsection <secure> }
|
||||
"Instances of this class can wrap an " { $link inet } ", " { $link inet4 } " or an " { $link inet6 } ", although note that certificate validation is only performed for instances of " { $link inet } " since otherwise the host name is not available." ;
|
||||
|
||||
HELP: premature-close
|
||||
{ $error-description "Thrown if an SSL connection is closed without the proper " { $snippet "close_notify" } " sequence. This error is never reported for " { $link SSLv2 } " connections because there is no distinction between expected and unexpected connection closure in that case." } ;
|
||||
|
||||
HELP: certificate-verify-error
|
||||
{ $error-description "Thrown if certificate verification failed. The " { $snippet "result" } " slot contains an object identifying the low-level error that occurred." } ;
|
||||
|
||||
HELP: common-name-verify-error
|
||||
{ $error-description "Thrown during certificate verification if the host name on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $snippet "expected" } " and " { $snippet "got" } " slots contain the mismatched host names." } ;
|
||||
|
||||
ARTICLE: "ssl-errors" "Secure socket errors"
|
||||
"Secure sockets can throw one of several errors in addition to the usual I/O errors:"
|
||||
{ $subsection premature-close }
|
||||
{ $subsection certificate-verify-error }
|
||||
{ $subsection common-name-verify-error } ;
|
||||
|
||||
ARTICLE: "io.sockets.secure" "Secure sockets (SSL, TLS)"
|
||||
"The " { $vocab-link "io.sockets.secure" } " vocabulary implements secure, encrypted sockets using the OpenSSL library."
|
||||
{ $subsection "ssl-config" }
|
||||
{ $subsection "ssl-contexts" }
|
||||
{ $subsection "ssl-addresses" }
|
||||
{ $subsection "ssl-errors" }
|
||||
"This product includes software developed by the OpenSSL Project for use in the OpenSSL Toolkit (" { $url "http://www.openssl.org/" } "), cryptographic software written by Eric Young (eay@cryptsoft.com) and software written by Tim Hudson (tjh@cryptsoft.com)." ;
|
||||
|
||||
ABOUT: "io.sockets.secure"
|
||||
|
|
@ -1,9 +1,13 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel symbols namespaces continuations
|
||||
destructors io.sockets sequences inspector ;
|
||||
destructors io.sockets sequences inspector calendar ;
|
||||
IN: io.sockets.secure
|
||||
|
||||
SYMBOL: secure-socket-timeout
|
||||
|
||||
1 minutes secure-socket-timeout set-global
|
||||
|
||||
SYMBOL: secure-socket-backend
|
||||
|
||||
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
|
||||
|
|
@ -11,6 +15,8 @@ SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
|
|||
TUPLE: secure-config
|
||||
method
|
||||
key-file password
|
||||
verify
|
||||
verify-depth
|
||||
ca-file ca-path
|
||||
dh-file
|
||||
ephemeral-key-bits ;
|
||||
|
|
@ -18,7 +24,9 @@ ephemeral-key-bits ;
|
|||
: <secure-config> ( -- config )
|
||||
secure-config new
|
||||
SSLv23 >>method
|
||||
512 >>ephemeral-key-bits ;
|
||||
1024 >>ephemeral-key-bits
|
||||
"resource:extra/openssl/cacert.pem" >>ca-file
|
||||
t >>verify ;
|
||||
|
||||
TUPLE: secure-context config handle disposed ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Secure sockets (SSL, TLS)
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -27,7 +27,8 @@ $nl
|
|||
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
|
||||
{ { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" }
|
||||
}
|
||||
"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface." ;
|
||||
"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
|
||||
{ $see-also "io.sockets.secure" } ;
|
||||
|
||||
ARTICLE: "network-packet" "Packet-oriented networking"
|
||||
"A packet-oriented socket can be opened with this word:"
|
||||
|
|
@ -49,11 +50,13 @@ ARTICLE: "network-streams" "Networking"
|
|||
"Factor supports connection-oriented and packet-oriented communication over a variety of protocols:"
|
||||
{ $list
|
||||
"TCP/IP and UDP/IP, over IPv4 and IPv6"
|
||||
"Unix domain sockets"
|
||||
"Unix domain sockets (Unix only)"
|
||||
}
|
||||
{ $subsection "network-addressing" }
|
||||
{ $subsection "network-connection" }
|
||||
{ $subsection "network-packet" } ;
|
||||
{ $subsection "network-packet" }
|
||||
{ $subsection "io.sockets.secure" }
|
||||
{ $see-also "io.pipes" } ;
|
||||
|
||||
ABOUT: "network-streams"
|
||||
|
||||
|
|
|
|||
|
|
@ -161,6 +161,11 @@ GENERIC: (get-remote-address) ( handle remote -- sockaddr )
|
|||
: get-remote-address ( handle local -- remote )
|
||||
[ (get-remote-address) ] keep parse-sockaddr ;
|
||||
|
||||
: <ports> ( handle -- input-port output-port )
|
||||
[
|
||||
[ <input-port> |dispose ] [ <output-port> |dispose ] bi
|
||||
] with-destructors ;
|
||||
|
||||
GENERIC: establish-connection ( client-out remote -- )
|
||||
|
||||
GENERIC: ((client)) ( remote -- handle )
|
||||
|
|
@ -173,7 +178,7 @@ M: object (client) ( remote -- client-in client-out local )
|
|||
[
|
||||
[ ((client)) ] keep
|
||||
[
|
||||
>r dup <ports> [ |dispose ] bi@ dup r>
|
||||
>r <ports> [ |dispose ] bi@ dup r>
|
||||
establish-connection
|
||||
]
|
||||
[ get-local-address ]
|
||||
|
|
@ -210,7 +215,7 @@ GENERIC: (accept) ( server addrspec -- handle sockaddr )
|
|||
dup addr>>
|
||||
[ (accept) ] keep
|
||||
parse-sockaddr swap
|
||||
dup <ports>
|
||||
<ports>
|
||||
] keep encoding>> <encoder-duplex> swap ;
|
||||
|
||||
TUPLE: datagram-port < port addr ;
|
||||
|
|
|
|||
|
|
@ -9,20 +9,20 @@ HELP: set-timeout
|
|||
{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } }
|
||||
{ $contract "Sets an object's timeout." } ;
|
||||
|
||||
HELP: timed-out
|
||||
HELP: cancel-operation
|
||||
{ $values { "obj" object } }
|
||||
{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
|
||||
|
||||
HELP: with-timeout
|
||||
{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
|
||||
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
|
||||
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ;
|
||||
|
||||
ARTICLE: "io.timeouts" "I/O timeout protocol"
|
||||
"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
|
||||
{ $subsection timeout }
|
||||
{ $subsection set-timeout }
|
||||
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
|
||||
{ $subsection timed-out }
|
||||
{ $subsection cancel-operation }
|
||||
"A combinator to be used in operations which can time out:"
|
||||
{ $subsection with-timeout }
|
||||
{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;
|
||||
|
|
|
|||
|
|
@ -11,17 +11,18 @@ M: decoder set-timeout stream>> set-timeout ;
|
|||
|
||||
M: encoder set-timeout stream>> set-timeout ;
|
||||
|
||||
GENERIC: timed-out ( obj -- )
|
||||
GENERIC: cancel-operation ( obj -- )
|
||||
|
||||
: queue-timeout ( obj timeout -- alarm )
|
||||
>r [ timed-out ] curry r> later ;
|
||||
>r [ cancel-operation ] curry r> later ;
|
||||
|
||||
: with-timeout* ( obj timeout quot -- )
|
||||
3dup drop queue-timeout >r nip call r> cancel-alarm ;
|
||||
inline
|
||||
|
||||
: with-timeout ( obj quot -- )
|
||||
over dup timeout dup [
|
||||
queue-timeout slip cancel-alarm
|
||||
] [
|
||||
2drop call
|
||||
] if ; inline
|
||||
over timeout [ >r dup timeout r> with-timeout* ] [ call ] if ;
|
||||
inline
|
||||
|
||||
: timeouts ( dt -- )
|
||||
[ input-stream get set-timeout ]
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ io.encodings.utf8 destructors accessors inspector combinators ;
|
|||
QUALIFIED: io
|
||||
IN: io.unix.backend
|
||||
|
||||
! I/O tasks
|
||||
GENERIC: handle-fd ( handle -- fd )
|
||||
|
||||
TUPLE: fd fd disposed ;
|
||||
|
|
@ -18,14 +17,22 @@ TUPLE: fd fd disposed ;
|
|||
#! since on OS X 10.3, this operation fails from init-io
|
||||
#! when running the Factor.app (presumably because fd 0 and
|
||||
#! 1 are closed).
|
||||
[ F_SETFL O_NONBLOCK fcntl drop ]
|
||||
[ F_SETFD FD_CLOEXEC fcntl drop ]
|
||||
[ f fd boa ]
|
||||
tri ;
|
||||
fd new
|
||||
swap
|
||||
[ F_SETFL O_NONBLOCK fcntl drop ]
|
||||
[ F_SETFD FD_CLOEXEC fcntl drop ]
|
||||
[ >>fd ]
|
||||
tri ;
|
||||
|
||||
M: fd dispose* fd>> close-file ;
|
||||
M: fd dispose
|
||||
dup disposed>> [ drop ] [
|
||||
[ cancel-operation ]
|
||||
[ t >>disposed drop ]
|
||||
[ fd>> close-file ]
|
||||
tri
|
||||
] if ;
|
||||
|
||||
M: fd handle-fd fd>> ;
|
||||
M: fd handle-fd dup check-disposed fd>> ;
|
||||
|
||||
! I/O multiplexers
|
||||
TUPLE: mx fd reads writes ;
|
||||
|
|
@ -62,18 +69,25 @@ 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-operation ( 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+
|
||||
SYMBOL: +output+
|
||||
|
||||
: wait-for-fd ( handle event -- timeout? )
|
||||
dup +retry+ eq? [ 2drop f ] [
|
||||
ERROR: io-timeout ;
|
||||
|
||||
M: io-timeout summary drop "I/O operation timed out" ;
|
||||
|
||||
: wait-for-fd ( handle event -- )
|
||||
dup +retry+ eq? [ 2drop ] [
|
||||
[
|
||||
>r
|
||||
swap handle-fd
|
||||
|
|
@ -82,30 +96,14 @@ SYMBOL: +output+
|
|||
{ +input+ [ add-input-callback ] }
|
||||
{ +output+ [ add-output-callback ] }
|
||||
} case
|
||||
] curry "I/O" suspend nip
|
||||
] curry "I/O" suspend nip [ io-timeout ] when
|
||||
] if ;
|
||||
|
||||
ERROR: io-timeout ;
|
||||
|
||||
M: io-timeout summary drop "I/O operation timed out" ;
|
||||
|
||||
: wait-for-port ( port event -- )
|
||||
[
|
||||
>r handle>> r> wait-for-fd
|
||||
[ io-timeout ] when
|
||||
] curry with-timeout ;
|
||||
[ >r handle>> r> wait-for-fd ] curry with-timeout ;
|
||||
|
||||
! Some general stuff
|
||||
: file-mode OCT: 0666 ;
|
||||
|
||||
: (io-error) ( -- * ) err_no strerror throw ;
|
||||
|
||||
: check-errno ( -- )
|
||||
err_no dup zero? [ drop ] [ strerror throw ] if ;
|
||||
|
||||
: check-null ( n -- ) zero? [ (io-error) ] when ;
|
||||
|
||||
: io-error ( n -- ) 0 < [ (io-error) ] when ;
|
||||
|
||||
! Readers
|
||||
: (refill) ( port -- n )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.files io.buffers io.monitors io.ports io.timeouts
|
|||
io.unix.backend io.unix.select io.encodings.utf8
|
||||
unix.linux.inotify assocs namespaces threads continuations init
|
||||
math math.bitfields sets alien alien.strings alien.c-types
|
||||
vocabs.loader accessors system hashtables destructors ;
|
||||
vocabs.loader accessors system hashtables destructors unix ;
|
||||
IN: io.unix.linux.monitors
|
||||
|
||||
SYMBOL: watches
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
IN: io.sockets.secure.tests
|
||||
USING: accessors kernel namespaces io io.sockets
|
||||
io.sockets.secure io.encodings.ascii io.streams.duplex
|
||||
classes words destructors threads tools.test
|
||||
concurrency.promises byte-arrays locals ;
|
||||
io.unix.backend classes words destructors threads tools.test
|
||||
concurrency.promises byte-arrays locals calendar io.timeouts ;
|
||||
|
||||
\ <secure-config> must-infer
|
||||
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
|
||||
|
|
@ -12,7 +12,6 @@ concurrency.promises byte-arrays locals ;
|
|||
: with-test-context
|
||||
<secure-config>
|
||||
"resource:extra/openssl/test/server.pem" >>key-file
|
||||
"resource:extra/openssl/test/root.pem" >>ca-file
|
||||
"resource:extra/openssl/test/dh1024.pem" >>dh-file
|
||||
"password" >>password
|
||||
swap with-secure-context ;
|
||||
|
|
@ -44,8 +43,8 @@ concurrency.promises byte-arrays locals ;
|
|||
[ ] [
|
||||
[
|
||||
drop
|
||||
input-stream get stream>> handle>> f >>connected drop
|
||||
"hello" write flush
|
||||
input-stream get stream>> handle>> f >>connected drop
|
||||
] server-test
|
||||
] unit-test
|
||||
|
||||
|
|
@ -55,7 +54,7 @@ concurrency.promises byte-arrays locals ;
|
|||
! actually an invalid certificate
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [ [ drop ] server-test ] unit-test
|
||||
[ ] [ [ drop "hi" write ] server-test ] unit-test
|
||||
|
||||
[
|
||||
<secure-config> [
|
||||
|
|
@ -63,3 +62,92 @@ concurrency.promises byte-arrays locals ;
|
|||
<client> drop dispose
|
||||
] with-secure-context
|
||||
] [ certificate-verify-error? ] must-fail-with
|
||||
|
||||
! Client-side handshake timeout
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> ascii <server> [
|
||||
dup addr>> port>> "port" get fulfill
|
||||
accept drop 1 minutes sleep dispose
|
||||
] with-disposal
|
||||
] "Silly server" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
client-test
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
|
||||
! Server-side handshake timeout
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"127.0.0.1" "port" get ?promise
|
||||
<inet4> ascii <client> drop 1 minutes sleep dispose
|
||||
] "Silly client" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop dup stream-read1 drop dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
|
||||
! Client socket shutdown timeout
|
||||
|
||||
! Until I sort out two-stage handshaking, I can't do much here
|
||||
[
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop 1 minutes sleep dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] "Silly server" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
<secure-config> [
|
||||
"127.0.0.1" "port" get ?promise <inet4> <secure>
|
||||
ascii <client> drop dispose
|
||||
] with-secure-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
|
||||
! Server socket shutdown timeout
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
[
|
||||
"127.0.0.1" "port" get ?promise
|
||||
<inet4> <secure> ascii <client> drop 1 minutes sleep dispose
|
||||
] with-test-context
|
||||
] "Silly client" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
] drop
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays kernel debugger sequences namespaces math
|
||||
USING: accessors unix byte-arrays kernel debugger sequences namespaces math
|
||||
math.order combinators init alien alien.c-types alien.strings libc
|
||||
continuations destructors
|
||||
openssl openssl.libcrypto openssl.libssl
|
||||
io.files io.ports io.unix.backend io.unix.sockets
|
||||
io.encodings.ascii io.buffers io.sockets io.sockets.secure
|
||||
unix system inspector ;
|
||||
io.timeouts system inspector ;
|
||||
IN: io.unix.sockets.secure
|
||||
|
||||
M: ssl-handle handle-fd file>> handle-fd ;
|
||||
|
|
@ -15,13 +15,33 @@ M: ssl-handle handle-fd file>> handle-fd ;
|
|||
ERR_get_error dup zero? [
|
||||
drop
|
||||
{
|
||||
{ -1 [ (io-error) ] }
|
||||
{ -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
|
||||
{ 0 [ premature-close ] }
|
||||
} case
|
||||
] [
|
||||
nip (ssl-error)
|
||||
] if ;
|
||||
|
||||
: check-accept-response ( handle r -- event )
|
||||
over handle>> over SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
: do-ssl-accept ( ssl-handle -- )
|
||||
dup dup handle>> SSL_accept check-accept-response dup
|
||||
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
|
||||
|
||||
: maybe-handshake ( ssl-handle -- )
|
||||
dup connected>> [ drop ] [
|
||||
t >>connected
|
||||
[ do-ssl-accept ] with-timeout
|
||||
] if ;
|
||||
|
||||
: check-response ( port r -- port r n )
|
||||
over handle>> handle>> over SSL_get_error ; inline
|
||||
|
||||
|
|
@ -38,6 +58,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
|
|||
} case ;
|
||||
|
||||
M: ssl-handle refill
|
||||
dup maybe-handshake
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer-end ] ! buf
|
||||
|
|
@ -57,6 +78,7 @@ M: ssl-handle refill
|
|||
} case ;
|
||||
|
||||
M: ssl-handle drain
|
||||
dup maybe-handshake
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer@ ] ! buf
|
||||
|
|
@ -64,6 +86,12 @@ M: ssl-handle drain
|
|||
SSL_write
|
||||
check-write-response ;
|
||||
|
||||
M: ssl-handle cancel-operation
|
||||
file>> cancel-operation ;
|
||||
|
||||
M: ssl-handle timeout
|
||||
drop secure-socket-timeout get ;
|
||||
|
||||
! Client sockets
|
||||
: <ssl-socket> ( fd -- ssl )
|
||||
[ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
|
||||
|
|
@ -76,30 +104,7 @@ M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
|
|||
|
||||
M: secure (get-local-address) addrspec>> (get-local-address) ;
|
||||
|
||||
: check-connect-response ( port r -- event )
|
||||
check-response
|
||||
{
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
: do-ssl-connect ( port -- )
|
||||
dup dup handle>> handle>> SSL_connect
|
||||
check-connect-response dup
|
||||
[ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ;
|
||||
|
||||
M: secure establish-connection ( client-out remote -- )
|
||||
[ addrspec>> establish-connection ]
|
||||
[ drop do-ssl-connect ]
|
||||
[ drop handle>> t >>connected drop ]
|
||||
2tri ;
|
||||
|
||||
M: secure (server) addrspec>> (server) ;
|
||||
|
||||
: check-accept-response ( handle r -- event )
|
||||
: check-connect-response ( ssl-handle r -- event )
|
||||
over handle>> over SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
|
|
@ -109,44 +114,45 @@ M: secure (server) addrspec>> (server) ;
|
|||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
: do-ssl-accept ( ssl-handle -- )
|
||||
dup dup handle>> SSL_accept check-accept-response dup
|
||||
[ >r dup file>> r> wait-for-fd drop do-ssl-accept ] [ 2drop ] if ;
|
||||
: do-ssl-connect ( ssl-handle -- )
|
||||
dup dup handle>> SSL_connect check-connect-response dup
|
||||
[ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
|
||||
|
||||
M: secure establish-connection ( client-out remote -- )
|
||||
[ addrspec>> establish-connection ]
|
||||
[
|
||||
drop handle>>
|
||||
[ [ do-ssl-connect ] with-timeout ]
|
||||
[ t >>connected drop ]
|
||||
bi
|
||||
] 2bi ;
|
||||
|
||||
M: secure (server) addrspec>> (server) ;
|
||||
|
||||
M: secure (accept)
|
||||
[
|
||||
addrspec>> (accept) >r
|
||||
|dispose <ssl-socket> t >>connected |dispose
|
||||
dup do-ssl-accept r>
|
||||
addrspec>> (accept) >r |dispose <ssl-socket> r>
|
||||
] with-destructors ;
|
||||
|
||||
: check-shutdown-response ( handle r -- event )
|
||||
#! SSL_shutdown always returns 0 due to openssl bugs?
|
||||
#! We don't do two-step shutdown here because I couldn't
|
||||
#! figure out how to do it with non-blocking BIOs. Also, it
|
||||
#! seems that SSL_shutdown always returns 0 -- this sounds
|
||||
#! like a bug
|
||||
over handle>> over SSL_get_error
|
||||
{
|
||||
{ 1 [ drop f ] }
|
||||
{ 0 [
|
||||
dup handle>> dup f 0 SSL_read 2dup SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_ZERO_RETURN [ 2drop dup handle>> SSL_shutdown check-shutdown-response ] }
|
||||
{ SSL_ERROR_WANT_READ [ 3drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 3drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case
|
||||
] }
|
||||
{ -1 [
|
||||
handle>> -1 SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_WANT_READ [ +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ -1 syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case
|
||||
] }
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
M: unix ssl-shutdown
|
||||
: (shutdown) ( handle -- )
|
||||
dup dup handle>> SSL_shutdown check-shutdown-response
|
||||
dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
|
||||
|
||||
M: ssl-handle shutdown
|
||||
dup connected>> [
|
||||
dup dup handle>> SSL_shutdown check-shutdown-response
|
||||
dup [ dupd wait-for-fd drop ssl-shutdown ] [ 2drop ] if
|
||||
f >>connected [ (shutdown) ] with-timeout
|
||||
] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -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-operation
|
||||
handle>> CancelIo drop ;
|
||||
|
||||
M: winnt io-multiplex ( ms -- )
|
||||
handle-overlapped [ 0 io-multiplex ] when ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays destructors io io.backend
|
||||
io.buffers io.files io.ports io.sockets io.binary
|
||||
io.sockets windows.errors strings
|
||||
io.sockets io.timeouts windows.errors strings
|
||||
kernel math namespaces sequences windows windows.kernel32
|
||||
windows.shell32 windows.types windows.winsock splitting
|
||||
continuations math.bitfields system accessors ;
|
||||
|
|
@ -24,6 +24,11 @@ TUPLE: win32-file < win32-handle ptr ;
|
|||
: <win32-file> ( handle -- win32-file )
|
||||
win32-file new-win32-handle ;
|
||||
|
||||
M: win32-file dispose
|
||||
dup disposed>> [ drop ] [
|
||||
[ cancel-operation ] [ call-next-method ] bi
|
||||
] if ;
|
||||
|
||||
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
|
||||
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
|
||||
HOOK: add-completion io-backend ( port -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,15 @@
|
|||
IN: lisp
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
ARTICLE: "lisp" "Lisp in Factor"
|
||||
"This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl
|
||||
"It works in two main stages: "
|
||||
{ $list
|
||||
{ "Parse (via " { $vocab-link "lisp.parser" } " the Lisp code into a "
|
||||
{ $snippet "s-exp" } " tuple." }
|
||||
{ "Transform the " { $snippet "s-exp" } " into a Factor quotation, via " { $link convert-form } }
|
||||
}
|
||||
|
||||
{ $subsection "lisp.parser" } ;
|
||||
|
||||
ABOUT: "lisp"
|
||||
|
|
@ -4,16 +4,44 @@ USING: lisp lisp.parser tools.test sequences math kernel parser ;
|
|||
|
||||
IN: lisp.test
|
||||
|
||||
init-env
|
||||
|
||||
"+" [ first2 + ] lisp-define
|
||||
|
||||
{ [ first2 + ] } [
|
||||
"+" lisp-get
|
||||
] unit-test
|
||||
|
||||
{ 3 } [
|
||||
[
|
||||
"((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
|
||||
] with-interactive-vocabs
|
||||
] unit-test
|
||||
[
|
||||
init-env
|
||||
|
||||
"#f" [ f ] lisp-define
|
||||
"#t" [ t ] lisp-define
|
||||
|
||||
"+" "math" "+" define-primitve
|
||||
"-" "math" "-" define-primitve
|
||||
|
||||
{ 5 } [
|
||||
[ 2 3 ] "+" <lisp-symbol> funcall
|
||||
] unit-test
|
||||
|
||||
{ 8.3 } [
|
||||
[ 10.4 2.1 ] "-" <lisp-symbol> funcall
|
||||
] unit-test
|
||||
|
||||
{ 3 } [
|
||||
"((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
|
||||
] unit-test
|
||||
|
||||
{ 42 } [
|
||||
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call
|
||||
] unit-test
|
||||
|
||||
{ 1 } [
|
||||
"(if #t 1 2)" lisp-string>factor call
|
||||
] unit-test
|
||||
|
||||
{ "b" } [
|
||||
"(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call
|
||||
] unit-test
|
||||
|
||||
{ 5 } [
|
||||
"(begin (+ 1 4))" lisp-string>factor call
|
||||
] unit-test
|
||||
|
||||
{ 3 } [
|
||||
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call
|
||||
] unit-test
|
||||
] with-interactive-vocabs
|
||||
|
|
@ -2,11 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel peg sequences arrays strings combinators.lib
|
||||
namespaces combinators math bake locals locals.private accessors
|
||||
vectors syntax lisp.parser assocs parser sequences.lib ;
|
||||
vectors syntax lisp.parser assocs parser sequences.lib words quotations ;
|
||||
IN: lisp
|
||||
|
||||
DEFER: convert-form
|
||||
DEFER: funcall
|
||||
DEFER: lookup-var
|
||||
|
||||
! Functions to convert s-exps to quotations
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -17,14 +18,16 @@ DEFER: funcall
|
|||
rest [ convert-form ] map reverse first3 [ % , , if ] bake ;
|
||||
|
||||
: convert-begin ( s-exp -- quot )
|
||||
rest convert-form ;
|
||||
rest [ convert-form ] map >quotation [ , [ funcall ] each ] bake ;
|
||||
|
||||
: convert-cond ( s-exp -- quot )
|
||||
rest [ [ convert-form map ] map ] [ % cond ] bake ;
|
||||
rest [ body>> >array [ convert-form ] map first2 swap `{ [ % funcall ] , } bake ]
|
||||
map >array [ , cond ] bake ;
|
||||
|
||||
: convert-general-form ( s-exp -- quot )
|
||||
unclip convert-form swap convert-body [ , % funcall ] bake ;
|
||||
|
||||
|
||||
! words for convert-lambda
|
||||
<PRIVATE
|
||||
: localize-body ( assoc body -- assoc newbody )
|
||||
[ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
|
||||
|
|
@ -34,8 +37,6 @@ DEFER: funcall
|
|||
: localize-lambda ( body vars -- newbody newvars )
|
||||
make-locals dup push-locals swap
|
||||
[ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: split-lambda ( s-exp -- body vars )
|
||||
first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
|
||||
|
|
@ -47,6 +48,7 @@ PRIVATE>
|
|||
|
||||
: normal-lambda ( body vars -- quot )
|
||||
localize-lambda <lambda> [ , compose ] bake ;
|
||||
PRIVATE>
|
||||
|
||||
: convert-lambda ( s-exp -- quot )
|
||||
split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ;
|
||||
|
|
@ -67,8 +69,10 @@ PRIVATE>
|
|||
[ drop convert-general-form ] if ;
|
||||
|
||||
: convert-form ( lisp-form -- quot )
|
||||
dup s-exp? [ body>> convert-list-form ]
|
||||
[ [ , ] [ ] make ] if ;
|
||||
{ { [ dup s-exp? ] [ body>> convert-list-form ] }
|
||||
{ [ dup lisp-symbol? ] [ [ , lookup-var ] bake ] }
|
||||
[ [ , ] bake ]
|
||||
} cond ;
|
||||
|
||||
: lisp-string>factor ( str -- quot )
|
||||
lisp-expr parse-result-ast convert-form lambda-rewrite call ;
|
||||
|
|
@ -85,7 +89,13 @@ ERROR: no-such-var var ;
|
|||
swap lisp-env get set-at ;
|
||||
|
||||
: lisp-get ( name -- word )
|
||||
dup lisp-env get at [ ] [ no-such-var ] ?if ;
|
||||
dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
|
||||
|
||||
: lookup-var ( lisp-symbol -- quot )
|
||||
name>> lisp-get ;
|
||||
|
||||
: funcall ( quot sym -- * )
|
||||
dup lisp-symbol? [ name>> lisp-get ] when call ; inline
|
||||
dup lisp-symbol? [ lookup-var ] when call ; inline
|
||||
|
||||
: define-primitve ( name vocab word -- )
|
||||
swap lookup [ [ , ] compose call ] bake lisp-define ;
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
IN: lisp.parser
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
ARTICLE: "lisp.parser" "Parsing strings of Lisp"
|
||||
"This vocab uses " { $vocab-link "peg.ebnf" } " to turn strings of Lisp into " { $snippet "s-exp" } "s, which are then used by"
|
||||
{ $vocab-link "lisp" } " to produce Factor quotations." ;
|
||||
|
|
@ -24,7 +24,7 @@ rational = integer "/" (digit)+ => [[ first3 nip string
|
|||
number = float
|
||||
| rational
|
||||
| integer
|
||||
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
|
||||
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
|
||||
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
|
||||
letters = [a-zA-Z] => [[ 1array >string ]]
|
||||
initials = letters | id-specials
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
A Lisp interpreter in Factor
|
||||
A Lisp interpreter/compiler in Factor
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -10,11 +10,12 @@ USING: alien alien.syntax combinators kernel system ;
|
|||
IN: openssl.libcrypto
|
||||
|
||||
<<
|
||||
"libcrypto" {
|
||||
{ [ os winnt? ] [ "libeay32.dll" "cdecl" ] }
|
||||
{ [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] }
|
||||
{ [ os unix? ] [ "libcrypto.so" "cdecl" ] }
|
||||
} cond add-library
|
||||
{
|
||||
{ [ os openbsd? ] [ ] } ! VM is linked with it
|
||||
{ [ os winnt? ] [ "libcrypto" "libeay32.dll" "cdecl" add-library ] }
|
||||
{ [ os macosx? ] [ "libcrypto" "libcrypto.dylib" "cdecl" add-library ] }
|
||||
{ [ os unix? ] [ "libcrypto" "libcrypto.so" "cdecl" add-library ] }
|
||||
} cond
|
||||
>>
|
||||
|
||||
C-STRUCT: bio-method
|
||||
|
|
|
|||
|
|
@ -10,11 +10,12 @@ assocs parser sequences words quotations ;
|
|||
|
||||
IN: openssl.libssl
|
||||
|
||||
<< "libssl" {
|
||||
{ [ os winnt? ] [ "ssleay32.dll" "cdecl" ] }
|
||||
{ [ os macosx? ] [ "libssl.dylib" "cdecl" ] }
|
||||
{ [ os unix? ] [ "libssl.so" "cdecl" ] }
|
||||
} cond add-library >>
|
||||
<< {
|
||||
{ [ os openbsd? ] [ ] } ! VM is linked with it
|
||||
{ [ os winnt? ] [ "libssl" "ssleay32.dll" "cdecl" add-library ] }
|
||||
{ [ os macosx? ] [ "libssl" "libssl.dylib" "cdecl" add-library ] }
|
||||
{ [ os unix? ] [ "libssl" "libssl.so" "cdecl" add-library ] }
|
||||
} cond >>
|
||||
|
||||
: X509_FILETYPE_PEM 1 ; inline
|
||||
: X509_FILETYPE_ASN1 2 ; inline
|
||||
|
|
@ -121,6 +122,11 @@ FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
|
|||
|
||||
FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
|
||||
|
||||
: SSL_SENT_SHUTDOWN 1 ;
|
||||
: SSL_RECEIVED_SHUTDOWN 2 ;
|
||||
|
||||
FUNCTION: int SSL_get_shutdown ( ssl-pointer ssl ) ;
|
||||
|
||||
FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
|
||||
|
||||
FUNCTION: int SSL_want ( ssl-pointer ssl ) ;
|
||||
|
|
@ -150,6 +156,15 @@ FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl,
|
|||
FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile,
|
||||
char* CApath ) ;
|
||||
|
||||
FUNCTION: int SSL_CTX_set_default_verify_paths ( ssl-ctx ctx ) ;
|
||||
|
||||
: SSL_VERIFY_NONE 0 ; inline
|
||||
: SSL_VERIFY_PEER 1 ; inline
|
||||
: SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline
|
||||
: SSL_VERIFY_CLIENT_ONCE 4 ; inline
|
||||
|
||||
FUNCTION: void SSL_CTX_set_verify ( ssl-ctx ctx, int mode, void* callback ) ;
|
||||
|
||||
FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ;
|
||||
|
||||
FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ math.order combinators init alien alien.c-types alien.strings libc
|
|||
continuations destructors debugger inspector
|
||||
locals unicode.case
|
||||
openssl.libcrypto openssl.libssl
|
||||
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure ;
|
||||
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
|
||||
io.timeouts ;
|
||||
IN: openssl
|
||||
|
||||
! This code is based on http://www.rtfm.com/openssl-examples/
|
||||
|
|
@ -93,11 +94,14 @@ TUPLE: openssl-context < secure-context aliens ;
|
|||
[ ca-file>> dup [ (normalize-path) ] when ]
|
||||
[ ca-path>> dup [ (normalize-path) ] when ] bi
|
||||
] bi
|
||||
SSL_CTX_load_verify_locations ssl-error
|
||||
] [ drop ] if ;
|
||||
SSL_CTX_load_verify_locations
|
||||
] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
|
||||
|
||||
: set-verify-depth ( ctx -- )
|
||||
handle>> 1 SSL_CTX_set_verify_depth ;
|
||||
dup config>> verify-depth>> [
|
||||
[ handle>> ] [ config>> verify-depth>> ] bi
|
||||
SSL_CTX_set_verify_depth
|
||||
] [ drop ] if ;
|
||||
|
||||
TUPLE: bio handle disposed ;
|
||||
|
||||
|
|
@ -153,25 +157,26 @@ M: openssl-context dispose*
|
|||
|
||||
TUPLE: ssl-handle file handle connected disposed ;
|
||||
|
||||
ERROR: no-ssl-context ;
|
||||
SYMBOL: default-secure-context
|
||||
|
||||
M: no-ssl-context summary
|
||||
drop "SSL operations must be wrapped in calls to with-ssl-context" ;
|
||||
: context-expired? ( context -- ? )
|
||||
dup [ handle>> expired? ] [ drop t ] if ;
|
||||
|
||||
: current-ssl-context ( -- ctx )
|
||||
secure-context get [ no-ssl-context ] unless* ;
|
||||
: current-secure-context ( -- ctx )
|
||||
secure-context get [
|
||||
default-secure-context get dup context-expired? [
|
||||
drop
|
||||
<secure-config> <secure-context> default-secure-context set-global
|
||||
current-secure-context
|
||||
] when
|
||||
] unless* ;
|
||||
|
||||
: <ssl-handle> ( fd -- ssl )
|
||||
current-ssl-context handle>> SSL_new dup ssl-error
|
||||
current-secure-context handle>> SSL_new dup ssl-error
|
||||
f f ssl-handle boa ;
|
||||
|
||||
HOOK: ssl-shutdown io-backend ( handle -- )
|
||||
|
||||
M: ssl-handle dispose*
|
||||
[ ssl-shutdown ]
|
||||
[ handle>> SSL_free ]
|
||||
[ file>> dispose ]
|
||||
tri ;
|
||||
[ handle>> SSL_free ] [ file>> dispose ] bi ;
|
||||
|
||||
: check-verify-result ( ssl-handle -- )
|
||||
SSL_get_verify_result dup X509_V_OK =
|
||||
|
|
@ -188,9 +193,11 @@ M: ssl-handle dispose*
|
|||
[ 2drop ] [ common-name-verify-error ] if ;
|
||||
|
||||
M: openssl check-certificate ( host ssl -- )
|
||||
handle>>
|
||||
[ nip check-verify-result ]
|
||||
[ check-common-name ]
|
||||
2bi ;
|
||||
current-secure-context config>> verify>> [
|
||||
handle>>
|
||||
[ nip check-verify-result ]
|
||||
[ check-common-name ]
|
||||
2bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
openssl secure-socket-backend set-global
|
||||
|
|
|
|||
|
|
@ -1,3 +1,2 @@
|
|||
enterprise
|
||||
network
|
||||
bindings
|
||||
|
|
|
|||
|
|
@ -0,0 +1,249 @@
|
|||
USING: regexp4 tools.test kernel ;
|
||||
IN: regexp4-tests
|
||||
|
||||
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "" "a*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaaaaaa" "a*" <regexp> matches? ] unit-test
|
||||
[ f ] [ "ab" "a*" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abc" "abc" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a|b|c" <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "a|b|c" <regexp> matches? ] unit-test
|
||||
[ t ] [ "c" "a|b|c" <regexp> matches? ] unit-test
|
||||
[ f ] [ "c" "d|e|f" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
|
||||
[ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
|
||||
[ f ] [ "cc" "a|b|c" <regexp> matches? ] unit-test
|
||||
[ f ] [ "cc" "d|e|f" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a+" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a+" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "a+" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a?" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a?" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "a?" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "." <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "." <regexp> matches? ] unit-test
|
||||
[ t ] [ "." "." <regexp> matches? ] unit-test
|
||||
! [ f ] [ "\n" "." <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" ".+" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" ".+" <regexp> matches? ] unit-test
|
||||
[ t ] [ "ab" ".+" <regexp> matches? ] unit-test
|
||||
|
||||
|
||||
[ t ] [ "" "a|b*|c+|d?" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a|b*|c+|d?" <regexp> matches? ] unit-test
|
||||
[ t ] [ "c" "a|b*|c+|d?" <regexp> matches? ] unit-test
|
||||
[ t ] [ "cc" "a|b*|c+|d?" <regexp> matches? ] unit-test
|
||||
[ f ] [ "ccd" "a|b*|c+|d?" <regexp> matches? ] unit-test
|
||||
[ t ] [ "d" "a|b*|c+|d?" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "foo" "foo|bar" <regexp> matches? ] unit-test
|
||||
[ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
|
||||
[ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "(a)" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "(a)" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "(a*)" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
|
||||
[ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a{1}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "a{1}" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "a" "a{2,}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{2,}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaaa" "a{2,}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaaaa" "a{2,}" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "a{,2}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{,2}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "a{,2}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaa" "a{,2}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{,2}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaaa" "a{,2}" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "a{1,3}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{1,3}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aa" "a{1,3}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaa" "a{1,3}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaa" "a{1,3}" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "[a]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[abc]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "[a]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "d" "[abc]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "ab" "[abc]{1,2}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "[abc]{1,2}" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "" "[^a]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[^a]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[^abc]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "[^a]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "d" "[^abc]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "ab" "[^abc]{1,2}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "[^abc]{1,2}" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "]" "[]]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "]" "[^]]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^]]" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "^" "[^]" <regexp> matches? ] must-fail
|
||||
[ t ] [ "^" "[]^]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "]" "[]^]" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "[" "[[]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "^" "[^^]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^^]" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "-" "[-]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[-]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "-" "[^-]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^-]" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "-" "[-a]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[-a]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "-" "[a-]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a-]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "[a-]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "-" "[^-]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^-]" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "-" "[a-c]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "-" "[^a-c]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "[a-c]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "[^a-c]" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "-" "[a-c-]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "-" "[^a-c-]" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "\\" "[\\\\]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[\\\\]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "\\" "[^\\\\]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\\\]" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "0" "[\\d]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[\\d]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abc" "\\p{Lower}{3}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "ABC" "\\p{Lower}{3}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "ABC" "\\p{Upper}{3}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "\\p{Upper}{3}" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "\\Q\\E" <regexp> matches? ] unit-test
|
||||
[ t ] [ "|*+" "\\Q|*+\\E" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "\\Q|*+\\E" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "S" "\\0123" <regexp> matches? ] unit-test
|
||||
[ t ] [ "SXY" "\\0123XY" <regexp> matches? ] unit-test
|
||||
[ t ] [ "x" "\\x78" <regexp> matches? ] unit-test
|
||||
[ f ] [ "y" "\\x78" <regexp> matches? ] unit-test
|
||||
[ t ] [ "x" "\\u000078" <regexp> matches? ] unit-test
|
||||
[ f ] [ "y" "\\u000078" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "ab" "a+b" <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "a+b" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aab" "a+b" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abb" "a+b" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abbbb" "ab*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "ab*" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abab" "ab*" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "x" "\\." <regexp> matches? ] unit-test
|
||||
[ t ] [ "." "\\." <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "aaaab" "a+ab" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
|
||||
|
||||
[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
|
||||
[ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
|
||||
[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
|
||||
[ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
|
||||
[ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
|
||||
[ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
|
||||
|
||||
! [ t ] [ "aaa" "AAA" t <regexp> matches? ] unit-test
|
||||
! [ f ] [ "aax" "AAA" t <regexp> matches? ] unit-test
|
||||
! [ t ] [ "aaa" "A*" t <regexp> matches? ] unit-test
|
||||
! [ f ] [ "aaba" "A*" t <regexp> matches? ] unit-test
|
||||
! [ t ] [ "b" "[AB]" t <regexp> matches? ] unit-test
|
||||
! [ f ] [ "c" "[AB]" t <regexp> matches? ] unit-test
|
||||
! [ t ] [ "c" "[A-Z]" t <regexp> matches? ] unit-test
|
||||
! [ f ] [ "3" "[A-Z]" t <regexp> matches? ] unit-test
|
||||
|
||||
[ ] [
|
||||
"(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
|
||||
<regexp> drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
|
||||
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
|
||||
|
||||
! [ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
! [ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
|
||||
! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
|
||||
! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
|
||||
|
||||
! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
|
||||
! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
|
||||
! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
|
||||
! [ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
|
||||
|
||||
! [ f ] [ "foo bar" "foo\\B" <regexp> matches? ] unit-test
|
||||
! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-head ] unit-test
|
||||
! [ t ] [ "foo" "foo\\B" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
|
||||
! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
|
||||
|
||||
! [ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
|
||||
! [ t ] [ ".o" "\\.[a-z]" <regexp> matches? ] unit-test
|
||||
|
||||
! Bug in parsing word
|
||||
[ t ] [
|
||||
"a"
|
||||
R' a'
|
||||
matches?
|
||||
] unit-test
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
! ((A)(B(C)))
|
||||
! 1. ((A)(B(C)))
|
||||
! 2. (A)
|
||||
! 3. (B(C))
|
||||
! 4. (C)
|
||||
|
|
@ -0,0 +1,651 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators kernel math
|
||||
sequences namespaces locals combinators.lib state-tables
|
||||
math.parser state-parser sets dlists unicode.categories
|
||||
math.order quotations shuffle math.ranges splitting
|
||||
symbols fry parser ;
|
||||
IN: regexp4
|
||||
|
||||
SYMBOLS: eps start-state final-state beginning-of-text
|
||||
end-of-text left-parenthesis alternation left-bracket
|
||||
caret dash ampersand colon ;
|
||||
|
||||
SYMBOL: runtime-epsilon
|
||||
|
||||
TUPLE: regexp raw parentheses-count bracket-count
|
||||
state stack nfa new-states dfa minimized-dfa
|
||||
dot-matches-newlines? capture-group captured-groups ;
|
||||
|
||||
TUPLE: capture-group n range ;
|
||||
|
||||
ERROR: parentheses-underflow ;
|
||||
ERROR: unbalanced-parentheses ;
|
||||
ERROR: unbalanced-brackets ;
|
||||
|
||||
: push-stack ( regexp token -- ) swap stack>> push ;
|
||||
: push-all-stack ( regexp seq -- ) swap stack>> push-all ;
|
||||
: next-state ( regexp -- n ) [ 1+ ] change-state state>> ;
|
||||
|
||||
: check-parentheses-underflow ( regexp -- )
|
||||
parentheses-count>> 0 < [ parentheses-underflow ] when ;
|
||||
|
||||
: check-unbalanced-parentheses ( regexp -- )
|
||||
parentheses-count>> 0 > [ unbalanced-parentheses ] when ;
|
||||
|
||||
:: (apply-alternation) ( stack regexp -- )
|
||||
[let | s2 [ stack peek first ]
|
||||
s3 [ stack pop second ]
|
||||
s0 [ stack peek alternation = [ stack pop* ] when stack peek first ]
|
||||
s1 [ stack pop second ]
|
||||
s4 [ regexp next-state ]
|
||||
s5 [ regexp next-state ]
|
||||
table [ regexp nfa>> ] |
|
||||
s5 table add-row
|
||||
s4 eps s0 <entry> table add-entry
|
||||
s4 eps s2 <entry> table add-entry
|
||||
s1 eps s5 <entry> table add-entry
|
||||
s3 eps s5 <entry> table add-entry
|
||||
s1 table final-states>> delete-at
|
||||
s3 table final-states>> delete-at
|
||||
t s5 table final-states>> set-at
|
||||
s4 s5 2array stack push ] ;
|
||||
|
||||
: apply-alternation ( regexp -- )
|
||||
[ stack>> ] [ (apply-alternation) ] bi ;
|
||||
|
||||
: apply-alternation? ( stack -- ? )
|
||||
dup length dup 3 <
|
||||
[ 2drop f ] [ 2 - swap nth alternation = ] if ;
|
||||
|
||||
:: (apply-concatenation) ( stack regexp -- )
|
||||
[let* |
|
||||
s2 [ stack peek first ]
|
||||
s3 [ stack pop second ]
|
||||
s0 [ stack peek first ]
|
||||
s1 [ stack pop second ]
|
||||
table [ regexp nfa>> ] |
|
||||
s1 eps s2 <entry> table set-entry
|
||||
s1 table final-states>> delete-at
|
||||
s3 table add-row
|
||||
s0 s3 2array stack push ] ;
|
||||
|
||||
: apply-concatenation ( regexp -- )
|
||||
[ stack>> ] [ (apply-concatenation) ] bi ;
|
||||
|
||||
: apply-concatenation? ( seq -- ? )
|
||||
dup length dup 2 <
|
||||
[ 2drop f ] [ 2 - swap nth array? ] if ;
|
||||
|
||||
: apply-loop ( seq regexp -- seq regexp )
|
||||
over length 1 > [
|
||||
2dup over apply-alternation?
|
||||
[ (apply-alternation) ] [ (apply-concatenation) ] if apply-loop
|
||||
] when ;
|
||||
|
||||
: cut-out ( vector n -- vector' vector ) cut rest ;
|
||||
|
||||
: cut-stack ( obj vector -- vector' vector )
|
||||
tuck last-index cut-out swap ;
|
||||
|
||||
: apply-til-last ( regexp token -- )
|
||||
swap [ cut-stack ] change-stack
|
||||
apply-loop stack>> push-all ;
|
||||
|
||||
: concatenation-loop ( regexp -- )
|
||||
dup stack>> dup apply-concatenation?
|
||||
[ over (apply-concatenation) concatenation-loop ] [ 2drop ] if ;
|
||||
|
||||
:: apply-kleene-closure ( regexp -- )
|
||||
[let* | stack [ regexp stack>> ]
|
||||
s0 [ stack peek first ]
|
||||
s1 [ stack pop second ]
|
||||
s2 [ regexp next-state ]
|
||||
s3 [ regexp next-state ]
|
||||
table [ regexp nfa>> ] |
|
||||
s1 table final-states>> delete-at
|
||||
t s3 table final-states>> set-at
|
||||
s3 table add-row
|
||||
s1 eps s0 <entry> table add-entry
|
||||
s2 eps s0 <entry> table add-entry
|
||||
s2 eps s3 <entry> table add-entry
|
||||
s1 eps s3 <entry> table add-entry
|
||||
s2 s3 2array stack push ] ;
|
||||
|
||||
: add-numbers ( n obj -- obj )
|
||||
2dup [ number? ] bi@ and
|
||||
[ + ] [ dup sequence? [ [ + ] with map ] [ nip ] if ] if ;
|
||||
|
||||
: increment-columns ( n assoc -- )
|
||||
dup [ >r swap >r add-numbers r> r> set-at ] curry with* assoc-each ;
|
||||
|
||||
:: copy-state-rows ( regexp range -- )
|
||||
[let* | len [ range range-length ]
|
||||
offset [ regexp state>> range range-min - 1+ ]
|
||||
state [ regexp [ len + ] change-state ] |
|
||||
regexp nfa>> rows>>
|
||||
[ drop range member? ] assoc-filter
|
||||
[
|
||||
[ offset + ] dip
|
||||
[ offset swap add-numbers ] assoc-map
|
||||
] assoc-map
|
||||
regexp nfa>> [ assoc-union ] change-rows drop
|
||||
range [ range-min ] [ range-max ] bi [ offset + ] bi@ 2array
|
||||
regexp stack>> push ] ;
|
||||
|
||||
: last-state ( regexp -- range )
|
||||
stack>> peek first2 [a,b] ;
|
||||
|
||||
: set-last-state-final ( ? regexp -- )
|
||||
[ stack>> peek second ] [ nfa>> final-states>> ] bi set-at ;
|
||||
|
||||
: apply-plus-closure ( regexp -- )
|
||||
[ dup last-state copy-state-rows ]
|
||||
[ apply-kleene-closure ]
|
||||
[ apply-concatenation ] tri ;
|
||||
|
||||
: apply-question-closure ( regexp -- )
|
||||
[ stack>> peek first2 eps swap <entry> ] [ nfa>> add-entry ] bi ;
|
||||
|
||||
: with0 ( obj n quot -- n quot' ) swapd curry ; inline
|
||||
|
||||
: copy-state ( regexp state n -- )
|
||||
[ copy-state-rows ] with0 with0 times ;
|
||||
|
||||
:: (exactly-n) ( regexp state n -- )
|
||||
regexp state n copy-state
|
||||
t regexp set-last-state-final ;
|
||||
|
||||
: exactly-n ( regexp n -- )
|
||||
>r dup last-state r> 1- (exactly-n) ;
|
||||
|
||||
: exactly-n-concatenated ( regexp state n -- )
|
||||
[ (exactly-n) ] 3keep
|
||||
nip 1- [ apply-concatenation ] with0 times ;
|
||||
|
||||
:: at-least-n ( regexp n -- )
|
||||
[let | state [ regexp stack>> pop first2 [a,b] ] |
|
||||
regexp state n copy-state
|
||||
state regexp stack>> push
|
||||
regexp apply-kleene-closure ] ;
|
||||
|
||||
: pop-last ( regexp -- range )
|
||||
stack>> pop first2 [a,b] ;
|
||||
|
||||
:: at-most-n ( regexp n -- )
|
||||
[let | state [ regexp pop-last ] |
|
||||
regexp state n [ 1+ exactly-n-concatenated ] with with each
|
||||
regexp n 1- [ apply-alternation ] with0 times
|
||||
regexp apply-question-closure ] ;
|
||||
|
||||
:: from-m-to-n ( regexp m n -- )
|
||||
[let | state [ regexp pop-last ] |
|
||||
regexp state
|
||||
m n [a,b] [ exactly-n-concatenated ] with with each
|
||||
regexp n m - [ apply-alternation ] with0 times ] ;
|
||||
|
||||
: apply-brace-closure ( regexp from/f to/f comma? -- )
|
||||
[
|
||||
2dup and
|
||||
[ from-m-to-n ]
|
||||
[ [ nip at-most-n ] [ at-least-n ] if* ] if
|
||||
] [ drop exactly-n ] if ;
|
||||
|
||||
:: make-nontoken-nfa ( regexp obj -- )
|
||||
[let | s0 [ regexp next-state ]
|
||||
s1 [ regexp next-state ]
|
||||
stack [ regexp stack>> ]
|
||||
table [ regexp nfa>> ] |
|
||||
s0 obj s1 <entry> table set-entry
|
||||
s1 table add-row
|
||||
t s1 table final-states>> set-at
|
||||
s0 s1 2array stack push ] ;
|
||||
|
||||
: set-start-state ( regexp -- )
|
||||
dup stack>> dup empty? [
|
||||
2drop
|
||||
] [
|
||||
[ nfa>> ] [ pop first ] bi* >>start-state drop
|
||||
] if ;
|
||||
|
||||
: ascii? ( n -- ? ) 0 HEX: 7f between? ;
|
||||
: octal-digit? ( n -- ? ) CHAR: 0 CHAR: 7 between? ;
|
||||
: decimal-digit? ( n -- ? ) CHAR: 0 CHAR: 9 between? ;
|
||||
|
||||
: hex-digit? ( n -- ? )
|
||||
dup decimal-digit?
|
||||
over CHAR: a CHAR: f between? or
|
||||
swap CHAR: A CHAR: F between? or ;
|
||||
|
||||
: control-char? ( n -- ? )
|
||||
dup 0 HEX: 1f between? swap HEX: 7f = or ;
|
||||
|
||||
: punct? ( n -- ? )
|
||||
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
|
||||
|
||||
: c-identifier-char? ( ch -- ? )
|
||||
dup alpha? swap CHAR: _ = or ;
|
||||
|
||||
: java-blank? ( n -- ? )
|
||||
{
|
||||
CHAR: \s CHAR: \t CHAR: \n
|
||||
HEX: b HEX: 7 CHAR: \r
|
||||
} member? ;
|
||||
|
||||
: java-printable? ( n -- ? )
|
||||
dup alpha? swap punct? or ;
|
||||
|
||||
ERROR: bad-character-class obj ;
|
||||
|
||||
: parse-posix-class ( -- quot )
|
||||
next
|
||||
CHAR: { expect
|
||||
[ get-char CHAR: } = ] take-until
|
||||
{
|
||||
{ "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? ] ] }
|
||||
! TODO: unicode-character-class, fallthrough in unicode is bad-char-clss
|
||||
[ bad-character-class ]
|
||||
} case ;
|
||||
|
||||
ERROR: bad-octal number ;
|
||||
|
||||
: parse-octal ( regexp -- )
|
||||
next get-char drop
|
||||
3 take oct>
|
||||
dup 255 > [ bad-octal ] when
|
||||
make-nontoken-nfa ;
|
||||
|
||||
ERROR: bad-hex number ;
|
||||
|
||||
: parse-short-hex ( regexp -- )
|
||||
next 2 take hex>
|
||||
dup number? [ bad-hex ] unless
|
||||
make-nontoken-nfa ;
|
||||
|
||||
: parse-long-hex ( regexp -- )
|
||||
next 4 take hex>
|
||||
dup number? [ bad-hex ] unless
|
||||
make-nontoken-nfa ;
|
||||
|
||||
: parse-control-character ( regexp -- )
|
||||
next get-char make-nontoken-nfa ;
|
||||
|
||||
: parse-backreference ( regexp obj -- )
|
||||
2drop ;
|
||||
|
||||
: dot-construction ( regexp -- )
|
||||
[ CHAR: \n = not ] make-nontoken-nfa ;
|
||||
|
||||
: front-anchor-construction ( regexp -- )
|
||||
drop ;
|
||||
|
||||
: back-anchor-construction ( regexp -- )
|
||||
drop ;
|
||||
|
||||
: parse-brace ( -- from/f to/f comma? )
|
||||
next
|
||||
[ get-char CHAR: } = ] take-until
|
||||
"," split1 [ [ string>number ] bi@ ] keep >boolean ;
|
||||
|
||||
: parse-escaped ( regexp -- )
|
||||
next get-char {
|
||||
{ CHAR: \ [ [ CHAR: \ = ] make-nontoken-nfa ] }
|
||||
{ CHAR: t [ [ CHAR: \t = ] make-nontoken-nfa ] }
|
||||
{ CHAR: n [ [ CHAR: \n = ] make-nontoken-nfa ] }
|
||||
{ CHAR: r [ [ CHAR: \r = ] make-nontoken-nfa ] }
|
||||
{ CHAR: f [ [ HEX: c = ] make-nontoken-nfa ] }
|
||||
{ CHAR: a [ [ HEX: 7 = ] make-nontoken-nfa ] }
|
||||
{ CHAR: e [ [ HEX: 1b = ] make-nontoken-nfa ] }
|
||||
|
||||
{ CHAR: d [ [ digit? ] make-nontoken-nfa ] }
|
||||
{ CHAR: D [ [ digit? not ] make-nontoken-nfa ] }
|
||||
{ CHAR: s [ [ java-blank? ] make-nontoken-nfa ] }
|
||||
{ CHAR: S [ [ java-blank? not ] make-nontoken-nfa ] }
|
||||
{ CHAR: w [ [ c-identifier-char? ] make-nontoken-nfa ] }
|
||||
{ CHAR: W [ [ c-identifier-char? not ] make-nontoken-nfa ] }
|
||||
|
||||
{ CHAR: p [ parse-posix-class make-nontoken-nfa ] }
|
||||
{ CHAR: P [ parse-posix-class [ not ] compose make-nontoken-nfa ] }
|
||||
{ CHAR: x [ parse-short-hex ] }
|
||||
{ CHAR: u [ parse-long-hex ] }
|
||||
{ CHAR: 0 [ parse-octal ] }
|
||||
{ CHAR: c [ parse-control-character ] }
|
||||
|
||||
! { CHAR: Q [ quot til \E ] }
|
||||
! { CHAR: E [ should be an error, parse this in the Q if exists ] }
|
||||
|
||||
! { CHAR: b [ ] } ! a word boundary
|
||||
! { CHAR: B [ ] } ! a non-word boundary
|
||||
! { CHAR: A [ ] } ! beginning of input
|
||||
! { CHAR: G [ ] } ! end of previous match
|
||||
! { CHAR: Z [ ] } ! end of input but for the final terminator, if any
|
||||
! { CHAR: z [ ] } ! end of the input
|
||||
[ dup digit? [ parse-backreference ] [ make-nontoken-nfa ] if ]
|
||||
} case ;
|
||||
|
||||
: handle-dash ( vector -- vector )
|
||||
[ dup dash eq? [ drop CHAR: - ] when ] map ;
|
||||
|
||||
ERROR: unmatched-negated-character-class class ;
|
||||
|
||||
: handle-caret ( vector -- vector ? )
|
||||
dup [ length 2 >= ] [ first caret eq? ] bi and [
|
||||
rest t
|
||||
] [
|
||||
f
|
||||
] if ;
|
||||
|
||||
: make-character-class ( regexp -- )
|
||||
left-bracket over stack>> cut-stack
|
||||
pick (>>stack)
|
||||
handle-dash
|
||||
handle-caret
|
||||
>r [ dup number? [ '[ dup , = ] ] when ] map
|
||||
[ [ drop t ] 2array ] map [ drop f ] suffix [ cond ] curry r>
|
||||
[ [ not ] compose ] when
|
||||
make-nontoken-nfa ;
|
||||
|
||||
: apply-dash ( regexp -- )
|
||||
stack>> dup [ pop ] [ pop* ] [ pop ] tri
|
||||
swap '[ dup , , between? ] swap push ;
|
||||
|
||||
: apply-dash? ( regexp -- ? )
|
||||
stack>> dup length 3 >=
|
||||
[ [ length 2 - ] keep nth dash eq? ] [ drop f ] if ;
|
||||
|
||||
DEFER: parse-character-class
|
||||
: (parse-character-class) ( regexp -- )
|
||||
[
|
||||
next get-char
|
||||
{
|
||||
{ CHAR: [ [
|
||||
[ 1+ ] change-bracket-count left-bracket push-stack
|
||||
parse-character-class
|
||||
] }
|
||||
{ CHAR: ] [
|
||||
[ 1- ] change-bracket-count
|
||||
make-character-class
|
||||
] }
|
||||
{ CHAR: - [ dash push-stack ] }
|
||||
! { CHAR: & [ ampersand push-stack ] }
|
||||
! { CHAR: : [ semicolon push-stack ] }
|
||||
{ CHAR: \ [ parse-escaped ] }
|
||||
{ f [ unbalanced-brackets ] }
|
||||
[ dupd push-stack dup apply-dash? [ apply-dash ] [ drop ] if ]
|
||||
} case
|
||||
] [
|
||||
dup bracket-count>> 0 >
|
||||
[ (parse-character-class) ] [ drop ] if
|
||||
] bi ;
|
||||
|
||||
: parse-character-class-second ( regexp -- )
|
||||
get-next
|
||||
{
|
||||
! { CHAR: [ [ CHAR: [ push-stack next ] }
|
||||
{ CHAR: ] [ CHAR: ] push-stack next ] }
|
||||
{ CHAR: - [ CHAR: - push-stack next ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
: parse-character-class-first ( regexp -- )
|
||||
get-next
|
||||
{
|
||||
{ CHAR: ^ [ caret dupd push-stack next parse-character-class-second ] }
|
||||
! { CHAR: [ [ CHAR: [ push-stack next ] }
|
||||
{ CHAR: ] [ CHAR: ] push-stack next ] }
|
||||
{ CHAR: - [ CHAR: - push-stack next ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
: parse-character-class ( regexp -- )
|
||||
[ parse-character-class-first ] [ (parse-character-class) ] bi ;
|
||||
|
||||
ERROR: unsupported-token token ;
|
||||
: parse-token ( regexp token -- )
|
||||
dup {
|
||||
{ CHAR: ^ [ drop front-anchor-construction ] }
|
||||
{ CHAR: $ [ drop back-anchor-construction ] }
|
||||
{ CHAR: \ [ drop parse-escaped ] }
|
||||
{ CHAR: | [ drop dup concatenation-loop alternation push-stack ] }
|
||||
{ CHAR: ( [ drop [ 1+ ] change-parentheses-count left-parenthesis push-stack ] }
|
||||
{ CHAR: ) [ drop [ 1- ] change-parentheses-count left-parenthesis apply-til-last ] }
|
||||
{ CHAR: * [ drop apply-kleene-closure ] }
|
||||
{ CHAR: + [ drop apply-plus-closure ] }
|
||||
{ CHAR: ? [ drop apply-question-closure ] }
|
||||
{ CHAR: { [ drop parse-brace apply-brace-closure ] }
|
||||
{ CHAR: [ [
|
||||
drop
|
||||
dup left-bracket push-stack
|
||||
[ 1+ ] change-bracket-count parse-character-class
|
||||
] }
|
||||
! { CHAR: } [ drop drop "brace" ] }
|
||||
! { CHAR: ? [ drop ] }
|
||||
{ CHAR: . [ drop dot-construction ] }
|
||||
{ beginning-of-text [ push-stack ] }
|
||||
{ end-of-text [
|
||||
drop {
|
||||
[ check-unbalanced-parentheses ]
|
||||
[ concatenation-loop ]
|
||||
[ beginning-of-text apply-til-last ]
|
||||
[ set-start-state ]
|
||||
} cleave
|
||||
] }
|
||||
[ drop make-nontoken-nfa ]
|
||||
} case ;
|
||||
|
||||
: (parse-raw-regexp) ( regexp -- )
|
||||
get-char [ dupd parse-token next (parse-raw-regexp) ] [ drop ] if* ;
|
||||
|
||||
: parse-raw-regexp ( regexp -- )
|
||||
[ beginning-of-text parse-token ]
|
||||
[
|
||||
dup raw>> dup empty? [
|
||||
2drop
|
||||
] [
|
||||
[ (parse-raw-regexp) ] string-parse
|
||||
] if
|
||||
]
|
||||
[ end-of-text parse-token ] tri ;
|
||||
|
||||
:: find-delta ( states obj table -- keys )
|
||||
obj states [
|
||||
table get-row at
|
||||
[ dup integer? [ 1array ] when unique ] [ H{ } ] if*
|
||||
] with map H{ } clone [ assoc-union ] reduce keys ;
|
||||
|
||||
:: (find-closure) ( states obj assoc table -- keys )
|
||||
[let | size [ assoc assoc-size ] |
|
||||
assoc states unique assoc-union
|
||||
dup assoc-size size > [
|
||||
obj states [
|
||||
table get-row at* [
|
||||
dup integer? [ 1array ] when
|
||||
obj rot table (find-closure)
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] with each
|
||||
] when ] ;
|
||||
|
||||
: find-closure ( states obj table -- states )
|
||||
>r H{ } r> (find-closure) keys ;
|
||||
|
||||
: find-epsilon-closure ( states table -- states )
|
||||
>r eps H{ } r> (find-closure) keys ;
|
||||
|
||||
: filter-special-transition ( vec -- vec' )
|
||||
[ drop eps = not ] assoc-filter ;
|
||||
|
||||
: initialize-subset-construction ( regexp -- )
|
||||
<vector-table> >>dfa
|
||||
[
|
||||
nfa>> [ start-state>> 1array ] keep
|
||||
find-epsilon-closure 1dlist
|
||||
] [
|
||||
swap >>new-states drop
|
||||
] [
|
||||
[ dfa>> ] [ nfa>> ] bi
|
||||
columns>> filter-special-transition >>columns drop
|
||||
] tri ;
|
||||
|
||||
:: (subset-construction) ( regexp -- )
|
||||
[let* | nfa [ regexp nfa>> ]
|
||||
dfa [ regexp dfa>> ]
|
||||
new-states [ regexp new-states>> ]
|
||||
columns [ dfa columns>> keys ] |
|
||||
|
||||
new-states dlist-empty? [
|
||||
new-states pop-front
|
||||
dup dfa add-row
|
||||
columns [
|
||||
2dup nfa [ find-delta ] [ find-epsilon-closure ] bi
|
||||
dup [ dfa rows>> key? ] [ empty? ] bi or [
|
||||
dup new-states push-back
|
||||
] unless
|
||||
dup empty? [ 3drop ] [ <entry> dfa set-entry ] if
|
||||
] with each
|
||||
regexp (subset-construction)
|
||||
] unless ] ;
|
||||
|
||||
: set-start/final-states ( regexp -- )
|
||||
dup [ nfa>> start-state>> ]
|
||||
[ dfa>> rows>> keys [ member? ] with filter first ] bi
|
||||
>r dup dfa>> r> >>start-state drop
|
||||
|
||||
dup [ nfa>> final-states>> ] [ dfa>> rows>> ] bi
|
||||
[ keys ] bi@
|
||||
[ intersect empty? not ] with filter
|
||||
>r dfa>> r> >>final-states drop ;
|
||||
|
||||
: subset-construction ( regexp -- )
|
||||
[ initialize-subset-construction ]
|
||||
[ (subset-construction) ]
|
||||
[ set-start/final-states ] tri ;
|
||||
|
||||
: <regexp> ( raw -- obj )
|
||||
regexp new
|
||||
swap >>raw
|
||||
0 >>parentheses-count
|
||||
0 >>bracket-count
|
||||
-1 >>state
|
||||
V{ } clone >>stack
|
||||
<vector-table> >>nfa
|
||||
dup [ parse-raw-regexp ] [ subset-construction ] bi ;
|
||||
|
||||
! Literal syntax for regexps
|
||||
: parse-options ( string -- ? )
|
||||
#! Lame
|
||||
{
|
||||
{ "" [ f ] }
|
||||
{ "i" [ t ] }
|
||||
} case ;
|
||||
|
||||
: parse-regexp ( accum end -- accum )
|
||||
lexer get dup skip-blank
|
||||
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
|
||||
! lexer get dup still-parsing-line?
|
||||
! [ (parse-token) parse-options ] [ drop f ] if
|
||||
<regexp> parsed ;
|
||||
|
||||
: R! CHAR: ! parse-regexp ; parsing
|
||||
: R" CHAR: " parse-regexp ; parsing
|
||||
: R# CHAR: # parse-regexp ; parsing
|
||||
: R' CHAR: ' parse-regexp ; parsing
|
||||
: R( CHAR: ) parse-regexp ; parsing
|
||||
: R/ CHAR: / parse-regexp ; parsing
|
||||
: R@ CHAR: @ parse-regexp ; parsing
|
||||
: R[ CHAR: ] parse-regexp ; parsing
|
||||
: R` CHAR: ` parse-regexp ; parsing
|
||||
: R{ CHAR: } parse-regexp ; parsing
|
||||
: R| CHAR: | parse-regexp ; parsing
|
||||
|
||||
TUPLE: dfa-traverser
|
||||
dfa
|
||||
last-state current-state
|
||||
text
|
||||
start-index current-index
|
||||
matches ;
|
||||
|
||||
: <dfa-traverser> ( text dfa -- match )
|
||||
dfa>>
|
||||
dfa-traverser new
|
||||
swap [ start-state>> >>current-state ] keep
|
||||
>>dfa
|
||||
swap >>text
|
||||
0 >>start-index
|
||||
0 >>current-index
|
||||
V{ } clone >>matches ;
|
||||
|
||||
: final-state? ( dfa-traverser -- ? )
|
||||
[ current-state>> ] [ dfa>> final-states>> ] bi
|
||||
member? ;
|
||||
|
||||
: text-finished? ( dfa-traverser -- ? )
|
||||
[ current-index>> ] [ text>> length ] bi >= ;
|
||||
|
||||
: save-final-state ( dfa-straverser -- )
|
||||
[ current-index>> ] [ matches>> ] bi push ;
|
||||
|
||||
: match-done? ( dfa-traverser -- ? )
|
||||
dup final-state? [
|
||||
dup save-final-state
|
||||
] when text-finished? ;
|
||||
|
||||
: increment-state ( dfa-traverser state -- dfa-traverser )
|
||||
>r [ 1+ ] change-current-index
|
||||
dup current-state>> >>last-state r>
|
||||
>>current-state ;
|
||||
|
||||
: match-transition ( obj hash -- state/f )
|
||||
2dup keys [ callable? ] filter predicates
|
||||
[ swap at nip ] [ at ] if* ;
|
||||
|
||||
: do-match ( dfa-traverser -- dfa-traverser )
|
||||
dup match-done? [
|
||||
dup {
|
||||
[ current-index>> ]
|
||||
[ text>> ]
|
||||
[ current-state>> ]
|
||||
[ dfa>> rows>> ]
|
||||
} cleave
|
||||
at >r nth r> match-transition [
|
||||
increment-state do-match
|
||||
] when*
|
||||
] unless ;
|
||||
|
||||
: return-match ( dfa-traverser -- interval/f )
|
||||
dup matches>> empty? [
|
||||
drop f
|
||||
] [
|
||||
[ start-index>> ] [ matches>> peek ] bi 1 <range>
|
||||
] if ;
|
||||
|
||||
: match ( string regexp -- pair )
|
||||
<dfa-traverser> do-match return-match ;
|
||||
|
||||
: matches? ( string regexp -- ? )
|
||||
dupd match [ [ length ] [ range-length 1- ] bi* = ] [ drop f ] if* ;
|
||||
|
||||
: match-head ( string regexp -- end )
|
||||
match length>> ;
|
||||
|
||||
! character classes
|
||||
! TUPLE: range-class from to ;
|
||||
! TUPLE: or-class left right ;
|
||||
|
||||
! (?:a|b)* <- does not capture
|
||||
! (a|b)*\1 <- group captured
|
||||
! (?!abba) negative lookahead matches ababa but not abbaa
|
||||
! (?=abba) positive lookahead matches abbaaa but not abaaa
|
||||
|
|
@ -5,8 +5,6 @@ USING: kernel sequences namespaces math inference.transforms
|
|||
|
||||
IN: shuffle
|
||||
|
||||
: 2dip -rot 2slip ; inline
|
||||
|
||||
MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
|
||||
|
||||
MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
USING: kernel state-tables tools.test ;
|
||||
IN: state-tables.tests
|
||||
|
||||
: test-table
|
||||
<table>
|
||||
"a" "c" "z" <entry> over set-entry
|
||||
"a" "o" "y" <entry> over set-entry
|
||||
"a" "l" "x" <entry> over set-entry
|
||||
"b" "o" "y" <entry> over set-entry
|
||||
"b" "l" "x" <entry> over set-entry
|
||||
"b" "s" "u" <entry> over set-entry ;
|
||||
|
||||
[
|
||||
T{
|
||||
table
|
||||
f
|
||||
H{
|
||||
{ "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } }
|
||||
{ "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
|
||||
}
|
||||
H{ { "l" t } { "s" t } { "c" t } { "o" t } }
|
||||
f
|
||||
H{ }
|
||||
}
|
||||
] [ test-table ] unit-test
|
||||
|
||||
[ "x" t ] [ "a" "l" test-table get-entry ] unit-test
|
||||
[ "har" t ] [
|
||||
"a" "z" "har" <entry> test-table [ set-entry ] keep
|
||||
>r "a" "z" r> get-entry
|
||||
] unit-test
|
||||
|
||||
: vector-test-table
|
||||
<vector-table>
|
||||
"a" "c" "z" <entry> over add-entry
|
||||
"a" "c" "r" <entry> over add-entry
|
||||
"a" "o" "y" <entry> over add-entry
|
||||
"a" "l" "x" <entry> over add-entry
|
||||
"b" "o" "y" <entry> over add-entry
|
||||
"b" "l" "x" <entry> over add-entry
|
||||
"b" "s" "u" <entry> over add-entry ;
|
||||
|
||||
[
|
||||
T{ vector-table f
|
||||
H{
|
||||
{ "a"
|
||||
H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } }
|
||||
{ "b"
|
||||
H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
|
||||
}
|
||||
H{ { "l" t } { "s" t } { "c" t } { "o" t } }
|
||||
f
|
||||
H{ }
|
||||
}
|
||||
] [ vector-test-table ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,123 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces sequences vectors assocs accessors ;
|
||||
IN: state-tables
|
||||
|
||||
TUPLE: table rows columns start-state final-states ;
|
||||
TUPLE: entry row-key column-key value ;
|
||||
|
||||
GENERIC: add-entry ( entry table -- )
|
||||
|
||||
: make-table ( class -- obj )
|
||||
new
|
||||
H{ } clone >>rows
|
||||
H{ } clone >>columns
|
||||
H{ } clone >>final-states ;
|
||||
|
||||
: <table> ( -- obj )
|
||||
table make-table ;
|
||||
|
||||
C: <entry> entry
|
||||
|
||||
: (add-row) ( row-key table -- row )
|
||||
2dup rows>> at* [
|
||||
2nip
|
||||
] [
|
||||
drop H{ } clone [ -rot rows>> set-at ] keep
|
||||
] if ;
|
||||
|
||||
: add-row ( row-key table -- )
|
||||
(add-row) drop ;
|
||||
|
||||
: add-column ( column-key table -- )
|
||||
t -rot columns>> set-at ;
|
||||
|
||||
: set-row ( row row-key table -- )
|
||||
rows>> set-at ;
|
||||
|
||||
: lookup-row ( row-key table -- row/f ? )
|
||||
rows>> at* ;
|
||||
|
||||
: row-exists? ( row-key table -- ? )
|
||||
lookup-row nip ;
|
||||
|
||||
: lookup-column ( column-key table -- column/f ? )
|
||||
columns>> at* ;
|
||||
|
||||
: column-exists? ( column-key table -- ? )
|
||||
lookup-column nip ;
|
||||
|
||||
ERROR: no-row key ;
|
||||
ERROR: no-column key ;
|
||||
|
||||
: get-row ( row-key table -- row )
|
||||
dupd lookup-row [
|
||||
nip
|
||||
] [
|
||||
drop no-row
|
||||
] if ;
|
||||
|
||||
: get-column ( column-key table -- column )
|
||||
dupd lookup-column [
|
||||
nip
|
||||
] [
|
||||
drop no-column
|
||||
] if ;
|
||||
|
||||
: get-entry ( row-key column-key table -- obj ? )
|
||||
swapd lookup-row [
|
||||
at*
|
||||
] [
|
||||
2drop f f
|
||||
] if ;
|
||||
|
||||
: (set-entry) ( entry table -- value column-key row )
|
||||
[ >r column-key>> r> add-column ] 2keep
|
||||
dupd >r row-key>> r> (add-row)
|
||||
>r [ value>> ] keep column-key>> r> ;
|
||||
|
||||
: set-entry ( entry table -- )
|
||||
(set-entry) set-at ;
|
||||
|
||||
: delete-entry ( entry table -- )
|
||||
>r [ column-key>> ] [ row-key>> ] bi r>
|
||||
lookup-row [ delete-at ] [ 2drop ] if ;
|
||||
|
||||
: swap-rows ( row-key1 row-key2 table -- )
|
||||
[ tuck get-row >r get-row r> ] 3keep
|
||||
>r >r rot r> r> [ set-row ] keep set-row ;
|
||||
|
||||
: member?* ( obj obj -- bool )
|
||||
2dup = [ 2drop t ] [ member? ] if ;
|
||||
|
||||
: find-by-column ( column-key data table -- seq )
|
||||
swapd 2dup lookup-column 2drop
|
||||
[
|
||||
rows>> [
|
||||
pick swap at* [
|
||||
>r pick r> member?* [ , ] [ drop ] if
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] assoc-each
|
||||
] { } make 2nip ;
|
||||
|
||||
|
||||
TUPLE: vector-table < table ;
|
||||
: <vector-table> ( -- obj )
|
||||
vector-table make-table ;
|
||||
|
||||
: add-hash-vector ( value key hash -- )
|
||||
2dup at* [
|
||||
dup vector? [
|
||||
2nip push
|
||||
] [
|
||||
V{ } clone [ push ] keep
|
||||
-rot >r >r [ push ] keep r> r> set-at
|
||||
] if
|
||||
] [
|
||||
drop set-at
|
||||
] if ;
|
||||
|
||||
M: vector-table add-entry ( entry table -- )
|
||||
(set-entry) add-hash-vector ;
|
||||
|
|
@ -1,26 +1,21 @@
|
|||
USING: math arrays sequences kernel random splitting strings unicode.case ;
|
||||
USING: math math.ranges arrays sequences kernel random splitting
|
||||
strings unicode.case ;
|
||||
IN: strings.lib
|
||||
|
||||
: char>digit ( c -- i ) 48 - ;
|
||||
|
||||
: string>digits ( s -- seq ) [ char>digit ] { } map-as ;
|
||||
|
||||
: >Upper ( str -- str )
|
||||
dup empty? [
|
||||
unclip ch>upper 1string prepend
|
||||
] unless ;
|
||||
dup empty? [ unclip ch>upper prefix ] unless ;
|
||||
|
||||
: >Upper-dashes ( str -- str )
|
||||
"-" split [ >Upper ] map "-" join ;
|
||||
|
||||
: lower-alpha-chars ( -- seq )
|
||||
26 [ CHAR: a + ] map ;
|
||||
CHAR: a CHAR: z [a,b] ;
|
||||
|
||||
: upper-alpha-chars ( -- seq )
|
||||
26 [ CHAR: A + ] map ;
|
||||
CHAR: A CHAR: Z [a,b] ;
|
||||
|
||||
: numeric-chars ( -- seq )
|
||||
10 [ CHAR: 0 + ] map ;
|
||||
CHAR: 0 CHAR: 9 [a,b] ;
|
||||
|
||||
: alpha-chars ( -- seq )
|
||||
lower-alpha-chars upper-alpha-chars append ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: tools.test.ui
|
|||
<dlist> \ graft-queue [
|
||||
over
|
||||
graft notify-queued
|
||||
swap slip
|
||||
dip
|
||||
ungraft notify-queued
|
||||
] with-variable
|
||||
] with-string-writer print ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ quotations math opengl combinators math.vectors
|
|||
sorting splitting io.streams.nested assocs
|
||||
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
|
||||
ui.gadgets.grid-lines classes.tuple models continuations
|
||||
destructors ;
|
||||
destructors accessors ;
|
||||
IN: ui.gadgets.panes
|
||||
|
||||
TUPLE: pane output current prototype scrolls?
|
||||
|
|
@ -114,6 +114,9 @@ GENERIC: write-gadget ( gadget stream -- )
|
|||
M: pane-stream write-gadget
|
||||
pane-stream-pane pane-current add-gadget ;
|
||||
|
||||
M: style-stream write-gadget
|
||||
stream>> write-gadget ;
|
||||
|
||||
: print-gadget ( gadget stream -- )
|
||||
tuck write-gadget stream-nl ;
|
||||
|
||||
|
|
|
|||
|
|
@ -160,6 +160,7 @@ M: stack-display tool-scroller
|
|||
{
|
||||
[ com-end ]
|
||||
[ clear-output ]
|
||||
[ input>> clear-input ]
|
||||
[ start-listener-thread ]
|
||||
[ wait-for-listener ]
|
||||
} cleave ;
|
||||
|
|
|
|||
|
|
@ -48,10 +48,6 @@ C-STRUCT: sockaddr-un
|
|||
|
||||
: max-un-path 104 ; inline
|
||||
|
||||
: EINTR HEX: 4 ; inline
|
||||
: EAGAIN HEX: 23 ; inline
|
||||
: EINPROGRESS HEX: 24 ; inline
|
||||
|
||||
: SOCK_STREAM 1 ; inline
|
||||
: SOCK_DGRAM 2 ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -12,3 +12,98 @@ C-STRUCT: addrinfo
|
|||
{ "char*" "canonname" }
|
||||
{ "void*" "addr" }
|
||||
{ "addrinfo*" "next" } ;
|
||||
|
||||
: EPERM 1 ; inline
|
||||
: ENOENT 2 ; inline
|
||||
: ESRCH 3 ; inline
|
||||
: EINTR 4 ; inline
|
||||
: EIO 5 ; inline
|
||||
: ENXIO 6 ; inline
|
||||
: E2BIG 7 ; inline
|
||||
: ENOEXEC 8 ; inline
|
||||
: EBADF 9 ; inline
|
||||
: ECHILD 10 ; inline
|
||||
: EDEADLK 11 ; inline
|
||||
: ENOMEM 12 ; inline
|
||||
: EACCES 13 ; inline
|
||||
: EFAULT 14 ; inline
|
||||
: ENOTBLK 15 ; inline
|
||||
: EBUSY 16 ; inline
|
||||
: EEXIST 17 ; inline
|
||||
: EXDEV 18 ; inline
|
||||
: ENODEV 19 ; inline
|
||||
: ENOTDIR 20 ; inline
|
||||
: EISDIR 21 ; inline
|
||||
: EINVAL 22 ; inline
|
||||
: ENFILE 23 ; inline
|
||||
: EMFILE 24 ; inline
|
||||
: ENOTTY 25 ; inline
|
||||
: ETXTBSY 26 ; inline
|
||||
: EFBIG 27 ; inline
|
||||
: ENOSPC 28 ; inline
|
||||
: ESPIPE 29 ; inline
|
||||
: EROFS 30 ; inline
|
||||
: EMLINK 31 ; inline
|
||||
: EPIPE 32 ; inline
|
||||
: EDOM 33 ; inline
|
||||
: ERANGE 34 ; inline
|
||||
: EAGAIN 35 ; inline
|
||||
: EWOULDBLOCK EAGAIN ; inline
|
||||
: EINPROGRESS 36 ; inline
|
||||
: EALREADY 37 ; inline
|
||||
: ENOTSOCK 38 ; inline
|
||||
: EDESTADDRREQ 39 ; inline
|
||||
: EMSGSIZE 40 ; inline
|
||||
: EPROTOTYPE 41 ; inline
|
||||
: ENOPROTOOPT 42 ; inline
|
||||
: EPROTONOSUPPORT 43 ; inline
|
||||
: ESOCKTNOSUPPORT 44 ; inline
|
||||
: EOPNOTSUPP 45 ; inline
|
||||
: ENOTSUP EOPNOTSUPP ; inline
|
||||
: EPFNOSUPPORT 46 ; inline
|
||||
: EAFNOSUPPORT 47 ; inline
|
||||
: EADDRINUSE 48 ; inline
|
||||
: EADDRNOTAVAIL 49 ; inline
|
||||
: ENETDOWN 50 ; inline
|
||||
: ENETUNREACH 51 ; inline
|
||||
: ENETRESET 52 ; inline
|
||||
: ECONNABORTED 53 ; inline
|
||||
: ECONNRESET 54 ; inline
|
||||
: ENOBUFS 55 ; inline
|
||||
: EISCONN 56 ; inline
|
||||
: ENOTCONN 57 ; inline
|
||||
: ESHUTDOWN 58 ; inline
|
||||
: ETOOMANYREFS 59 ; inline
|
||||
: ETIMEDOUT 60 ; inline
|
||||
: ECONNREFUSED 61 ; inline
|
||||
: ELOOP 62 ; inline
|
||||
: ENAMETOOLONG 63 ; inline
|
||||
: EHOSTDOWN 64 ; inline
|
||||
: EHOSTUNREACH 65 ; inline
|
||||
: ENOTEMPTY 66 ; inline
|
||||
: EPROCLIM 67 ; inline
|
||||
: EUSERS 68 ; inline
|
||||
: EDQUOT 69 ; inline
|
||||
: ESTALE 70 ; inline
|
||||
: EREMOTE 71 ; inline
|
||||
: EBADRPC 72 ; inline
|
||||
: ERPCMISMATCH 73 ; inline
|
||||
: EPROGUNAVAIL 74 ; inline
|
||||
: EPROGMISMATCH 75 ; inline
|
||||
: EPROCUNAVAIL 76 ; inline
|
||||
: ENOLCK 77 ; inline
|
||||
: ENOSYS 78 ; inline
|
||||
: EFTYPE 79 ; inline
|
||||
: EAUTH 80 ; inline
|
||||
: ENEEDAUTH 81 ; inline
|
||||
: EIDRM 82 ; inline
|
||||
: ENOMSG 83 ; inline
|
||||
: EOVERFLOW 84 ; inline
|
||||
: ECANCELED 85 ; inline
|
||||
: EILSEQ 86 ; inline
|
||||
: ENOATTR 87 ; inline
|
||||
: EDOOFUS 88 ; inline
|
||||
: EBADMSG 89 ; inline
|
||||
: EMULTIHOP 90 ; inline
|
||||
: ENOLINK 91 ; inline
|
||||
: EPROTO 92 ; inline
|
||||
|
|
|
|||
|
|
@ -25,3 +25,108 @@ C-STRUCT: passwd
|
|||
{ "char*" "pw_shell" }
|
||||
{ "time_t" "pw_expire" }
|
||||
{ "int" "pw_fields" } ;
|
||||
|
||||
: EPERM 1 ; inline
|
||||
: ENOENT 2 ; inline
|
||||
: ESRCH 3 ; inline
|
||||
: EINTR 4 ; inline
|
||||
: EIO 5 ; inline
|
||||
: ENXIO 6 ; inline
|
||||
: E2BIG 7 ; inline
|
||||
: ENOEXEC 8 ; inline
|
||||
: EBADF 9 ; inline
|
||||
: ECHILD 10 ; inline
|
||||
: EDEADLK 11 ; inline
|
||||
: ENOMEM 12 ; inline
|
||||
: EACCES 13 ; inline
|
||||
: EFAULT 14 ; inline
|
||||
: ENOTBLK 15 ; inline
|
||||
: EBUSY 16 ; inline
|
||||
: EEXIST 17 ; inline
|
||||
: EXDEV 18 ; inline
|
||||
: ENODEV 19 ; inline
|
||||
: ENOTDIR 20 ; inline
|
||||
: EISDIR 21 ; inline
|
||||
: EINVAL 22 ; inline
|
||||
: ENFILE 23 ; inline
|
||||
: EMFILE 24 ; inline
|
||||
: ENOTTY 25 ; inline
|
||||
: ETXTBSY 26 ; inline
|
||||
: EFBIG 27 ; inline
|
||||
: ENOSPC 28 ; inline
|
||||
: ESPIPE 29 ; inline
|
||||
: EROFS 30 ; inline
|
||||
: EMLINK 31 ; inline
|
||||
: EPIPE 32 ; inline
|
||||
: EDOM 33 ; inline
|
||||
: ERANGE 34 ; inline
|
||||
: EAGAIN 35 ; inline
|
||||
: EWOULDBLOCK EAGAIN ; inline
|
||||
: EINPROGRESS 36 ; inline
|
||||
: EALREADY 37 ; inline
|
||||
: ENOTSOCK 38 ; inline
|
||||
: EDESTADDRREQ 39 ; inline
|
||||
: EMSGSIZE 40 ; inline
|
||||
: EPROTOTYPE 41 ; inline
|
||||
: ENOPROTOOPT 42 ; inline
|
||||
: EPROTONOSUPPORT 43 ; inline
|
||||
: ESOCKTNOSUPPORT 44 ; inline
|
||||
: ENOTSUP 45 ; inline
|
||||
: EPFNOSUPPORT 46 ; inline
|
||||
: EAFNOSUPPORT 47 ; inline
|
||||
: EADDRINUSE 48 ; inline
|
||||
: EADDRNOTAVAIL 49 ; inline
|
||||
: ENETDOWN 50 ; inline
|
||||
: ENETUNREACH 51 ; inline
|
||||
: ENETRESET 52 ; inline
|
||||
: ECONNABORTED 53 ; inline
|
||||
: ECONNRESET 54 ; inline
|
||||
: ENOBUFS 55 ; inline
|
||||
: EISCONN 56 ; inline
|
||||
: ENOTCONN 57 ; inline
|
||||
: ESHUTDOWN 58 ; inline
|
||||
: ETOOMANYREFS 59 ; inline
|
||||
: ETIMEDOUT 60 ; inline
|
||||
: ECONNREFUSED 61 ; inline
|
||||
: ELOOP 62 ; inline
|
||||
: ENAMETOOLONG 63 ; inline
|
||||
: EHOSTDOWN 64 ; inline
|
||||
: EHOSTUNREACH 65 ; inline
|
||||
: ENOTEMPTY 66 ; inline
|
||||
: EPROCLIM 67 ; inline
|
||||
: EUSERS 68 ; inline
|
||||
: EDQUOT 69 ; inline
|
||||
: ESTALE 70 ; inline
|
||||
: EREMOTE 71 ; inline
|
||||
: EBADRPC 72 ; inline
|
||||
: ERPCMISMATCH 73 ; inline
|
||||
: EPROGUNAVAIL 74 ; inline
|
||||
: EPROGMISMATCH 75 ; inline
|
||||
: EPROCUNAVAIL 76 ; inline
|
||||
: ENOLCK 77 ; inline
|
||||
: ENOSYS 78 ; inline
|
||||
: EFTYPE 79 ; inline
|
||||
: EAUTH 80 ; inline
|
||||
: ENEEDAUTH 81 ; inline
|
||||
: EPWROFF 82 ; inline
|
||||
: EDEVERR 83 ; inline
|
||||
: EOVERFLOW 84 ; inline
|
||||
: EBADEXEC 85 ; inline
|
||||
: EBADARCH 86 ; inline
|
||||
: ESHLIBVERS 87 ; inline
|
||||
: EBADMACHO 88 ; inline
|
||||
: ECANCELED 89 ; inline
|
||||
: EIDRM 90 ; inline
|
||||
: ENOMSG 91 ; inline
|
||||
: EILSEQ 92 ; inline
|
||||
: ENOATTR 93 ; inline
|
||||
: EBADMSG 94 ; inline
|
||||
: EMULTIHOP 95 ; inline
|
||||
: ENODATA 96 ; inline
|
||||
: ENOLINK 97 ; inline
|
||||
: ENOSR 98 ; inline
|
||||
: ENOSTR 99 ; inline
|
||||
: EPROTO 100 ; inline
|
||||
: ETIME 101 ; inline
|
||||
: EOPNOTSUPP 102 ; inline
|
||||
: ENOPOLICY 103 ; inline
|
||||
|
|
|
|||
|
|
@ -12,3 +12,102 @@ C-STRUCT: addrinfo
|
|||
{ "char*" "canonname" }
|
||||
{ "void*" "addr" }
|
||||
{ "addrinfo*" "next" } ;
|
||||
|
||||
: EPERM 1 ; inline
|
||||
: ENOENT 2 ; inline
|
||||
: ESRCH 3 ; inline
|
||||
: EINTR 4 ; inline
|
||||
: EIO 5 ; inline
|
||||
: ENXIO 6 ; inline
|
||||
: E2BIG 7 ; inline
|
||||
: ENOEXEC 8 ; inline
|
||||
: EBADF 9 ; inline
|
||||
: ECHILD 10 ; inline
|
||||
: EDEADLK 11 ; inline
|
||||
: ENOMEM 12 ; inline
|
||||
: EACCES 13 ; inline
|
||||
: EFAULT 14 ; inline
|
||||
: ENOTBLK 15 ; inline
|
||||
: EBUSY 16 ; inline
|
||||
: EEXIST 17 ; inline
|
||||
: EXDEV 18 ; inline
|
||||
: ENODEV 19 ; inline
|
||||
: ENOTDIR 20 ; inline
|
||||
: EISDIR 21 ; inline
|
||||
: EINVAL 22 ; inline
|
||||
: ENFILE 23 ; inline
|
||||
: EMFILE 24 ; inline
|
||||
: ENOTTY 25 ; inline
|
||||
: ETXTBSY 26 ; inline
|
||||
: EFBIG 27 ; inline
|
||||
: ENOSPC 28 ; inline
|
||||
: ESPIPE 29 ; inline
|
||||
: EROFS 30 ; inline
|
||||
: EMLINK 31 ; inline
|
||||
: EPIPE 32 ; inline
|
||||
: EDOM 33 ; inline
|
||||
: ERANGE 34 ; inline
|
||||
: EAGAIN 35 ; inline
|
||||
: EWOULDBLOCK EAGAIN ; inline
|
||||
: EINPROGRESS 36 ; inline
|
||||
: EALREADY 37 ; inline
|
||||
: ENOTSOCK 38 ; inline
|
||||
: EDESTADDRREQ 39 ; inline
|
||||
: EMSGSIZE 40 ; inline
|
||||
: EPROTOTYPE 41 ; inline
|
||||
: ENOPROTOOPT 42 ; inline
|
||||
: EPROTONOSUPPORT 43 ; inline
|
||||
: ESOCKTNOSUPPORT 44 ; inline
|
||||
: EOPNOTSUPP 45 ; inline
|
||||
: EPFNOSUPPORT 46 ; inline
|
||||
: EAFNOSUPPORT 47 ; inline
|
||||
: EADDRINUSE 48 ; inline
|
||||
: EADDRNOTAVAIL 49 ; inline
|
||||
: ENETDOWN 50 ; inline
|
||||
: ENETUNREACH 51 ; inline
|
||||
: ENETRESET 52 ; inline
|
||||
: ECONNABORTED 53 ; inline
|
||||
: ECONNRESET 54 ; inline
|
||||
: ENOBUFS 55 ; inline
|
||||
: EISCONN 56 ; inline
|
||||
: ENOTCONN 57 ; inline
|
||||
: ESHUTDOWN 58 ; inline
|
||||
: ETOOMANYREFS 59 ; inline
|
||||
: ETIMEDOUT 60 ; inline
|
||||
: ECONNREFUSED 61 ; inline
|
||||
: ELOOP 62 ; inline
|
||||
: ENAMETOOLONG 63 ; inline
|
||||
: EHOSTDOWN 64 ; inline
|
||||
: EHOSTUNREACH 65 ; inline
|
||||
: ENOTEMPTY 66 ; inline
|
||||
: EPROCLIM 67 ; inline
|
||||
: EUSERS 68 ; inline
|
||||
: EDQUOT 69 ; inline
|
||||
: ESTALE 70 ; inline
|
||||
: EREMOTE 71 ; inline
|
||||
: EBADRPC 72 ; inline
|
||||
: ERPCMISMATCH 73 ; inline
|
||||
: EPROGUNAVAIL 74 ; inline
|
||||
: EPROGMISMATCH 75 ; inline
|
||||
: EPROCUNAVAIL 76 ; inline
|
||||
: ENOLCK 77 ; inline
|
||||
: ENOSYS 78 ; inline
|
||||
: EFTYPE 79 ; inline
|
||||
: EAUTH 80 ; inline
|
||||
: ENEEDAUTH 81 ; inline
|
||||
: EIDRM 82 ; inline
|
||||
: ENOMSG 83 ; inline
|
||||
: EOVERFLOW 84 ; inline
|
||||
: EILSEQ 85 ; inline
|
||||
: ENOTSUP 86 ; inline
|
||||
: ECANCELED 87 ; inline
|
||||
: EBADMSG 88 ; inline
|
||||
: ENODATA 89 ; inline
|
||||
: ENOSR 90 ; inline
|
||||
: ENOSTR 91 ; inline
|
||||
: ETIME 92 ; inline
|
||||
: ENOATTR 93 ; inline
|
||||
: EMULTIHOP 94 ; inline
|
||||
: ENOLINK 95 ; inline
|
||||
: EPROTO 96 ; inline
|
||||
: ELAST 96 ; inline
|
||||
|
|
|
|||
|
|
@ -12,3 +12,93 @@ C-STRUCT: addrinfo
|
|||
{ "void*" "addr" }
|
||||
{ "char*" "canonname" }
|
||||
{ "addrinfo*" "next" } ;
|
||||
|
||||
: EPERM 1 ; inline
|
||||
: ENOENT 2 ; inline
|
||||
: ESRCH 3 ; inline
|
||||
: EINTR 4 ; inline
|
||||
: EIO 5 ; inline
|
||||
: ENXIO 6 ; inline
|
||||
: E2BIG 7 ; inline
|
||||
: ENOEXEC 8 ; inline
|
||||
: EBADF 9 ; inline
|
||||
: ECHILD 10 ; inline
|
||||
: EDEADLK 11 ; inline
|
||||
: ENOMEM 12 ; inline
|
||||
: EACCES 13 ; inline
|
||||
: EFAULT 14 ; inline
|
||||
: ENOTBLK 15 ; inline
|
||||
: EBUSY 16 ; inline
|
||||
: EEXIST 17 ; inline
|
||||
: EXDEV 18 ; inline
|
||||
: ENODEV 19 ; inline
|
||||
: ENOTDIR 20 ; inline
|
||||
: EISDIR 21 ; inline
|
||||
: EINVAL 22 ; inline
|
||||
: ENFILE 23 ; inline
|
||||
: EMFILE 24 ; inline
|
||||
: ENOTTY 25 ; inline
|
||||
: ETXTBSY 26 ; inline
|
||||
: EFBIG 27 ; inline
|
||||
: ENOSPC 28 ; inline
|
||||
: ESPIPE 29 ; inline
|
||||
: EROFS 30 ; inline
|
||||
: EMLINK 31 ; inline
|
||||
: EPIPE 32 ; inline
|
||||
: EDOM 33 ; inline
|
||||
: ERANGE 34 ; inline
|
||||
: EAGAIN 35 ; inline
|
||||
: EWOULDBLOCK EAGAIN ; inline
|
||||
: EINPROGRESS 36 ; inline
|
||||
: EALREADY 37 ; inline
|
||||
: ENOTSOCK 38 ; inline
|
||||
: EDESTADDRREQ 39 ; inline
|
||||
: EMSGSIZE 40 ; inline
|
||||
: EPROTOTYPE 41 ; inline
|
||||
: ENOPROTOOPT 42 ; inline
|
||||
: EPROTONOSUPPORT 43 ; inline
|
||||
: ESOCKTNOSUPPORT 44 ; inline
|
||||
: EOPNOTSUPP 45 ; inline
|
||||
: EPFNOSUPPORT 46 ; inline
|
||||
: EAFNOSUPPORT 47 ; inline
|
||||
: EADDRINUSE 48 ; inline
|
||||
: EADDRNOTAVAIL 49 ; inline
|
||||
: ENETDOWN 50 ; inline
|
||||
: ENETUNREACH 51 ; inline
|
||||
: ENETRESET 52 ; inline
|
||||
: ECONNABORTED 53 ; inline
|
||||
: ECONNRESET 54 ; inline
|
||||
: ENOBUFS 55 ; inline
|
||||
: EISCONN 56 ; inline
|
||||
: ENOTCONN 57 ; inline
|
||||
: ESHUTDOWN 58 ; inline
|
||||
: ETOOMANYREFS 59 ; inline
|
||||
: ETIMEDOUT 60 ; inline
|
||||
: ECONNREFUSED 61 ; inline
|
||||
: ELOOP 62 ; inline
|
||||
: ENAMETOOLONG 63 ; inline
|
||||
: EHOSTDOWN 64 ; inline
|
||||
: EHOSTUNREACH 65 ; inline
|
||||
: ENOTEMPTY 66 ; inline
|
||||
: EPROCLIM 67 ; inline
|
||||
: EUSERS 68 ; inline
|
||||
: EDQUOT 69 ; inline
|
||||
: ESTALE 70 ; inline
|
||||
: EREMOTE 71 ; inline
|
||||
: EBADRPC 72 ; inline
|
||||
: ERPCMISMATCH 73 ; inline
|
||||
: EPROGUNAVAIL 74 ; inline
|
||||
: EPROGMISMATCH 75 ; inline
|
||||
: EPROCUNAVAIL 76 ; inline
|
||||
: ENOLCK 77 ; inline
|
||||
: ENOSYS 78 ; inline
|
||||
: EFTYPE 79 ; inline
|
||||
: EAUTH 80 ; inline
|
||||
: ENEEDAUTH 81 ; inline
|
||||
: EIPSEC 82 ; inline
|
||||
: ENOATTR 83 ; inline
|
||||
: EILSEQ 84 ; inline
|
||||
: ENOMEDIUM 85 ; inline
|
||||
: EMEDIUMTYPE 86 ; inline
|
||||
: EOVERFLOW 87 ; inline
|
||||
: ECANCELED 88 ; inline
|
||||
|
|
|
|||
|
|
@ -59,10 +59,6 @@ C-STRUCT: sockaddr-un
|
|||
{ "ushort" "family" }
|
||||
{ { "char" max-un-path } "path" } ;
|
||||
|
||||
: EINTR HEX: 4 ; inline
|
||||
: EAGAIN HEX: b ; inline
|
||||
: EINPROGRESS HEX: 73 ; inline
|
||||
|
||||
: SOCK_STREAM 1 ; inline
|
||||
: SOCK_DGRAM 2 ; inline
|
||||
|
||||
|
|
@ -93,3 +89,135 @@ C-STRUCT: passwd
|
|||
{ "char*" "pw_gecos" }
|
||||
{ "char*" "pw_dir" }
|
||||
{ "char*" "pw_shell" } ;
|
||||
|
||||
: EPERM 1 ; inline
|
||||
: ENOENT 2 ; inline
|
||||
: ESRCH 3 ; inline
|
||||
: EINTR 4 ; inline
|
||||
: EIO 5 ; inline
|
||||
: ENXIO 6 ; inline
|
||||
: E2BIG 7 ; inline
|
||||
: ENOEXEC 8 ; inline
|
||||
: EBADF 9 ; inline
|
||||
: ECHILD 10 ; inline
|
||||
: EAGAIN 11 ; inline
|
||||
: ENOMEM 12 ; inline
|
||||
: EACCES 13 ; inline
|
||||
: EFAULT 14 ; inline
|
||||
: ENOTBLK 15 ; inline
|
||||
: EBUSY 16 ; inline
|
||||
: EEXIST 17 ; inline
|
||||
: EXDEV 18 ; inline
|
||||
: ENODEV 19 ; inline
|
||||
: ENOTDIR 20 ; inline
|
||||
: EISDIR 21 ; inline
|
||||
: EINVAL 22 ; inline
|
||||
: ENFILE 23 ; inline
|
||||
: EMFILE 24 ; inline
|
||||
: ENOTTY 25 ; inline
|
||||
: ETXTBSY 26 ; inline
|
||||
: EFBIG 27 ; inline
|
||||
: ENOSPC 28 ; inline
|
||||
: ESPIPE 29 ; inline
|
||||
: EROFS 30 ; inline
|
||||
: EMLINK 31 ; inline
|
||||
: EPIPE 32 ; inline
|
||||
: EDOM 33 ; inline
|
||||
: ERANGE 34 ; inline
|
||||
: EDEADLK 35 ; inline
|
||||
: ENAMETOOLONG 36 ; inline
|
||||
: ENOLCK 37 ; inline
|
||||
: ENOSYS 38 ; inline
|
||||
: ENOTEMPTY 39 ; inline
|
||||
: ELOOP 40 ; inline
|
||||
: EWOULDBLOCK EAGAIN ; inline
|
||||
: ENOMSG 42 ; inline
|
||||
: EIDRM 43 ; inline
|
||||
: ECHRNG 44 ; inline
|
||||
: EL2NSYNC 45 ; inline
|
||||
: EL3HLT 46 ; inline
|
||||
: EL3RST 47 ; inline
|
||||
: ELNRNG 48 ; inline
|
||||
: EUNATCH 49 ; inline
|
||||
: ENOCSI 50 ; inline
|
||||
: EL2HLT 51 ; inline
|
||||
: EBADE 52 ; inline
|
||||
: EBADR 53 ; inline
|
||||
: EXFULL 54 ; inline
|
||||
: ENOANO 55 ; inline
|
||||
: EBADRQC 56 ; inline
|
||||
: EBADSLT 57 ; inline
|
||||
: EDEADLOCK EDEADLK ; inline
|
||||
: EBFONT 59 ; inline
|
||||
: ENOSTR 60 ; inline
|
||||
: ENODATA 61 ; inline
|
||||
: ETIME 62 ; inline
|
||||
: ENOSR 63 ; inline
|
||||
: ENONET 64 ; inline
|
||||
: ENOPKG 65 ; inline
|
||||
: EREMOTE 66 ; inline
|
||||
: ENOLINK 67 ; inline
|
||||
: EADV 68 ; inline
|
||||
: ESRMNT 69 ; inline
|
||||
: ECOMM 70 ; inline
|
||||
: EPROTO 71 ; inline
|
||||
: EMULTIHOP 72 ; inline
|
||||
: EDOTDOT 73 ; inline
|
||||
: EBADMSG 74 ; inline
|
||||
: EOVERFLOW 75 ; inline
|
||||
: ENOTUNIQ 76 ; inline
|
||||
: EBADFD 77 ; inline
|
||||
: EREMCHG 78 ; inline
|
||||
: ELIBACC 79 ; inline
|
||||
: ELIBBAD 80 ; inline
|
||||
: ELIBSCN 81 ; inline
|
||||
: ELIBMAX 82 ; inline
|
||||
: ELIBEXEC 83 ; inline
|
||||
: EILSEQ 84 ; inline
|
||||
: ERESTART 85 ; inline
|
||||
: ESTRPIPE 86 ; inline
|
||||
: EUSERS 87 ; inline
|
||||
: ENOTSOCK 88 ; inline
|
||||
: EDESTADDRREQ 89 ; inline
|
||||
: EMSGSIZE 90 ; inline
|
||||
: EPROTOTYPE 91 ; inline
|
||||
: ENOPROTOOPT 92 ; inline
|
||||
: EPROTONOSUPPORT 93 ; inline
|
||||
: ESOCKTNOSUPPORT 94 ; inline
|
||||
: EOPNOTSUPP 95 ; inline
|
||||
: EPFNOSUPPORT 96 ; inline
|
||||
: EAFNOSUPPORT 97 ; inline
|
||||
: EADDRINUSE 98 ; inline
|
||||
: EADDRNOTAVAIL 99 ; inline
|
||||
: ENETDOWN 100 ; inline
|
||||
: ENETUNREACH 101 ; inline
|
||||
: ENETRESET 102 ; inline
|
||||
: ECONNABORTED 103 ; inline
|
||||
: ECONNRESET 104 ; inline
|
||||
: ENOBUFS 105 ; inline
|
||||
: EISCONN 106 ; inline
|
||||
: ENOTCONN 107 ; inline
|
||||
: ESHUTDOWN 108 ; inline
|
||||
: ETOOMANYREFS 109 ; inline
|
||||
: ETIMEDOUT 110 ; inline
|
||||
: ECONNREFUSED 111 ; inline
|
||||
: EHOSTDOWN 112 ; inline
|
||||
: EHOSTUNREACH 113 ; inline
|
||||
: EALREADY 114 ; inline
|
||||
: EINPROGRESS 115 ; inline
|
||||
: ESTALE 116 ; inline
|
||||
: EUCLEAN 117 ; inline
|
||||
: ENOTNAM 118 ; inline
|
||||
: ENAVAIL 119 ; inline
|
||||
: EISNAM 120 ; inline
|
||||
: EREMOTEIO 121 ; inline
|
||||
: EDQUOT 122 ; inline
|
||||
: ENOMEDIUM 123 ; inline
|
||||
: EMEDIUMTYPE 124 ; inline
|
||||
: ECANCELED 125 ; inline
|
||||
: ENOKEY 126 ; inline
|
||||
: EKEYEXPIRED 127 ; inline
|
||||
: EKEYREVOKED 128 ; inline
|
||||
: EKEYREJECTED 129 ; inline
|
||||
: EOWNERDEAD 130 ; inline
|
||||
: ENOTRECOVERABLE 131 ; inline
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc structs sequences
|
|||
continuations byte-arrays strings
|
||||
math namespaces system combinators vocabs.loader qualified
|
||||
accessors inference macros locals shuffle arrays.lib
|
||||
unix.types ;
|
||||
unix.types debugger io prettyprint ;
|
||||
|
||||
IN: unix
|
||||
|
||||
|
|
@ -23,9 +23,6 @@ TYPEDEF: uint socklen_t
|
|||
|
||||
: MAP_FAILED -1 <alien> ; inline
|
||||
|
||||
: ESRCH 3 ; inline
|
||||
: EEXIST 17 ; inline
|
||||
|
||||
: NGROUPS_MAX 16 ; inline
|
||||
|
||||
C-STRUCT: group
|
||||
|
|
@ -41,10 +38,30 @@ FUNCTION: int err_no ( ) ;
|
|||
|
||||
LIBRARY: libc
|
||||
|
||||
ERROR: unix-system-call-error args message word ;
|
||||
|
||||
FUNCTION: char* strerror ( int errno ) ;
|
||||
|
||||
ERROR: unix-error errno message ;
|
||||
|
||||
M: unix-error error.
|
||||
"Unix system call failed:" print
|
||||
nl
|
||||
dup message>> write " (" write errno>> pprint ")" print ;
|
||||
|
||||
: (io-error) ( -- * ) err_no dup strerror unix-error ;
|
||||
|
||||
: io-error ( n -- ) 0 < [ (io-error) ] when ;
|
||||
|
||||
ERROR: unix-system-call-error args errno message word ;
|
||||
|
||||
M: unix-system-call-error error.
|
||||
"Unix system call ``" write dup word>> pprint "'' failed:" print
|
||||
nl
|
||||
dup message>> write " (" write dup errno>> pprint ")" print
|
||||
nl
|
||||
"It was called with the following arguments:" print
|
||||
nl
|
||||
args>> stack. ;
|
||||
|
||||
MACRO:: unix-system-call ( quot -- )
|
||||
[let | n [ quot infer in>> ]
|
||||
word [ quot first ] |
|
||||
|
|
@ -52,7 +69,7 @@ MACRO:: unix-system-call ( quot -- )
|
|||
n ndup quot call dup 0 < [
|
||||
drop
|
||||
n narray
|
||||
err_no strerror
|
||||
err_no dup strerror
|
||||
word unix-system-call-error
|
||||
] [
|
||||
n nnip
|
||||
|
|
|
|||
|
|
@ -64,14 +64,14 @@ annotation "ANNOTATION"
|
|||
] unless ;
|
||||
|
||||
: <annotation-form> ( -- form )
|
||||
"paste" <form>
|
||||
"annotation" <form>
|
||||
"annotation" pastebin-template >>view-template
|
||||
"id" <integer>
|
||||
hidden >>renderer
|
||||
add-field
|
||||
"aid" <integer>
|
||||
hidden >>renderer
|
||||
add-field
|
||||
"annotation" pastebin-template >>view-template
|
||||
"summary" <string> add-field
|
||||
"author" <string> add-field
|
||||
"mode" <mode> add-field
|
||||
|
|
@ -79,7 +79,7 @@ annotation "ANNOTATION"
|
|||
"date" <date> add-field ;
|
||||
|
||||
: <new-annotation-form> ( -- form )
|
||||
"paste" <form>
|
||||
"annotation" <form>
|
||||
"new-annotation" pastebin-template >>edit-template
|
||||
"id" <integer>
|
||||
hidden >>renderer
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ unless
|
|||
>r find-com-interface-definition family-tree
|
||||
r> 1quotation [ >r iid>> r> 2array ] curry map
|
||||
] map-index concat
|
||||
[ f ] prefix ,
|
||||
[ f ] suffix ,
|
||||
\ case ,
|
||||
"void*" heap-size
|
||||
[ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -2,4 +2,4 @@ include vm/Config.unix
|
|||
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o
|
||||
CFLAGS += -export-dynamic
|
||||
LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
|
||||
LIBS = -lm $(X11_UI_LIBS)
|
||||
LIBS = -lm -lopenal -lalut $(X11_UI_LIBS)
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@ include vm/Config.unix
|
|||
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o
|
||||
CC = egcc
|
||||
CFLAGS += -export-dynamic
|
||||
LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz
|
||||
LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz -lssl -lcrypto
|
||||
|
|
|
|||
Loading…
Reference in New Issue