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

build-support/factor.sh

@@ -174,6 +174,7 @@ find_os() {
         CYGWIN_NT-5.2-WOW64) OS=winnt;;
         *CYGWIN_NT*) OS=winnt;;
         *CYGWIN*) OS=winnt;;
+        MINGW32*) OS=winnt;;
         *darwin*) OS=macosx;;
         *Darwin*) OS=macosx;;
         *linux*) OS=linux;;

core/classes/parser/parser.factor

@@ -6,7 +6,7 @@ IN: classes.parser
 : save-class-location ( class -- )
     location remember-class ;
 
-: create-class-in ( word -- word )
+: create-class-in ( string -- word )
     current-vocab create
     dup save-class-location
     dup predicate-word dup set-word save-location ;

extra/cursors/authors.txt

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

extra/cursors/cursors-tests.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cursors math tools.test make ;
+IN: cursors.tests
+
+[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test
+[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test
+[ f f ] [ { 2 4 } [ odd? ] find ] unit-test
+
+[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test
+[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test
+
+[ t ] [ { } [ odd? ] all? ] unit-test
+[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test
+[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test
+
+[ t ] [ { } [ odd? ] all? ] unit-test
+[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test
+[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test
+
+[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test

extra/cursors/cursors.factor

@@ -0,0 +1,99 @@
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math sequences sequences.private ;
+IN: cursors
+
+GENERIC: cursor-done? ( cursor -- ? )
+GENERIC: cursor-get-unsafe ( cursor -- obj )
+GENERIC: cursor-advance ( cursor -- )
+GENERIC: cursor-valid? ( cursor -- ? )
+GENERIC: cursor-write ( obj cursor -- )
+
+ERROR: cursor-ended cursor ;
+
+: cursor-get ( cursor -- obj )
+   dup cursor-done?
+   [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
+
+: find-done? ( quot cursor -- ? )
+   dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline
+
+: cursor-until ( quot cursor -- )
+   [ find-done? not ]
+   [ cursor-advance drop ] bi-curry bi-curry while ; inline
+
+: cursor-each ( cursor quot -- )
+   [ f ] compose swap cursor-until ; inline
+
+: cursor-find ( cursor quot -- obj ? )
+   swap [ cursor-until ] keep
+   dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
+
+: cursor-any? ( cursor quot -- ? )
+   cursor-find nip ; inline
+
+: cursor-all? ( cursor quot -- ? )
+   [ not ] compose cursor-any? not ; inline
+
+: cursor-map-quot ( quot to -- quot' )
+   [ [ call ] dip cursor-write ] 2curry ; inline
+
+: cursor-map ( from to quot -- )
+   swap cursor-map-quot cursor-each ; inline
+
+: cursor-write-if ( obj quot to -- )
+    [ over [ call ] dip ] dip
+    [ cursor-write ] 2curry when ; inline
+
+: cursor-filter-quot ( quot to -- quot' )
+   [ cursor-write-if ] 2curry ; inline
+
+: cursor-filter ( from to quot -- )
+   swap cursor-filter-quot cursor-each ; inline
+
+TUPLE: from-sequence { seq sequence } { n integer } ;
+
+: >from-sequence< ( from-sequence -- n seq )
+    [ n>> ] [ seq>> ] bi ; inline
+
+M: from-sequence cursor-done? ( cursor -- ? )
+    >from-sequence< length >= ;
+
+M: from-sequence cursor-valid?
+   >from-sequence< bounds-check? not ;
+
+M: from-sequence cursor-get-unsafe
+   >from-sequence< nth-unsafe ;
+
+M: from-sequence cursor-advance
+   [ 1+ ] change-n drop ;
+
+: >input ( seq -- cursor )
+   0 from-sequence boa ; inline
+
+: iterate ( seq quot iterator -- )
+   [ >input ] 2dip call ; inline
+
+: each ( seq quot -- ) [ cursor-each ] iterate ; inline
+: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
+: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline
+: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline
+
+TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
+
+M: to-sequence cursor-write
+   seq>> push ;
+
+: freeze ( cursor -- seq )
+   [ seq>> ] [ exemplar>> ] bi like ; inline
+
+: >output ( seq -- cursor )
+   [ [ length ] keep new-resizable ] keep
+   to-sequence boa ; inline
+
+: transform ( seq quot transformer -- newseq )
+   [ [ >input ] [ >output ] bi ] 2dip
+   [ call ] [ 2drop freeze ] 3bi ; inline
+
+: map ( seq quot -- ) [ cursor-map ] transform ; inline
+: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline

extra/managed-server/authors.txt

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

extra/managed-server/chat/authors.txt

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

extra/managed-server/chat/chat.factor

@@ -0,0 +1,103 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators combinators.smart
+destructors fry io io.encodings.utf8 kernel managed-server
+namespaces parser sequences sorting splitting strings.parser
+unicode.case unicode.categories calendar calendar.format
+locals multiline ;
+IN: managed-server.chat
+
+TUPLE: chat-server < managed-server ;
+
+SYMBOL: commands
+commands [ H{ } clone ] initialize
+
+SYMBOL: chat-docs
+chat-docs [ H{ } clone ] initialize
+
+CONSTANT: line-beginning "-!- "
+
+: handle-me ( string -- )
+    [
+        [ "* " username " " ] dip
+    ] "" append-outputs-as send-everyone ;
+
+: handle-quit ( string -- )
+    client [ (>>object) ] [ t >>quit? drop ] bi ;
+
+: handle-help ( string -- )
+    [
+        "Commands: "
+        commands get keys natural-sort ", " join append print flush
+    ] [
+        chat-docs get ?at
+        [ print flush ]
+        [ "Unknown command: " prepend print flush ] if
+    ] if-empty ;
+
+:: add-command ( quot docs key -- )
+    quot key commands get set-at
+    docs key chat-docs get set-at ;
+
+[ handle-help ]
+<" Syntax: /help [command]
+Displays the documentation for a command.">
+"help" add-command
+
+[ drop clients keys ", " join print flush ]
+<" Syntax: /who
+Shows the list of connected users.">
+"who" add-command
+
+[ drop gmt timestamp>rfc822 print flush ]
+<" Syntax: /time
+Returns the current GMT time."> "time" add-command
+
+[ handle-me ]
+<" Syntax: /me action">
+"me" add-command
+
+[ handle-quit ]
+<" Syntax: /quit [message]
+Disconnects a user from the chat server."> "quit" add-command
+
+: handle-command ( string -- )
+    dup " " split1 swap >lower commands get at* [
+        call( string -- ) drop
+    ] [
+        2drop "Unknown command: " prepend print flush
+    ] if ;
+
+: <chat-server> ( port -- managed-server )
+    "chat-server" chat-server new-managed-server
+        utf8 >>encoding ;
+
+: handle-chat ( string -- )
+    [
+        [ username ": " ] dip
+    ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-login
+    "Username: " write flush
+    readln ;
+
+M: chat-server handle-client-join
+    [
+        line-beginning username " has joined"
+    ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-client-disconnect
+    [
+        line-beginning username " has quit  "
+        client object>> dup [ "\"" dup surround ] when
+    ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-already-logged-in
+    "The username ``" username "'' is already in use; try again."
+    3append print flush ;
+
+M: chat-server handle-managed-client*
+    readln dup f = [ t client (>>quit?) ] when
+    [
+        "/" ?head [ handle-command ] [ handle-chat ] if
+    ] unless-empty ;

extra/managed-server/managed-server.factor

@@ -0,0 +1,80 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar continuations destructors io
+io.encodings.binary io.servers.connection io.sockets
+io.streams.duplex fry kernel locals math math.ranges multiline
+namespaces prettyprint random sequences sets splitting threads
+tools.continuations ;
+IN: managed-server
+
+TUPLE: managed-server < threaded-server clients ;
+
+TUPLE: managed-client
+input-stream output-stream local-address remote-address
+username object quit? ;
+
+HOOK: handle-login threaded-server ( -- username )
+HOOK: handle-already-logged-in managed-server ( -- )
+HOOK: handle-client-join managed-server ( -- )
+HOOK: handle-client-disconnect managed-server ( -- )
+HOOK: handle-managed-client* managed-server ( -- )
+
+M: managed-server handle-already-logged-in ;
+M: managed-server handle-client-join ;
+M: managed-server handle-client-disconnect ;
+M: managed-server handle-managed-client* ;
+
+: server ( -- managed-client ) managed-server get ;
+: client ( -- managed-client ) managed-client get ;
+: clients ( -- assoc ) server clients>> ;
+: client-streams ( -- assoc ) clients values ;
+: username ( -- string ) client username>> ;
+
+: send-everyone ( seq -- )
+    [ client-streams ] dip '[
+        output-stream>> [ _ print flush ] with-output-stream*
+    ] each ;
+
+ERROR: already-logged-in username ;
+
+<PRIVATE
+
+: <managed-client> ( username -- managed-client )
+    managed-client new
+        swap >>username
+        input-stream get >>input-stream
+        output-stream get >>output-stream
+        local-address get >>local-address
+        remote-address get >>remote-address ;
+
+: check-logged-in ( username -- username )
+    dup server clients>> key? [
+        [ server ] dip
+        [ handle-already-logged-in ] [ already-logged-in ] bi
+    ] when ;
+
+: add-managed-client ( -- )
+    client username check-logged-in clients set-at ;
+
+: delete-managed-client ( -- )
+    username server clients>> delete-at ;
+
+: handle-managed-client ( -- )
+    [ [ handle-managed-client* client quit?>> not ] loop ]
+    [ delete-managed-client handle-client-disconnect ]
+    [ ] cleanup ;
+
+PRIVATE>
+
+M: managed-server handle-client*
+    managed-server set
+    handle-login <managed-client> managed-client set
+    add-managed-client
+    handle-client-join handle-managed-client ;
+
+: new-managed-server ( port name class -- server )
+    new-threaded-server
+        swap >>name
+        swap >>insecure
+        f >>timeout
+        H{ } clone >>clients ; inline

extra/nurbs/nurbs-tests.factor

@@ -11,13 +11,13 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
 ! unit circle as NURBS
 3 {
     { 1.0 0.0 1.0 }
-    { $ √2/2 $ √2/2 $ √2/2 }
+    ${ √2/2 √2/2 √2/2 }
     { 0.0 1.0 1.0 }
-    { $ -√2/2 $ √2/2 $ √2/2 }
+    ${ -√2/2 √2/2 √2/2 }
     { -1.0 0.0 1.0 }
-    { $ -√2/2 $ -√2/2 $ √2/2 }
+    ${ -√2/2 -√2/2 √2/2 }
     { 0.0 -1.0 1.0 }
-    { $ √2/2 $ -√2/2 $ √2/2 }
+    ${ √2/2 -√2/2 √2/2 }
     { 1.0 0.0 1.0 }
 } { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set
 
@@ -26,7 +26,7 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
 [ t ] [ test-nurbs get 0.5   eval-nurbs {  -1.0   0.0 } 0.00001 v~ ] unit-test
 [ t ] [ test-nurbs get 0.75  eval-nurbs {   0.0  -1.0 } 0.00001 v~ ] unit-test
 
-[ t ] [ test-nurbs get 0.125 eval-nurbs { $  √2/2 $  √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.125 eval-nurbs ${ √2/2 √2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $  √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.375 eval-nurbs ${ -√2/2 √2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.625 eval-nurbs ${ -√2/2 -√2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.875 eval-nurbs { $  √2/2 $ -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.875 eval-nurbs ${ √2/2 -√2/2 } 0.00001 v~ ] unit-test