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

extra/ftp/client/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/ftp/client/client.factor

@@ -0,0 +1,138 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes.singleton combinators continuations
+io io.encodings.binary io.encodings.ascii io.files io.sockets
+kernel math math.parser sequences splitting namespaces strings ;
+IN: ftp.client
+
+TUPLE: ftp-client host port stream user password mode ;
+TUPLE: ftp-response n strings ;
+
+SINGLETON: active
+SINGLETON: passive
+
+: <ftp-response> ( -- ftp-response )
+    ftp-response new
+        V{ } clone >>strings ;
+
+: <ftp-client> ( host -- ftp-client )
+    ftp-client new
+        swap >>host
+        21 >>port
+        "anonymous" >>user
+        "factor-ftp@factorcode.org" >>password ;
+
+: add-response-line ( ftp-response string -- ftp-response )
+    over strings>> push ;
+
+: (ftp-response-code) ( str -- n )
+    3 head string>number ;
+
+: ftp-response-code ( string -- n/f )
+    dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
+
+: last-code ( ftp-response -- n )
+    strings>> peek (ftp-response-code) ;
+
+: read-response-until ( stream ftp-response n -- ftp-response )
+    >r over stream-readln
+    [ add-response-line ] [ ftp-response-code ] bi
+    r> tuck = [ drop nip ] [ read-response-until ] if ;
+
+: read-response ( stream -- ftp-response )
+    <ftp-response>
+    over stream-readln
+    [ add-response-line ] [ fourth CHAR: - = ] bi
+    [ dup last-code read-response-until ]
+    [ nip ] if dup last-code >>n ;
+
+: ftp-read ( ftp-client -- ftp-response )
+    stream>> read-response ;
+
+: ftp-send ( str ftp-client -- )
+    stream>>
+    [ stream-write ]
+    [ "\r\n" swap stream-write ]
+    [ stream-flush ] tri ;
+
+: ftp-command ( string ftp-client -- ftp-response )
+    [ ftp-send ] [ ftp-read ] bi ;
+
+: ftp-user ( ftp-client -- ftp-response )
+    [ user>> "USER " prepend ] [ ftp-command ] bi ;
+
+: ftp-password ( ftp-client -- ftp-response )
+    [ password>> "PASS " prepend ] [ ftp-command ] bi ;
+
+: ftp-set-binary ( ftp-client -- ftp-response )
+    >r "TYPE I" r> ftp-command ;
+
+: ftp-pwd ( ftp-client -- ftp-response )
+    >r "PWD" r> ftp-command ;
+
+: ftp-list ( ftp-client -- ftp-response )
+    >r "LIST" r> ftp-command ;
+
+: ftp-quit ( ftp-client -- ftp-response )
+    >r "QUIT" r> ftp-command ;
+
+: ftp-cwd ( directory ftp-client -- ftp-response )
+    >r "CWD " prepend r> ftp-command ;
+
+: ftp-retr ( filename ftp-client -- ftp-response )
+    >r "RETR " prepend r> ftp-command ;
+
+: parse-epsv ( ftp-response -- port )
+    strings>> first
+    "|" split 2 tail* first string>number ;
+
+: ftp-epsv ( ftp-client -- ftp-response )
+    >r "EPSV" r> ftp-command ;
+
+M: ftp-client dispose ( ftp-client -- )
+    [ ftp-quit drop ] [ stream>> dispose ] bi ;
+
+ERROR: ftp-error got expected ;
+: ftp-assert ( ftp-response n -- )
+    2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
+
+: ftp-connect ( ftp-client -- )
+    dup
+    [ host>> ] [ port>> ] bi <inet> ascii <client>
+    >>stream drop ;
+
+: ftp-login ( ftp-client -- )
+    {
+        [ ftp-connect ]
+        [ ftp-read 220 ftp-assert ]
+        [ ftp-user 331 ftp-assert ]
+        [ ftp-password 230 ftp-assert ]
+        [ ftp-set-binary 200 ftp-assert ]
+    } cleave ;
+
+: start-2nd ( ftp-client -- port )
+    ftp-epsv [ 229 ftp-assert ] [ parse-epsv ] bi ;
+
+: list ( ftp-client -- ftp-response )
+    dup [ host>> ] [ start-2nd ] bi <inet> ascii <client>
+    over ftp-list 150 ftp-assert
+    lines <ftp-response> swap >>strings
+    >r ftp-read 226 ftp-assert r> ;
+
+: ftp-get ( filename ftp-client -- ftp-response )
+    dup [ host>> ] [ start-2nd ] bi <inet> binary <client>
+    rot tuck
+    [ over ftp-retr 150 ftp-assert ]
+    [ binary <file-writer> stream-copy ] 2bi*
+    ftp-read dup 226 ftp-assert ;
+
+GENERIC: ftp-download ( path obj -- )
+
+M: ftp-client ftp-download ( path ftp-client -- )
+    dup ftp-login
+    [ >r parent-directory r> ftp-cwd drop ]
+    [ >r file-name r> ftp-get drop ]
+    [ dispose drop ] 2tri ;
+
+M: string ftp-download ( path string -- )
+    <ftp-client> ftp-download ;

extra/lisp/lisp-tests.factor

@@ -4,10 +4,6 @@ USING: lisp lisp.parser tools.test sequences math kernel ;
 
 IN: lisp.test
 
-{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [
-  "(foo 1 2 \"aoeu\")" lisp-string>factor
-] unit-test
-
 init-env
 
 "+" [ first2 + ] lisp-define

extra/lisp/lisp.factor

@@ -38,15 +38,18 @@ DEFER: funcall
 PRIVATE>
                    
 : split-lambda ( s-exp -- body vars )                   
-  first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline                 
+  first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
   
-: rest-lambda-vars ( seq -- n newseq )  
-  "&rest" swap [ remove ] [ index ] 2bi ;
+: rest-lambda ( body vars -- quot )  
+  "&rest" swap [ remove ] [ index ] 2bi
+  [ localize-lambda <lambda> ] dip
+  [ , cut swap [ % , ] bake , compose ] bake ;
+  
+: normal-lambda ( body vars -- quot )
+  localize-lambda <lambda> [ , compose ] bake ;
   
 : convert-lambda ( s-exp -- quot )  
-  split-lambda dup "&rest"  swap member? [ rest-lambda-vars ] [ dup length ] if
-  [ localize-lambda <lambda> ] dip
-  [ , cut [ dup length firstn ] dip dup empty? [ drop ] when  , ] bake ;
+  split-lambda dup "&rest"  swap member? [ rest-lambda ] [ normal-lambda ] if ;
   
 : convert-quoted ( s-exp -- quot )  
   second [ , ] bake ;
@@ -64,10 +67,9 @@ PRIVATE>
     [ drop convert-general-form ] if ;
   
 : convert-form ( lisp-form -- quot )
-  { { [ dup s-exp? ] [ body>> convert-list-form ] }
-   [ [ , ] [ ] make ]
-  } cond ;
-  
+  dup s-exp?  [ body>> convert-list-form ]
+              [ [ , ] [ ] make ] if ;
+                
 : lisp-string>factor ( str -- quot )
   lisp-expr parse-result-ast convert-form ;