diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index b0a279c11b..4aa2088143 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/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? ] diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 059129f22e..11b9bf4bf4 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -12,31 +12,32 @@ GENERIC: cursor-write ( obj cursor -- ) ERROR: cursor-ended cursor ; : cursor-get ( cursor -- obj ) - dup cursor-done? - [ cursor-ended ] [ cursor-get-unsafe ] if ; inline + 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 +: find-done? ( cursor quot -- ? ) + over cursor-done? + [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; 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 - dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline + [ cursor-until ] [ drop ] 2bi + 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 - to-sequence boa ; inline + [ [ length ] keep new-resizable ] keep + to-sequence boa ; inline : transform ( seq quot transformer -- newseq ) - [ [ >input ] [ >output ] bi ] 2dip - [ call ] [ 2drop freeze ] 3bi ; inline + [ [ >input ] [ >output ] bi ] 2dip + [ call ] + [ 2drop freeze ] 3bi ; inline : map ( seq quot -- ) [ cursor-map ] transform ; inline : filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 5d4149867b..ded10b66cb 100644 --- a/extra/fuel/fuel.factor +++ b/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 - dup require dup scaffold-help vocab-docs-path - (normalize-path) fuel-eval-set-result ; + [ fuel-scaffold-name dup require dup scaffold-help ] with-scope + vocab-docs-path (normalize-path) fuel-eval-set-result ; : fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ; diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor index 2c26188e04..a591fe9ce0 100644 --- a/extra/irc/client/internals/internals-tests.factor +++ b/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" + [ 2drop ] >>connect + [ + (connect-irc) + (do-login) + irc> stream>> out>> lines>> + (terminate-irc) + ] with-irc +] unit-test + ! Test join [ { "JOIN #factortest" } [ "#factortest" %join %pop-output-line diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index 0a4fe11830..1b4a4550dc 100644 --- a/extra/irc/client/internals/internals.factor +++ b/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 ; diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 8835e3d8a6..4e841ec95e 100644 --- a/extra/managed-server/chat/chat.factor +++ b/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 ] - [ "Unknown command: " prepend print flush ] if + [ send-line ] + [ "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 ; : ( 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 diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el index ac400c5622..b1c4462503 100644 --- a/misc/fuel/fuel-scaffold.el +++ b/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) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 61aa2b7cdd..3fc16e7af6 100644 --- a/misc/fuel/fuel-syntax.el +++ b/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"))