Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
b3fd1adb1c
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -32,8 +32,8 @@ SYMBOL: bootstrap-time
|
|||
: count-words ( pred -- )
|
||||
all-words swap count number>string write ;
|
||||
|
||||
: print-time ( us -- )
|
||||
1000000 /i
|
||||
: print-time ( ms -- )
|
||||
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
|
||||
|
|
|
|||
|
|
@ -82,15 +82,16 @@ big-endian on
|
|||
BLRL ;
|
||||
|
||||
[
|
||||
0 3 LOAD32
|
||||
6 ds-reg 0 LWZ
|
||||
0 6 \ f tag-number CMPI
|
||||
2 BNE
|
||||
3 3 4 ADDI
|
||||
3 3 0 LWZ
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
jit-jump-quot
|
||||
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define
|
||||
0 3 \ f tag-number CMPI
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 arg1 [] CMOVNE ! load true branch if not equal
|
||||
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
|
||||
arg0 quot-xt-offset [+] JMP ! jump to quotation-xt
|
||||
] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
|
||||
arg0 \ f tag-number CMP ! compare boolean with f
|
||||
f JNE ! jump to true branch if not equal
|
||||
] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 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
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
! [ channel-mode? ] keep and [
|
||||
! [ name>> ] [ mode>> ] [ parameter>> ] tri
|
||||
! [ change-participant-mode ] [ 2drop ] if*
|
||||
! ] when* ;
|
||||
M: mode process-message ( mode -- )
|
||||
[ channel-mode? ] keep and [
|
||||
[ name>> ] [ mode>> ] [ parameter>> ] tri
|
||||
[ change-participant-mode ] [ 2drop ] if*
|
||||
] 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) ]
|
||||
[ [ f f f <participant-changed> ] dip name>> to-chat ] bi
|
||||
[ maybe-clean-participants ]
|
||||
[ 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
|
||||
! ======================================
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
18
vm/image.c
18
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++)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue