! A simple IRC client written in Factor.
+IN: irc
+USE: generic
USE: stdio
USE: namespaces
USE: streams
USE: kernel
USE: threads
+USE: lists
+USE: strings
+USE: words
+USE: math
SYMBOL: irc-stream
+SYMBOL: channels
SYMBOL: channel
+SYMBOL: nickname
-: irc-write ( str -- )
- irc-stream get fwrite ;
+: irc-write ( s -- ) irc-stream get fwrite ;
+: irc-print ( s -- ) irc-stream get fprint irc-stream get fflush ;
-: irc-print ( str -- )
- irc-stream get fprint irc-stream get fflush ;
-
-: join ( chan -- )
- dup channel set "JOIN " irc-write irc-print ;
+: nick ( nick -- )
+ dup nickname set "NICK " irc-write irc-print ;
: login ( nick -- )
- "NICK " irc-write dup irc-print
+ dup nick
"USER " irc-write irc-write
" hostname servername :irc.factor" irc-print ;
-: connect ( channel nick server -- )
- 6667 <client> irc-stream set login join ;
+: connect ( server -- ) 6667 <client> irc-stream set ;
+
+: write-highlighted ( line -- )
+ dup nickname get index-of -1 =
+ f [ [ "ansi-fg" | "3" ] ] ? write-attr ;
+
+: extract-nick ( line -- nick )
+ "!" split1 drop ;
+
+: write-nick ( line -- )
+ "!" split1 drop [ [ "bold" | t ] ] write-attr ;
+
+GENERIC: irc-display
+PREDICATE: string privmsg "PRIVMSG" index-of -1 > ;
+PREDICATE: string action "ACTION" index-of -1 > ;
+
+M: string irc-display ( line -- )
+ print ;
+
+M: privmsg irc-display ( line -- )
+ "PRIVMSG" split1 >r write-nick r>
+ write-highlighted terpri flush ;
+
+! Doesn't look good
+! M: action irc-display ( line -- )
+! " * " write
+! "ACTION" split1 >r write-nick r>
+! write-highlighted terpri flush ;
: in-loop ( -- )
- irc-stream get freadln [ print in-loop ] when* ;
+ irc-stream get freadln [ irc-display in-loop ] when* ;
+
+: input-thread ( -- ) [ in-loop ] in-thread ;
+: disconnect ( -- ) irc-stream get fclose ;
-: say ( input -- )
- "PRIVMSG " irc-write
- channel get irc-write
- " :" irc-write irc-print ;
+: command ( line -- )
+ #! IRC /commands are just words.
+ " " split1 swap [
+ "irc" "listener" "parser" "scratchpad"
+ ] search execute ;
-: say-loop ( -- )
- read [ say say-loop ] when* ;
+: (msg) ( line nick -- )
+ "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
-: disconnect ( -- )
- irc-stream get fclose ;
+: say ( line -- )
+ channel get [ (msg) ] [ "No channel." print ] ifte* ;
-: input-thread ( -- )
- [ in-loop ] in-thread ;
+: talk ( input -- ) "/" ?str-head [ command ] [ say ] ifte ;
+: talk-loop ( -- ) read [ talk talk-loop ] when* ;
+
+: irc ( nick server -- )
+ [
+ channels off
+ channel off
+ connect
+ login
+ input-thread
+ talk-loop
+ disconnect
+ ] with-scope ;
+
+! /commands
+: join ( chan -- )
+ dup channels [ cons ] change
+ dup channel set
+ "JOIN " irc-write irc-print ;
-: irc ( channel nick server -- )
- [ connect input-thread say-loop disconnect ] with-scope ;
+: leave ( chan -- )
+ dup channels [ remove ] change
+ channels get dup [ car ] when channel set
+ "PART " irc-write irc-print ;
-"#concatenative" "conc" "irc.freenode.net" irc
+: msg ( line -- ) " " split1 swap (msg) ;
+: me ( line -- ) "\u0001ACTION " swap "\u0001" cat3 say ;
+: quit ( line -- ) drop disconnect ;
USE: vectors
USE: words
-! <LittleDan> peephole?
-! <LittleDan> "whose peephole are we optimizing" "your mom's"
-
-: begin-compiling ( word -- definition )
+: compiling ( word -- definition )
"verbose-compile" get [
"Compiling " write dup . flush
] when
: (compile) ( word -- )
#! Should be called inside the with-compiler scope.
- begin-compiling dataflow optimize linearize generate ;
+ compiling dataflow optimize linearize simplify generate ;
: precompile ( word -- )
#! Print linear IR of word.
[
- word-parameter dataflow optimize linearize [.]
+ word-parameter dataflow optimize linearize simplify [.]
] with-scope ;
: compile-postponed ( -- )
] "linearizer" set-word-property
: <label> ( -- label )
- gensym
- dup t "label" set-word-property ;
+ gensym dup t "label" set-word-property ;
+
+: label? ( obj -- ? )
+ dup word ? [ "label" word-property ] [ drop f ] ifte ;
: label, ( label -- )
#label swons , ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: compiler
+USE: inference
+USE: errors
+USE: generic
+USE: hashtables
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: parser
+USE: prettyprint
+USE: stdio
+USE: strings
+USE: unparser
+USE: vectors
+USE: words
+
+! <LittleDan> peephole?
+! <LittleDan> "whose peephole are we optimizing" "your mom's"
+
+: labels ( linear -- list )
+ #! Make a list of all labels defined in the linear IR.
+ [ [ unswons #label = [ , ] [ drop ] ifte ] each ] make-list ;
+
+: label-called? ( label linear -- ? )
+ [ unswons #label = [ drop f ] [ over = ] ifte ] some? nip ;
+
+: purge-label ( label linear -- )
+ >r dup cdr r> label-called? [ , ] [ drop ] ifte ;
+
+: purge-labels ( linear -- linear )
+ #! Remove all unused labels.
+ [
+ dup [
+ dup car #label = [ over purge-label ] [ , ] ifte
+ ] each drop
+ ] make-list ;
+
+: simplify-node ( node rest -- rest ? )
+ over car "simplifier" word-property [
+ call
+ ] [
+ swap , f
+ ] ifte* ;
+
+: find-label ( label linear -- rest )
+ [ cdr over = ] some? cdr nip ;
+
+: (simplify) ( list -- ? )
+ dup [ uncons simplify-node drop (simplify) ] [ drop ] ifte ;
+
+: simplify ( linear -- linear )
+ purge-labels [ (simplify) ] make-list ;
+
+: follows? ( op list -- ? ) dup [ car car = ] [ 2drop f ] ifte ;
+
+GENERIC: call-simplifier ( node rest -- rest ? )
+
+M: cons call-simplifier ( node rest -- ? )
+ swap , f ;
+
+PREDICATE: cons return-follows #return swap follows? ;
+M: return-follows call-simplifier ( node rest -- rest ? )
+ cdr swap cdr #jump swons , t ;
+
+#call [ call-simplifier ] "simplifier" set-word-property
--- /dev/null
+IN: scratchpad
+USE: compiler
+USE: test
+USE: inference
+USE: lists
+
+[ [ ] ] [ [ ] simplify ] unit-test
+[ [ [ #return ] ] ] [ [ [ #return ] ] simplify ] unit-test
+[ [ [ #jump | car ] ] ] [ [ [ #call | car ] [ #return ] ] simplify ] unit-test
+
+[ [ [ #return ] ] ]
+[ 123 [ [ #call | car ] [ #label | 123 ] [ #return ] ] find-label ]
+unit-test
projects / factor.git / commitdiff