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

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

db4
U-SLAVA-DFB8FF805\Slava 2008-05-22 23:15:15 -05:00
parent 6d457a3dc8 eee90b69c4
commit d79dad93ac
46 changed files with 11428 additions and 209 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
build-support/factor.sh
View File

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

2
core/debugger/debugger.factor
View File

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

6
core/kernel/kernel.factor
View File

@ -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
extra/alarms/alarms-docs.factor
View File

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

2
extra/concurrency/mailboxes/mailboxes.factor
View File

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

8
extra/db/pooling/pooling-tests.factor
View File

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

43
extra/db/pooling/pooling.factor
View File

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

8
extra/db/pools/pools-tests.factor Normal file
View File

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

21
extra/db/pools/pools.factor Normal file
View File

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

1
extra/ftp/client/tags.txt Normal file
View File

@ -0,0 +1 @@
network

1
extra/ftp/server/tags.txt Normal file
View File

@ -0,0 +1 @@
network

1
extra/ftp/tags.txt Normal file
View File

@ -0,0 +1 @@
network

2
extra/hardware-info/linux/linux.factor
View File

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

6
extra/http/server/db/db.factor
View File

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

1
extra/io/pools/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

61
extra/io/pools/pools-docs.factor Normal file
View File

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

50
extra/io/pools/pools.factor Normal file
View File

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

1
extra/io/pools/summary.txt Normal file
View File

@ -0,0 +1 @@
Abstract connection pooling

1
extra/io/pools/tags.txt Normal file
View File

@ -0,0 +1 @@
network

1
extra/io/server/tags.txt Normal file
View File

@ -0,0 +1 @@
network

1
extra/io/sockets/secure/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

6
extra/io/sockets/secure/secure.factor
View File

@ -15,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 ;
@ -22,7 +24,9 @@ ephemeral-key-bits ;
: <secure-config> ( -- config )
secure-config new
SSLv23 >>method
1024 >>ephemeral-key-bits ;
1024 >>ephemeral-key-bits
"resource:extra/openssl/cacert.pem" >>ca-file
t >>verify ;
TUPLE: secure-context config handle disposed ;

1
extra/io/sockets/secure/summary.txt Normal file
View File

@ -0,0 +1 @@
Secure sockets (SSL, TLS)

1
extra/io/sockets/secure/tags.txt Normal file
View File

@ -0,0 +1 @@
network

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

@ -24,8 +24,13 @@ TUPLE: fd fd disposed ;
[ >>fd ]
tri ;
M: fd dispose*
[ cancel-operation ] [ fd>> close-file ] bi ;
M: fd dispose
dup disposed>> [ drop ] [
[ cancel-operation ]
[ t >>disposed drop ]
[ fd>> close-file ]
tri
] if ;
M: fd handle-fd dup check-disposed fd>> ;

91
extra/io/unix/sockets/secure/secure-tests.factor
View File

@ -12,7 +12,6 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
: 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 calendar io.timeouts ;
[ ] [
[
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 calendar io.timeouts ;
! actually an invalid certificate
[ ] [ <promise> "port" set ] unit-test
[ ] [ [ drop ] server-test ] unit-test
[ ] [ [ drop "hi" write ] server-test ] unit-test
[
<secure-config> [
@ -97,54 +96,58 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill
accept drop dispose
accept drop dup stream-read1 drop dispose
] with-disposal
] with-test-context
] with-variable
] [ io-timeout? ] must-fail-with
! Client socket shutdown timeout
[ ] [ <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
! Until I sort out two-stage handshaking, I can't do much here
[
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
[ ] [
[ ] [ <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
[
"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

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

@ -22,6 +22,26 @@ M: ssl-handle handle-fd file>> handle-fd ;
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
@ -107,52 +129,25 @@ M: secure establish-connection ( client-out remote -- )
M: secure (server) addrspec>> (server) ;
: check-accept-response ( handle r -- event )
M: secure (accept)
[
addrspec>> (accept) >r |dispose <ssl-socket> r>
] with-destructors ;
: check-shutdown-response ( handle r -- event )
#! 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
{
{ SSL_ERROR_NONE [ 2drop f ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] }
{ 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 ;
M: secure (accept)
[
addrspec>> (accept) >r
|dispose <ssl-socket> t >>connected |dispose
dup [ do-ssl-accept ] with-timeout r>
] with-destructors ;
: check-shutdown-response ( handle r -- event )
#! SSL_shutdown always returns 0 due to openssl bugs?
{
{ 1 [ drop f ] }
{ 0 [
dup handle>> dup f 0 SSL_read 2dup SSL_get_error
{
{ SSL_ERROR_ZERO_RETURN [ 3drop +retry+ ] }
{ 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
] }
} case ;
: (shutdown) ( handle -- )
dup dup handle>> SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;

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

@ -24,8 +24,10 @@ TUPLE: win32-file < win32-handle ptr ;
: <win32-file> ( handle -- win32-file )
win32-file new-win32-handle ;
M: win32-file dispose*
[ cancel-operation ] [ call-next-method ] bi ;
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 )

15
extra/lisp/lisp-docs.factor Normal file
View File

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

54
extra/lisp/lisp-tests.factor
View File

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

30
extra/lisp/lisp.factor
View File

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

6
extra/lisp/parser/parser-docs.factor Normal file
View File

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

2
extra/lisp/parser/parser.factor
View File

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

2
extra/lisp/summary.txt
View File

@ -1 +1 @@
A Lisp interpreter in Factor
A Lisp interpreter/compiler in Factor

10908
extra/openssl/cacert.pem Normal file
View File

File diff suppressed because it is too large Load Diff

14
extra/openssl/libssl/libssl.factor
View File

@ -122,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 ) ;
@ -151,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 ) ;

24
extra/openssl/openssl.factor
View File

@ -94,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 ;
@ -154,11 +157,6 @@ M: openssl-context dispose*
TUPLE: ssl-handle file handle connected disposed ;
ERROR: no-secure-context ;
M: no-secure-context summary
drop "Secure socket operations must be wrapped in calls to with-secure-context" ;
SYMBOL: default-secure-context
: context-expired? ( context -- ? )
@ -195,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
extra/openssl/tags.txt
View File

@ -1,3 +1,2 @@
enterprise
network
bindings

110
extra/regexp4/regexp4-tests.factor
View File

@ -131,6 +131,116 @@ IN: regexp4-tests
[ 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)))

32
extra/regexp4/regexp4.factor
View File

@ -4,7 +4,7 @@ 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 ;
symbols fry parser ;
IN: regexp4
SYMBOLS: eps start-state final-state beginning-of-text
@ -544,6 +544,33 @@ ERROR: unsupported-token token ;
<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
@ -611,6 +638,9 @@ TUPLE: dfa-traverser
: 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 ;

2
extra/shuffle/shuffle.factor
View File

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

17
extra/strings/lib/lib.factor
View File

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

2
extra/tools/test/ui/ui.factor
View File

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

1
extra/ui/tools/listener/listener.factor
View File

@ -160,6 +160,7 @@ M: stack-display tool-scroller
{
[ com-end ]
[ clear-output ]
[ input>> clear-input ]
[ start-listener-thread ]
[ wait-for-listener ]
} cleave ;

6
extra/webapps/pastebin/pastebin.factor
View File

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

2
vm/Config.netbsd
View File

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