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

basis/bootstrap/image/image.factor

@@ -127,7 +127,8 @@ SYMBOL: jit-word-call
 SYMBOL: jit-push-literal
 SYMBOL: jit-push-immediate
 SYMBOL: jit-if-word
-SYMBOL: jit-if-jump
+SYMBOL: jit-if-1
+SYMBOL: jit-if-2
 SYMBOL: jit-dispatch-word
 SYMBOL: jit-dispatch
 SYMBOL: jit-dip-word
@@ -157,7 +158,7 @@ SYMBOL: undefined-quot
         { jit-word-call 27 }
         { jit-push-literal 28 }
         { jit-if-word 29 }
-        { jit-if-jump 30 }
+        { jit-if-1 30 }
         { jit-dispatch-word 31 }
         { jit-dispatch 32 }
         { jit-epilog 33 }
@@ -172,6 +173,7 @@ SYMBOL: undefined-quot
         { jit-2dip 47 }
         { jit-3dip-word 48 }
         { jit-3dip 49 }
+        { jit-if-2 50 }
         { undefined-quot 60 }
     } ; inline
 
@@ -472,7 +474,8 @@ M: quotation '
         jit-push-literal
         jit-push-immediate
         jit-if-word
-        jit-if-jump
+        jit-if-1
+        jit-if-2
         jit-dispatch-word
         jit-dispatch
         jit-dip-word

basis/bootstrap/stage2.factor

@@ -32,8 +32,8 @@ SYMBOL: bootstrap-time
 : count-words ( pred -- )
     all-words swap count number>string write ;
 
-: print-time ( us -- )
+: print-time ( ms -- )
-    1000000 /i
+    1000 /i
     60 /mod swap
     number>string write
     " minutes and " write number>string write " seconds." print ;
@@ -52,7 +52,7 @@ SYMBOL: bootstrap-time
 
 [
     ! We time bootstrap
-    micros
+    millis
 
     default-image-name "output-image" set-global
 
@@ -77,7 +77,7 @@ SYMBOL: bootstrap-time
     [
         load-components
 
-        micros over - core-bootstrap-time set-global
+        millis over - core-bootstrap-time set-global
 
         run-bootstrap-init
     ] with-compiler-errors
@@ -100,7 +100,7 @@ SYMBOL: bootstrap-time
             ] [ print-error 1 exit ] recover
         ] set-boot-quot
 
-        micros swap - bootstrap-time set-global
+        millis swap - bootstrap-time set-global
         print-report
 
         "output-image" get save-image-and-exit

basis/cpu/ppc/bootstrap.factor

@@ -82,15 +82,16 @@ big-endian on
     BLRL ;
 
 [
-    0 3 LOAD32
+    3 ds-reg 0 LWZ
-    6 ds-reg 0 LWZ
-    0 6 \ f tag-number CMPI
-    2 BNE
-    3 3 4 ADDI
-    3 3 0 LWZ
     ds-reg dup 4 SUBI
-    jit-jump-quot
+    0 3 \ f tag-number CMPI
-] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
+    2 BNE
+    0 B
+] rc-relative-ppc-3 rt-xt 3 jit-if-1 jit-define
+
+[
+    0 B
+] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define
 
 [
     0 3 LOAD32
@@ -103,9 +104,6 @@ big-endian on
     jit-jump-quot
 ] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define
 
-! These should not clobber r3 since we store a quotation in there
-! in jit-dip
-
 : jit->r ( -- )
     4 ds-reg 0 LWZ
     ds-reg dup 4 SUBI
@@ -152,30 +150,23 @@ big-endian on
     5 ds-reg -4 STW
     6 ds-reg -8 STW ;
 
-: prepare-dip ( -- )
-    0 3 LOAD32
-    3 3 0 LWZ ;
-
 [
-    prepare-dip
     jit->r
-    jit-call-quot
+    0 BL
     jit-r>
-] rc-absolute-ppc-2/2 rt-literal 1 jit-dip jit-define
+] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define
 
 [
-    prepare-dip
     jit-2>r
-    jit-call-quot
+    0 BL
     jit-2r>
-] rc-absolute-ppc-2/2 rt-literal 1 jit-2dip jit-define
+] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define
 
 [
-    prepare-dip
     jit-3>r
-    jit-call-quot
+    0 BL
     jit-3r>
-] rc-absolute-ppc-2/2 rt-literal 1 jit-3dip jit-define
+] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define
 
 [
     0 1 lr-save stack-frame + LWZ

basis/cpu/x86/assembler/assembler.factor

@@ -308,18 +308,21 @@ M: operand MOV HEX: 88 2-operand ;
 ! Control flow
 GENERIC: JMP ( op -- )
 : (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
+M: f JMP (JMP) 2drop ;
 M: callable JMP (JMP) rel-word ;
 M: label JMP (JMP) label-fixup ;
 M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 
 GENERIC: CALL ( op -- )
 : (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
+M: f CALL (CALL) 2drop ;
 M: callable CALL (CALL) rel-word ;
 M: label CALL (CALL) label-fixup ;
 M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
 
 GENERIC# JUMPcc 1 ( addr opcode -- )
 : (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
+M: f JUMPcc nip (JUMPcc) drop ;
 M: callable JUMPcc (JUMPcc) rel-word ;
 M: label JUMPcc (JUMPcc) label-fixup ;
 

basis/cpu/x86/bootstrap.factor

@@ -45,22 +45,23 @@ big-endian off
 ] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
 
 [
-    (JMP) drop
+    f JMP
 ] rc-relative rt-xt 1 jit-word-jump jit-define
 
 [
-    (CALL) drop
+    f CALL
 ] rc-relative rt-xt 1 jit-word-call jit-define
 
 [
-    arg1 0 MOV                                 ! load addr of true quotation
     arg0 ds-reg [] MOV                         ! load boolean
     ds-reg bootstrap-cell SUB                  ! pop boolean
-    arg0 \ f tag-number CMP                    ! compare it with f
+    arg0 \ f tag-number CMP                    ! compare boolean with f
-    arg0 arg1 [] CMOVNE                        ! load true branch if not equal
+    f JNE                                      ! jump to true branch if not equal
-    arg0 arg1 bootstrap-cell [+] CMOVE         ! load false branch if equal
+] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
-    arg0 quot-xt-offset [+] JMP                ! jump to quotation-xt
+
-] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
+[
+    f JMP                                      ! jump to false branch if equal
+] rc-relative rt-xt 1 jit-if-2 jit-define
 
 [
     arg1 0 MOV                                 ! load dispatch table
@@ -73,79 +74,71 @@ big-endian off
     arg0 quot-xt-offset [+] JMP                ! execute branch
 ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
 
-! The jit->r words cannot clobber arg0
-
 : jit->r ( -- )
     rs-reg bootstrap-cell ADD
-    temp-reg ds-reg [] MOV
+    arg0 ds-reg [] MOV
     ds-reg bootstrap-cell SUB
-    rs-reg [] temp-reg MOV ;
+    rs-reg [] arg0 MOV ;
 
 : jit-2>r ( -- )
     rs-reg 2 bootstrap-cells ADD
-    temp-reg ds-reg [] MOV
+    arg0 ds-reg [] MOV
     arg1 ds-reg -1 bootstrap-cells [+] MOV
     ds-reg 2 bootstrap-cells SUB
-    rs-reg [] temp-reg MOV
+    rs-reg [] arg0 MOV
     rs-reg -1 bootstrap-cells [+] arg1 MOV ;
 
 : jit-3>r ( -- )
     rs-reg 3 bootstrap-cells ADD
-    temp-reg ds-reg [] MOV
+    arg0 ds-reg [] MOV
     arg1 ds-reg -1 bootstrap-cells [+] MOV
     arg2 ds-reg -2 bootstrap-cells [+] MOV
     ds-reg 3 bootstrap-cells SUB
-    rs-reg [] temp-reg MOV
+    rs-reg [] arg0 MOV
     rs-reg -1 bootstrap-cells [+] arg1 MOV
     rs-reg -2 bootstrap-cells [+] arg2 MOV ;
 
 : jit-r> ( -- )
     ds-reg bootstrap-cell ADD
-    temp-reg rs-reg [] MOV
+    arg0 rs-reg [] MOV
     rs-reg bootstrap-cell SUB
-    ds-reg [] temp-reg MOV ;
+    ds-reg [] arg0 MOV ;
 
 : jit-2r> ( -- )
     ds-reg 2 bootstrap-cells ADD
-    temp-reg rs-reg [] MOV
+    arg0 rs-reg [] MOV
     arg1 rs-reg -1 bootstrap-cells [+] MOV
     rs-reg 2 bootstrap-cells SUB
-    ds-reg [] temp-reg MOV
+    ds-reg [] arg0 MOV
     ds-reg -1 bootstrap-cells [+] arg1 MOV ;
 
 : jit-3r> ( -- )
     ds-reg 3 bootstrap-cells ADD
-    temp-reg rs-reg [] MOV
+    arg0 rs-reg [] MOV
     arg1 rs-reg -1 bootstrap-cells [+] MOV
     arg2 rs-reg -2 bootstrap-cells [+] MOV
     rs-reg 3 bootstrap-cells SUB
-    ds-reg [] temp-reg MOV
+    ds-reg [] arg0 MOV
     ds-reg -1 bootstrap-cells [+] arg1 MOV
     ds-reg -2 bootstrap-cells [+] arg2 MOV ;
 
 [
-    arg0 0 MOV                                 ! load quotation addr
-    arg0 arg0 [] MOV                           ! load quotation
     jit->r
-    arg0 quot-xt-offset [+] CALL               ! call quotation
+    f CALL
     jit-r>
-] rc-absolute-cell rt-literal 1 rex-length + jit-dip jit-define
+] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
 
 [
-    arg0 0 MOV                                 ! load quotation addr
-    arg0 arg0 [] MOV                           ! load quotation
     jit-2>r
-    arg0 quot-xt-offset [+] CALL               ! call quotation
+    f CALL
     jit-2r>
-] rc-absolute-cell rt-literal 1 rex-length + jit-2dip jit-define
+] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
 
 [
-    arg0 0 MOV                                 ! load quotation addr
-    arg0 arg0 [] MOV                           ! load quotation
     jit-3>r                                    
-    arg0 quot-xt-offset [+] CALL               ! call quotation
+    f CALL
     jit-3r>
-] rc-absolute-cell rt-literal 1 rex-length + jit-3dip jit-define
+] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
 
 [
     stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame

basis/io/windows/nt/backend/backend.factor

@@ -48,12 +48,12 @@ M: winnt add-completion ( win32-handle -- )
         } cond
     ] with-timeout ;
 
-:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? )
+:: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
     master-completion-port get-global
     0 <int> [ ! bytes
         f <void*> ! key
         f <void*> [ ! overlapped
-            ms INFINITE or ! timeout
+            us 1000 /i INFINITE or ! timeout
             GetQueuedCompletionStatus zero?
         ] keep *void*
     ] keep *int spin ;
@@ -61,7 +61,7 @@ M: winnt add-completion ( win32-handle -- )
 : resume-callback ( result overlapped -- )
     pending-overlapped get-global delete-at* drop resume-with ;
 
-: handle-overlapped ( timeout -- ? )
+: handle-overlapped ( us -- ? )
     wait-for-overlapped [
         dup [
             >r drop GetLastError 1array r> resume-callback t
@@ -75,7 +75,7 @@ M: winnt add-completion ( win32-handle -- )
 M: win32-handle cancel-operation
     [ check-disposed ] [ handle>> CancelIo drop ] bi ;
 
-M: winnt io-multiplex ( ms -- )
+M: winnt io-multiplex ( us -- )
     handle-overlapped [ 0 io-multiplex ] when ;
 
 M: winnt init-io ( -- )

basis/present/present-docs.factor

@@ -8,6 +8,6 @@ ARTICLE: "present" "Converting objects to human-readable strings"
 HELP: present
 { $values { "object" object } { "string" string } }
 { $contract "Outputs a human-readable string from an object." }
-{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $link "urls" } " vocabularies." } ;
+{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $vocab-link "html.components" } " or " { $vocab-link "urls" } " vocabularies." } ;
 
 ABOUT: "present"

basis/sequences/deep/deep-tests.factor

@@ -4,11 +4,11 @@ IN: sequences.deep.tests
 
 [ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test
 
-[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find-from ] unit-test
+[ "foo" t ] [ { { "foo" } "bar" } [ string? ] (deep-find) ] unit-test
 
-[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find-from ] unit-test
+[ f f ] [ { { "foo" } "bar" } [ number? ] (deep-find) ] unit-test
 
-[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find-from ] unit-test
+[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] (deep-find) ] unit-test
 
 : change-something ( seq -- newseq )
     dup array? [ "hi" suffix ] [ "hello" append ] if ;

basis/threads/threads.factor

@@ -89,7 +89,7 @@ PRIVATE>
     f >>state
     check-registered 2array run-queue push-front ;
 
-: sleep-time ( -- ms/f )
+: sleep-time ( -- us/f )
     {
         { [ run-queue deque-empty? not ] [ 0 ] }
         { [ sleep-queue heap-empty? ] [ f ] }

core/io/backend/backend.factor

@@ -8,7 +8,7 @@ SYMBOL: io-backend
 
 SINGLETON: c-io-backend
 
-c-io-backend io-backend set-global
+io-backend global [ c-io-backend or ] change-at
 
 HOOK: init-io io-backend ( -- )
 
@@ -20,7 +20,7 @@ HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
     [ utf8 <encoder> output-stream set-global ]
     [ utf8 <encoder> error-stream set-global ] tri* ;
 
-HOOK: io-multiplex io-backend ( ms -- )
+HOOK: io-multiplex io-backend ( us -- )
 
 HOOK: normalize-directory io-backend ( str -- newstr )
 

core/system/system-docs.factor

@@ -12,6 +12,7 @@ ARTICLE: "system" "System interface"
 { $subsection image }
 "Getting the current time:"
 { $subsection micros }
+{ $subsection millis }
 "Exiting the Factor VM:"
 { $subsection exit } ;
 
@@ -70,7 +71,7 @@ HELP: micros ( -- us )
 { $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
 
 HELP: millis ( -- ms )
-{ $values { "us" integer } }
+{ $values { "ms" integer } }
 { $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." }
 { $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
 

extra/irc/client/client-tests.factor

@@ -169,6 +169,20 @@ M: mb-writer dispose drop ;
   ] unit-test
 ] with-irc
 
+[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [
+      "#factortest" <irc-channel-chat>
+          H{ { "ircuser" +normal+ } } clone >>participants
+      [ %add-named-chat ] keep
+      ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
+      ":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line
+      ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
+      ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
+      ":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line
+      ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
+      participants>>
+  ] unit-test
+] with-irc
+
 ! Namelist change notification
 [ { T{ participant-changed f f f f } } [
       "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
@@ -195,3 +209,11 @@ M: mb-writer dispose drop ;
       [ participant-changed? ] read-matching-message
   ] unit-test
 ] with-irc
+
+! Mode change
+[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [
+      "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+      ":ircserver.net MODE #factortest +o ircuser" %push-line
+      [ participant-changed? ] read-matching-message
+  ] unit-test
+] with-irc

extra/irc/client/client.factor

@@ -32,7 +32,7 @@ TUPLE: irc-client profile stream in-messages out-messages
 
 TUPLE: irc-chat in-messages client ;
 TUPLE: irc-server-chat < irc-chat ;
-TUPLE: irc-channel-chat < irc-chat name password timeout participants ;
+TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ;
 TUPLE: irc-nick-chat < irc-chat name ;
 SYMBOL: +server-chat+
 
@@ -55,7 +55,7 @@ SYMBOL: +nick+
      <mailbox> f irc-server-chat boa ;
 
 : <irc-channel-chat> ( name -- irc-channel-chat )
-     [ <mailbox> f ] dip f 60 seconds H{ } clone
+     [ <mailbox> f ] dip f 60 seconds H{ } clone t
      irc-channel-chat boa ;
 
 : <irc-nick-chat> ( name -- irc-nick-chat )
@@ -148,7 +148,9 @@ M: irc-chat to-chat in-messages>> mailbox-put ;
 : change-participant-mode ( channel mode nick -- )
     rot chat>
     [ participants>> set-at ]
-    [ [ [ +mode+ ] dip <participant-changed> ] dip to-chat ] 3bi ; ! FIXME
+    [ [ participant-changed new
+        [ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
+    3bi ; ! FIXME
 
 DEFER: me?
 
@@ -208,7 +210,7 @@ M: broadcast-forward forward-message
 GENERIC: process-message ( irc-message -- )
 M: object      process-message drop ; 
 M: logged-in   process-message
-    name>> f irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
+    name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
     values [ initialize-chat ] each ;
 M: ping        process-message trailing>> /PONG ;
 M: nick-in-use process-message name>> "_" append /NICK ;
@@ -231,11 +233,11 @@ M: quit process-message
 M: nick process-message
     [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
 
-! M: mode process-message ( mode -- )
+M: mode process-message ( mode -- )
-!    [ channel-mode? ] keep and [
+    [ channel-mode? ] keep and [
-!        [ name>> ] [ mode>> ] [ parameter>> ] tri
+        [ name>> ] [ mode>> ] [ parameter>> ] tri
-!        [ change-participant-mode ] [ 2drop ] if*
+        [ change-participant-mode ] [ 2drop ] if*
-!    ] when* ;
+    ] when* ;
 
 : >nick/mode ( string -- nick mode )
     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@@ -244,12 +246,24 @@ M: nick process-message
     trailing>> [ blank? ] trim " " split
     [ >nick/mode 2array ] map >hashtable ;
 
+: maybe-clean-participants ( channel-chat -- )
+    dup clean-participants>> [
+        H{ } clone >>participants f >>clean-participants
+    ] when drop ;
+
 M: names-reply process-message
     [ names-reply>participants ] [ channel>> chat> ] bi [
-        [ (>>participants) ]
+        [ maybe-clean-participants ] 
-        [ [ f f f <participant-changed> ] dip name>> to-chat ] bi
+        [ participants>> 2array assoc-combine ]
+        [ (>>participants) ] tri
     ] [ drop ] if* ;
 
+M: end-of-names process-message
+    channel>> chat> [
+        t >>clean-participants
+        [ f f f <participant-changed> ] dip name>> to-chat
+    ] when* ;
+
 ! ======================================
 ! Client message handling
 ! ======================================

extra/irc/messages/messages.factor

@@ -20,6 +20,7 @@ TUPLE: nick-in-use < irc-message name ;
 TUPLE: notice < irc-message type ;
 TUPLE: mode < irc-message name mode parameter ;
 TUPLE: names-reply < irc-message who channel ;
+TUPLE: end-of-names < irc-message who channel ;
 TUPLE: unhandled < irc-message ;
 
 : <irc-client-message> ( command parameters trailing -- irc-message )
@@ -85,6 +86,9 @@ M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
 M: names-reply >>command-parameters ( names-reply params -- names-reply )
     first3 nip [ >>who ] [ >>channel ] bi* ;
 
+M: end-of-names >>command-parameters ( names-reply params -- names-reply )
+    first2 [ >>who ] [ >>channel ] bi* ;
+
 M: mode >>command-parameters ( mode params -- mode )
     dup length 3 = [
         first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
@@ -159,6 +163,7 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
             { "001"     [ logged-in ] }
             { "433"     [ nick-in-use ] }
             { "353"     [ names-reply ] }
+            { "366"     [ end-of-names ] }
             { "JOIN"    [ join ] }
             { "PART"    [ part ] }
             { "NICK"    [ nick ] }

extra/irc/ui/commandparser/commandparser.factor

@@ -5,8 +5,6 @@ USING: kernel vocabs.loader sequences strings splitting words irc.messages ;
 
 IN: irc.ui.commandparser
 
-"irc.ui.commands" require
-
 : command ( string string -- string command )
     [ "say" ] when-empty
     dup "irc.ui.commands" lookup

extra/irc/ui/commands/commands.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 William Schlieper
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: accessors kernel arrays irc.client irc.messages irc.ui namespaces ;
+USING: accessors kernel sequences arrays irc.client
+       irc.messages irc.ui namespaces ;
 
 IN: irc.ui.commands
 
@@ -10,6 +11,9 @@ IN: irc.ui.commands
     [ window>> client>> profile>> nickname>> <own-message> print-irc ]
     [ chat>> speak ] 2bi ;
 
+: me ( string -- ) ! Placeholder until I make /me look different
+    "ACTION " 1 prefix prepend 1 suffix say ;
+
 : join ( string -- )
     irc-tab get window>> join-channel ;
 

extra/irc/ui/ui.factor

@@ -9,7 +9,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes
        ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
        io io.styles namespaces calendar calendar.format models continuations
        irc.client irc.client.private irc.messages
-       irc.ui.commandparser irc.ui.load ;
+       irc.ui.commandparser irc.ui.load vocabs.loader ;
 
 RENAME: join sequences => sjoin
 
@@ -245,3 +245,5 @@ M: irc-tab pref-dim*
 : main-run ( -- ) run-ircui ;
 
 MAIN: main-run
+
+"irc.ui.commands" require

extra/ui/gadgets/tabs/tabs.factor

@@ -12,9 +12,9 @@ TUPLE: tabbed < frame names toggler content ;
 
 DEFER: (del-page)
 
-:: add-toggle ( model n name toggler -- )
+:: add-toggle ( n name model toggler -- )
   <frame>
-    n name toggler parent>> '[ _ _ _ (del-page) ] "X" swap <bevel-button>
+    n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>
       @right grid-add
     n model name <toggle-button> @center grid-add
   toggler swap add-gadget drop ;
@@ -23,7 +23,7 @@ DEFER: (del-page)
      [ names>> ] [ model>> ] [ toggler>> ] tri
      [ clear-gadget ] keep
      [ [ length ] keep ] 2dip
-     '[ [ _ ] 2dip _ add-toggle ] 2each ;
+     '[ _ _ add-toggle ] 2each ;
 
 : refresh-book ( tabbed -- )
     model>> [ ] change-model ;
@@ -39,8 +39,8 @@ DEFER: (del-page)
 
 : add-page ( page name tabbed -- )
     [ names>> push ] 2keep
-    [ [ model>> swap ]
+    [ [ names>> length 1 - swap ]
-      [ names>> length 1 - swap ]
+      [ model>> ]
       [ toggler>> ] tri add-toggle ]
     [ content>> swap add-gadget drop ]
     [ refresh-book ] tri ;

vm/code_heap.c

@@ -55,6 +55,8 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start)
 INLINE CELL compute_code_rel(F_REL *rel,
 	CELL code_start, CELL literals_start)
 {
+	CELL obj;
+
 	switch(REL_TYPE(rel))
 	{
 	case RT_PRIMITIVE:
@@ -66,7 +68,11 @@ INLINE CELL compute_code_rel(F_REL *rel,
 	case RT_IMMEDIATE:
 		return get(CREF(literals_start,REL_ARGUMENT(rel)));
 	case RT_XT:
-		return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt;
+		obj = get(CREF(literals_start,REL_ARGUMENT(rel)));
+		if(type_of(obj) == WORD_TYPE)
+			return (CELL)untag_word(obj)->xt;
+		else
+			return (CELL)untag_quotation(obj)->xt;
 	case RT_HERE:
 		return rel->offset + code_start + (short)REL_ARGUMENT(rel);
 	case RT_LABEL:

vm/image.c

@@ -174,21 +174,6 @@ void primitive_save_image(void)
 	save_image(unbox_native_string());
 }
 
-void strip_compiled_quotations(void)
-{
-	begin_scan();
-	CELL obj;
-	while((obj = next_object()) != F)
-	{
-		if(type_of(obj) == QUOTATION_TYPE)
-		{
-			F_QUOTATION *quot = untag_object(obj);
-			quot->compiledp = F;
-		}
-	}
-	gc_off = false;
-}
-
 void primitive_save_image_and_exit(void)
 {
 	/* We unbox this before doing anything else. This is the only point
@@ -198,9 +183,6 @@ void primitive_save_image_and_exit(void)
 
 	REGISTER_C_STRING(path);
 
-	/* This reduces deployed image size */
-	strip_compiled_quotations();
-
 	/* strip out userenv data which is set on startup anyway */
 	CELL i;
 	for(i = 0; i < FIRST_SAVE_ENV; i++)

vm/quotations.c

@@ -251,9 +251,13 @@ void jit_compile(CELL quot, bool relocate)
 				if(stack_frame)
 					EMIT(userenv[JIT_EPILOG],0);
 
+				jit_compile(array_nth(untag_object(array),i),true);
+				jit_compile(array_nth(untag_object(array),i + 1),true);
+
 				GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+				EMIT(userenv[JIT_IF_1],literals_count - 1);
 				GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
-				EMIT(userenv[JIT_IF_JUMP],literals_count - 2);
+				EMIT(userenv[JIT_IF_2],literals_count - 1);
 
 				i += 2;
 
@@ -262,6 +266,8 @@ void jit_compile(CELL quot, bool relocate)
 			}
 			else if(jit_fast_dip_p(untag_object(array),i))
 			{
+				jit_compile(obj,true);
+
 				GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
 				EMIT(userenv[JIT_DIP],literals_count - 1);
 
@@ -270,6 +276,8 @@ void jit_compile(CELL quot, bool relocate)
 			}
 			else if(jit_fast_2dip_p(untag_object(array),i))
 			{
+				jit_compile(obj,true);
+
 				GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
 				EMIT(userenv[JIT_2DIP],literals_count - 1);
 
@@ -278,6 +286,8 @@ void jit_compile(CELL quot, bool relocate)
 			}
 			else if(jit_fast_3dip_p(untag_object(array),i))
 			{
+				jit_compile(obj,true);
+
 				GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
 				EMIT(userenv[JIT_3DIP],literals_count - 1);
 
@@ -413,7 +423,8 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
 				if(stack_frame)
 					COUNT(userenv[JIT_EPILOG],i)
 
-				COUNT(userenv[JIT_IF_JUMP],i)
+				COUNT(userenv[JIT_IF_1],i)
+				COUNT(userenv[JIT_IF_2],i)
 				i += 2;
 
 				tail_call = true;

vm/run.h

@@ -41,7 +41,7 @@ typedef enum {
 	JIT_WORD_CALL,
 	JIT_PUSH_LITERAL,
 	JIT_IF_WORD,
-	JIT_IF_JUMP,
+	JIT_IF_1,
 	JIT_DISPATCH_WORD,
 	JIT_DISPATCH,
 	JIT_EPILOG,
@@ -56,6 +56,7 @@ typedef enum {
 	JIT_2DIP,
 	JIT_3DIP_WORD,
 	JIT_3DIP,
+	JIT_IF_2,
 
 	STACK_TRACES_ENV    = 59,