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

build-support/factor.sh

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

core/debugger/debugger.factor

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

core/kernel/kernel.factor

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

extra/alarms/alarms-docs.factor

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

extra/concurrency/mailboxes/mailboxes.factor

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

extra/db/pooling/pooling-tests.factor

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

extra/db/pooling/pooling.factor

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

extra/db/pools/pools-tests.factor

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

extra/db/pools/pools.factor

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

extra/ftp/client/tags.txt

@@ -0,0 +1 @@
+network

extra/ftp/server/tags.txt

@@ -0,0 +1 @@
+network

extra/ftp/tags.txt

@@ -0,0 +1 @@
+network

extra/hardware-info/linux/linux.factor

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

extra/http/server/db/db.factor

@@ -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
+USING: db db.pools io.pools http.server http.server.sessions
-accessors continuations namespaces destructors ;
+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*
     [

extra/io/pools/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/io/pools/pools-docs.factor

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

extra/io/pools/pools.factor

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

extra/io/pools/summary.txt

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

extra/io/pools/tags.txt

@@ -0,0 +1 @@
+network

extra/io/server/tags.txt

@@ -0,0 +1 @@
+network

extra/io/sockets/secure/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/io/sockets/secure/secure.factor

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

extra/io/sockets/secure/summary.txt

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

extra/io/sockets/secure/tags.txt

@@ -0,0 +1 @@
+network

extra/io/unix/backend/backend.factor

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

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

@@ -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,13 +96,16 @@ 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
+
+! Until I sort out two-stage handshaking, I can't do much here
+[
     [ ] [ <promise> "port" set ] unit-test
     
     [ ] [
@@ -148,3 +150,4 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
             ] with-test-context
         ] with-variable
     ] [ io-timeout? ] must-fail-with
+] drop

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

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

extra/io/windows/windows.factor

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

extra/lisp/lisp-docs.factor

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

extra/lisp/lisp-tests.factor

@@ -4,16 +4,44 @@ USING: lisp lisp.parser tools.test sequences math kernel parser ;
 
 IN: lisp.test
 
+[
     init-env
     
-"+" [ first2 + ] lisp-define
+    "#f" [ f ] lisp-define 
+    "#t" [ t ] lisp-define
     
-{ [ first2 + ] } [
+    "+" "math" "+" define-primitve
-  "+" lisp-get
+    "-" "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
-  ] with-interactive-vocabs
     ] 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

extra/lisp/lisp.factor

@@ -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 ]
@@ -35,8 +38,6 @@ DEFER: funcall
   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 ]
+  { { [ dup s-exp? ] [ body>> convert-list-form ] }
-              [ [ , ] [ ] make ] if ;
+    { [ 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 ;

extra/lisp/parser/parser-docs.factor

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

extra/lisp/parser/parser.factor

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

extra/lisp/summary.txt

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

extra/openssl/libssl/libssl.factor

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

extra/openssl/openssl.factor

@@ -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
+        SSL_CTX_load_verify_locations
-    ] [ drop ] if ;
+    ] [ 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 -- )
+    current-secure-context config>> verify>> [
         handle>>
         [ nip check-verify-result ]
         [ check-common-name ]
-    2bi ;
+        2bi
+    ] [ 2drop ] if ;
 
 openssl secure-socket-backend set-global

extra/openssl/tags.txt

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

extra/regexp4/regexp4-tests.factor

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

extra/regexp4/regexp4.factor

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

extra/shuffle/shuffle.factor

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

extra/strings/lib/lib.factor

@@ -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? [
+    dup empty? [ unclip ch>upper prefix ] unless ;
-        unclip ch>upper 1string prepend
-    ] 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 ;

extra/tools/test/ui/ui.factor

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

extra/ui/tools/listener/listener.factor

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

extra/webapps/pastebin/pastebin.factor

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

vm/Config.netbsd

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