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

basis/compiler/cfg/checker/checker.factor

@@ -8,7 +8,7 @@ IN: compiler.cfg.checker
 ERROR: last-insn-not-a-jump insn ;
 
 : check-last-instruction ( bb -- )
-    peek dup {
+    last dup {
         [ ##branch? ]
         [ ##dispatch? ]
         [ ##conditional-branch? ]

extra/cursors/cursors.factor

@@ -12,31 +12,32 @@ GENERIC: cursor-write ( obj cursor -- )
 ERROR: cursor-ended cursor ;
 
 : cursor-get ( cursor -- obj )
-   dup cursor-done?
+    dup cursor-done?
-   [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
+    [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
 
-: find-done? ( quot cursor -- ? )
+: find-done? ( cursor quot -- ? )
-   dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline
+    over cursor-done?
-
+    [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
-: cursor-until ( quot cursor -- )
-   [ find-done? not ]
-   [ cursor-advance drop ] bi-curry bi-curry while ; inline
 
+: cursor-until ( cursor quot -- )
+    [ find-done? not ]
+    [ drop cursor-advance ] bi-curry bi-curry while ; inline
+ 
 : cursor-each ( cursor quot -- )
-   [ f ] compose swap cursor-until ; inline
+    [ f ] compose cursor-until ; inline
 
 : cursor-find ( cursor quot -- obj ? )
-   swap [ cursor-until ] keep
+    [ cursor-until ] [ drop ] 2bi
-   dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
+    dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
 
 : cursor-any? ( cursor quot -- ? )
-   cursor-find nip ; inline
+    cursor-find nip ; inline
 
 : cursor-all? ( cursor quot -- ? )
-   [ not ] compose cursor-any? not ; inline
+    [ not ] compose cursor-any? not ; inline
 
 : cursor-map-quot ( quot to -- quot' )
-   [ [ call ] dip cursor-write ] 2curry ; inline
+    [ [ call ] dip cursor-write ] 2curry ; inline
 
 : cursor-map ( from to quot -- )
    swap cursor-map-quot cursor-each ; inline
@@ -46,10 +47,10 @@ ERROR: cursor-ended cursor ;
     [ cursor-write ] 2curry when ; inline
 
 : cursor-filter-quot ( quot to -- quot' )
-   [ cursor-write-if ] 2curry ; inline
+    [ cursor-write-if ] 2curry ; inline
 
 : cursor-filter ( from to quot -- )
-   swap cursor-filter-quot cursor-each ; inline
+    swap cursor-filter-quot cursor-each ; inline
 
 TUPLE: from-sequence { seq sequence } { n integer } ;
 
@@ -60,19 +61,19 @@ M: from-sequence cursor-done? ( cursor -- ? )
     >from-sequence< length >= ;
 
 M: from-sequence cursor-valid?
-   >from-sequence< bounds-check? not ;
+    >from-sequence< bounds-check? not ;
 
 M: from-sequence cursor-get-unsafe
-   >from-sequence< nth-unsafe ;
+    >from-sequence< nth-unsafe ;
 
 M: from-sequence cursor-advance
-   [ 1+ ] change-n drop ;
+    [ 1+ ] change-n drop ;
 
 : >input ( seq -- cursor )
-   0 from-sequence boa ; inline
+    0 from-sequence boa ; inline
 
 : iterate ( seq quot iterator -- )
-   [ >input ] 2dip call ; inline
+    [ >input ] 2dip call ; inline
 
 : each ( seq quot -- ) [ cursor-each ] iterate ; inline
 : find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
@@ -82,18 +83,19 @@ M: from-sequence cursor-advance
 TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
 
 M: to-sequence cursor-write
-   seq>> push ;
+    seq>> push ;
 
 : freeze ( cursor -- seq )
-   [ seq>> ] [ exemplar>> ] bi like ; inline
+    [ seq>> ] [ exemplar>> ] bi like ; inline
 
 : >output ( seq -- cursor )
-   [ [ length ] keep new-resizable ] keep
+    [ [ length ] keep new-resizable ] keep
-   to-sequence boa ; inline
+    to-sequence boa ; inline
 
 : transform ( seq quot transformer -- newseq )
-   [ [ >input ] [ >output ] bi ] 2dip
+    [ [ >input ] [ >output ] bi ] 2dip
-   [ call ] [ 2drop freeze ] 3bi ; inline
+    [ call ]
+    [ 2drop freeze ] 3bi ; inline
 
 : map ( seq quot -- ) [ cursor-map ] transform ; inline
 : filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline

extra/fuel/fuel.factor

@@ -134,14 +134,16 @@ PRIVATE>
 
 ! Scaffold support
 
+: fuel-scaffold-name ( devname -- )
+    [ developer-name set ] when* ;
+
 : fuel-scaffold-vocab ( root name devname -- )
-    developer-name set dup [ scaffold-vocab ] dip
+    [ fuel-scaffold-name dup [ scaffold-vocab ] dip ] with-scope
     dup require vocab-source-path (normalize-path) fuel-eval-set-result ;
 
 : fuel-scaffold-help ( name devname -- )
-    developer-name set
+    [ fuel-scaffold-name dup require dup scaffold-help ] with-scope
-    dup require dup scaffold-help vocab-docs-path
+    vocab-docs-path (normalize-path) fuel-eval-set-result ;
-    (normalize-path) fuel-eval-set-result ;
 
 : fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
 

extra/irc/client/internals/internals-tests.factor

@@ -85,6 +85,18 @@ M: mb-writer dispose drop ;
     ] with-irc
 ] unit-test
 
+! Test connect with password
+{ V{ "PASS password" "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
+    "someserver" irc-port "factorbot" "password" <irc-profile> <irc-client>
+    [ 2drop <test-stream> ] >>connect
+    [
+        (connect-irc)
+        (do-login)
+        irc> stream>> out>> lines>>
+        (terminate-irc)
+    ] with-irc
+] unit-test
+
 ! Test join
 [ { "JOIN #factortest" } [
       "#factortest" %join %pop-output-line

extra/irc/client/internals/internals.factor

@@ -16,6 +16,7 @@ IN: irc.client.internals
 
 : /NICK ( nick -- ) "NICK " prepend irc-print ;
 : /PONG ( text -- ) "PONG " prepend irc-print ;
+: /PASS ( password -- ) "PASS " prepend irc-print ;
 
 : /LOGIN ( nick -- )
     dup /NICK
@@ -44,7 +45,11 @@ IN: irc.client.internals
         in-messages>> [ irc-connected ] dip mailbox-put
     ] [ (terminate-irc) ] if* ;
 
-: (do-login) ( -- ) irc> nick>> /LOGIN ;
+: (do-login) ( -- )
+     irc>
+     [ profile>> password>> [ /PASS ] when* ]
+     [ nick>> /LOGIN ]
+     bi ;
 
 GENERIC: initialize-chat ( chat -- )
 M: irc-chat         initialize-chat drop ;

extra/managed-server/chat/chat.factor

@@ -18,6 +18,9 @@ chat-docs [ H{ } clone ] initialize
 
 CONSTANT: line-beginning "-!- "
 
+: send-line ( string -- )
+    write "\r\n" write flush ;
+
 : handle-me ( string -- )
     [
         [ "* " username " " ] dip
@@ -29,15 +32,15 @@ CONSTANT: line-beginning "-!- "
 : handle-help ( string -- )
     [
         "Commands: "
-        commands get keys natural-sort ", " join append print flush
+        commands get keys natural-sort ", " join append send-line
     ] [
         chat-docs get ?at
-        [ print flush ]
+        [ send-line ]
-        [ "Unknown command: " prepend print flush ] if
+        [ "Unknown command: " prepend send-line ] if
     ] if-empty ;
 
 : usage ( string -- )
-    chat-docs get at print flush ;
+    chat-docs get at send-line ;
 
 : username-taken-string ( username -- string )
     "The username ``" "'' is already in use; try again." surround ;
@@ -53,7 +56,7 @@ CONSTANT: line-beginning "-!- "
         "nick" usage
     ] [
         dup clients key? [
-            username-taken-string print flush
+            username-taken-string send-line
         ] [
             [ username swap warn-name-changed ]
             [ username clients rename-at ]
@@ -70,12 +73,12 @@ CONSTANT: line-beginning "-!- "
 Displays the documentation for a command.">
 "help" add-command
 
-[ drop clients keys [ "``" "''" surround ] map ", " join print flush ]
+[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
 <" Syntax: /who
 Shows the list of connected users.">
 "who" add-command
 
-[ drop gmt timestamp>rfc822 print flush ]
+[ drop gmt timestamp>rfc822 send-line ]
 <" Syntax: /time
 Returns the current GMT time."> "time" add-command
 
@@ -96,7 +99,7 @@ Disconnects a user from the chat server."> "quit" add-command
     dup " " split1 swap >lower commands get at* [
         call( string -- ) drop
     ] [
-        2drop "Unknown command: " prepend print flush
+        2drop "Unknown command: " prepend send-line
     ] if ;
 
 : <chat-server> ( port -- managed-server )
@@ -123,7 +126,7 @@ M: chat-server handle-client-disconnect
     ] "" append-outputs-as send-everyone ;
 
 M: chat-server handle-already-logged-in
-    username username-taken-string print flush ;
+    username username-taken-string send-line ;
 
 M: chat-server handle-managed-client*
     readln dup f = [ t client (>>quit?) ] when

misc/fuel/fuel-scaffold.el

@@ -26,9 +26,10 @@
   "Options for FUEL's scaffolding."
   :group 'fuel)
 
-(defcustom fuel-scaffold-developer-name user-full-name
+(defcustom fuel-scaffold-developer-name nil
   "The name to be inserted as yours in scaffold templates."
-  :type 'string
+  :type '(choice string
+                 (const :tag "Factor's value for developer-name" nil))
   :group 'fuel-scaffold)
 
 

misc/fuel/fuel-syntax.el

@@ -59,7 +59,7 @@
     "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
     "QUALIFIED-WITH:" "QUALIFIED:"
     "read-only" "RENAME:" "REQUIRE:"  "REQUIRES:"
-    "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:"
+    "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
     "TUPLE:" "t" "t?" "TYPEDEF:"
     "UNION:" "USE:" "USING:"
     "VARS:"))
@@ -109,7 +109,7 @@
   (format "\\_<\\(%s\\)?: +\\_<\\(\\w+\\)\\_>"
           (regexp-opt
            '(":" "GENERIC" "DEFER" "HOOK" "MAIN" "MATH" "POSTPONE"
-             "SYMBOL" "RENAME"))))
+             "SYMBOL" "SYNTAX" "RENAME"))))
 
 (defconst fuel-syntax--alias-definition-regex
   "^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
@@ -156,6 +156,7 @@
                                            "INTERSECTION:"
                                            "M" "MACRO" "MACRO:"
                                            "MEMO" "MEMO:" "METHOD"
+                                           "SYNTAX"
                                            "PREDICATE" "PRIMITIVE"
                                            "UNION"))