From 1603be0cec3a03925c7ec8f3bf3c7fc8ea23b72b Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 7 Aug 2008 14:00:54 -0300
Subject: [PATCH 01/44] irc.client: Improve testing, better handling of
participant list changes notifications, fix quit notification.
---
extra/irc/client/client-tests.factor | 285 ++++++++++++---------------
extra/irc/client/client.factor | 62 +++---
2 files changed, 147 insertions(+), 200 deletions(-)
diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor
index 1b338df442..97532cbd95 100644
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@@ -1,190 +1,153 @@
USING: kernel tools.test accessors arrays sequences qualified
- io.streams.string io.streams.duplex namespaces threads
+ io io.streams.duplex namespaces threads
calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ;
EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_
IN: irc.client.tests
-! Utilities
-: <test-stream> ( lines -- stream )
- "\n" join <string-reader> <string-writer> <duplex-stream> ;
+! Streams for testing
+TUPLE: mb-writer lines last-line disposed ;
+TUPLE: mb-reader lines disposed ;
+: <mb-writer> ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ;
+: <mb-reader> ( -- mb-reader ) <mailbox> f mb-reader boa ;
+: push-line ( line test-reader-stream -- ) lines>> mailbox-put ;
+: <test-stream> ( -- stream ) <mb-reader> <mb-writer> <duplex-stream> ;
+M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ;
+M: mb-writer stream-flush ( mb-writer -- ) drop ;
+M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
+M: mb-writer stream-nl ( mb-writer -- )
+ [ [ last-line>> concat ] [ lines>> ] bi push ] keep
+ V{ } clone >>last-line drop ;
-: make-client ( lines -- irc-client )
- "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
- swap [ 2nip <test-stream> f ] curry >>connect ;
+: spawn-client ( lines listeners -- irc-client )
+ "someserver" irc-port "factorbot" f <irc-profile>
+ <irc-client>
+ t >>is-running
+ <test-stream> >>stream
+ dup [ spawn-irc yield ] with-irc-client ;
-: set-nick ( irc-client nickname -- )
- swap profile>> (>>nickname) ;
+! to be used inside with-irc-client quotations
+: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
+: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
+: %push-line ( line -- ) irc> stream>> in>> push-line yield yield ;
-: with-dummy-client ( irc-client quot -- )
- [ current-irc-client ] dip with-variable ; inline
+: read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
+ [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
-{ "" } make-client dup "factorbot" set-nick [
- { t } [ irc> profile>> nickname>> me? ] unit-test
+: with-irc ( quot: ( -- ) -- )
+ [ spawn-client ] dip [ f %push-line ] compose with-irc-client ; inline
- { "factorbot" } [ irc> profile>> nickname>> ] unit-test
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TESTS
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+[ { t } [ irc> profile>> nickname>> me? ] unit-test
- { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- parse-irc-line irc-message-origin ] unit-test
+ { "factorbot" } [ irc> profile>> nickname>> ] unit-test
- { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
- parse-irc-line irc-message-origin ] unit-test
-] with-dummy-client
+ { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+
+ { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+ parse-irc-line irc-message-origin ] unit-test
+
+ { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
+ parse-irc-line irc-message-origin ] unit-test
+] with-irc
! Test login and nickname set
-{ "factorbot" } [
- { "NOTICE AUTH :*** Looking up your hostname..."
- "NOTICE AUTH :*** Checking ident"
- "NOTICE AUTH :*** Found your hostname"
- "NOTICE AUTH :*** No identd (auth) response"
- ":some.where 001 factorbot :Welcome factorbot"
- } make-client
- { [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ profile>> nickname>> ]
- [ terminate-irc ]
- } cleave ] unit-test
+[ { "factorbot2" } [
+ ":some.where 001 factorbot2 :Welcome factorbot2" %push-line
+ irc> profile>> nickname>>
+ ] unit-test
+] with-irc
-{ join_ "#factortest" } [
- { ":factorbot!n=factorbo@some.where JOIN :#factortest"
- ":ircserver.net MODE #factortest +ns"
- ":ircserver.net 353 factorbot @ #factortest :@factorbot "
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
- ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
- } make-client
- { [ "factorbot" set-nick ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ join-messages>> 0.1 seconds mailbox-get-timeout ]
- [ terminate-irc ]
- } cleave
- [ class ] [ trailing>> ] bi ] unit-test
+[ { join_ "#factortest" } [
+ { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+ ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
+ } [ %push-line ] each
+ irc> join-messages>> 0.1 seconds mailbox-get-timeout
+ [ class ] [ trailing>> ] bi
+ ] unit-test
+] with-irc
-{ +join+ "somebody" } [
- { ":somebody!n=somebody@some.where JOIN :#factortest" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ listeners>> [ "#factortest" ] dip at
- [ read-message drop ] [ read-message drop ] [ read-message ] tri ]
- [ terminate-irc ]
- } cleave
- [ action>> ] [ nick>> ] bi
- ] unit-test
+[ { T{ participant-changed f "somebody" +join+ } } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":somebody!n=somebody@some.where JOIN :#factortest" %push-line
+ [ participant-changed? ] read-matching-message
+ ] unit-test
+] with-irc
-{ privmsg "#factortest" "hello" } [
- { ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ listeners>> [ "#factortest" ] dip at
- [ read-message drop ] [ read-message ] bi ]
- [ terminate-irc ]
- } cleave
- [ class ] [ name>> ] [ trailing>> ] tri
- ] unit-test
+[ { privmsg "#factortest" "hello" } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
+ [ privmsg? ] read-matching-message
+ [ class ] [ name>> ] [ trailing>> ] tri
+ ] unit-test
+] with-irc
-{ privmsg "factorbot" "hello" } [
- { ":somedude!n=user@isp.net PRIVMSG factorbot :hello" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "somedude" [ <irc-nick-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ listeners>> [ "somedude" ] dip at
- [ read-message drop ] [ read-message ] bi ]
- [ terminate-irc ]
- } cleave
- [ class ] [ name>> ] [ trailing>> ] tri
- ] unit-test
+[ { privmsg "factorbot" "hello" } [
+ "somedude" <irc-nick-listener> [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net PRIVMSG factorbot :hello" %push-line
+ [ privmsg? ] read-matching-message
+ [ class ] [ name>> ] [ trailing>> ] tri
+ ] unit-test
+] with-irc
! Participants lists tests
-{ H{ { "somedude" +normal+ } } } [
- { ":somedude!n=user@isp.net JOIN :#factortest" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at participants>> ]
- [ terminate-irc ]
- } cleave
- ] unit-test
+[ { H{ { "somedude" +normal+ } } } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net JOIN :#factortest" %push-line
+ participants>>
+ ] unit-test
+] with-irc
-{ H{ { "somedude2" +normal+ } } } [
- { ":somedude!n=user@isp.net PART #factortest" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants ] keep
- ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at participants>> ]
- [ terminate-irc ]
- } cleave
- ] unit-test
+[ { H{ { "somedude2" +normal+ } } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude2" +normal+ }
+ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net PART #factortest" %push-line
+ participants>>
+ ] unit-test
+] with-irc
-{ H{ { "somedude2" +normal+ } } } [
- { ":somedude!n=user@isp.net QUIT" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants ] keep
- ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at participants>> ]
- [ terminate-irc ]
- } cleave
- ] unit-test
+[ { H{ { "somedude2" +normal+ } } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude2" +normal+ }
+ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net QUIT" %push-line
+ participants>>
+ ] unit-test
+] with-irc
-{ H{ { "somedude2" +normal+ } } } [
- { ":somedude2!n=user2@isp.net KICK #factortest somedude" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener>
- H{ { "somedude2" +normal+ }
- { "somedude" +normal+ } } clone >>participants ] keep
- ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at participants>> ]
- [ terminate-irc ]
- } cleave
- ] unit-test
+[ { H{ { "somedude2" +normal+ } } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude2" +normal+ }
+ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude2!n=user2@isp.net KICK #factortest somedude" %push-line
+ participants>>
+ ] unit-test
+] with-irc
! Namelist change notification
-{ T{ participant-changed f f f } } [
- { ":ircserver.net 353 factorbot @ #factortest :@factorbot "
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener> ] keep ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
- [ terminate-irc ]
- } cleave
- ] unit-test
+[ { T{ participant-changed f f f } } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
+ [ participant-changed? ] read-matching-message
+ ] unit-test
+] with-irc
-{ T{ participant-changed f "somedude" +part+ } } [
- { ":somedude!n=user@isp.net QUIT" } make-client
- { [ "factorbot" set-nick ]
- [ listeners>>
- [ "#factortest" [ <irc-channel-listener>
- H{ { "somedude" +normal+ } } clone >>participants ] keep
- ] dip set-at ]
- [ connect-irc ]
- [ drop 0.1 seconds sleep ]
- [ listeners>> [ "#factortest" ] dip at
- [ read-message drop ] [ read-message drop ] [ read-message ] tri ]
- [ terminate-irc ]
- } cleave
- ] unit-test
\ No newline at end of file
+[ { T{ participant-changed f "somedude" +part+ } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user@isp.net QUIT" %push-line
+ [ participant-changed? ] read-matching-message
+ ] unit-test
+] with-irc
\ No newline at end of file
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 99922b1fb5..07885a3f82 100644
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -100,17 +100,21 @@ M: string to-listener ( message string -- )
listener> [ +server-listener+ listener> ] unless*
[ to-listener ] [ drop ] if* ;
+M: irc-listener to-listener ( message irc-listener -- )
+ in-messages>> mailbox-put ;
+
: unregister-listener ( name -- )
irc> listeners>>
[ at [ irc-listener-end ] dip to-listener ]
[ delete-at ]
2bi ;
-M: irc-listener to-listener ( message irc-listener -- )
- in-messages>> mailbox-put ;
+: (remove-participant) ( nick listener -- )
+ [ participants>> delete-at ]
+ [ [ +part+ <participant-changed> ] dip to-listener ] 2bi ;
: remove-participant ( nick channel -- )
- listener> [ participants>> delete-at ] [ drop ] if* ;
+ listener> [ (remove-participant) ] [ drop ] if* ;
: listeners-with-participant ( nick -- seq )
irc> listeners>> values
@@ -118,10 +122,13 @@ M: irc-listener to-listener ( message irc-listener -- )
with filter ;
: remove-participant-from-all ( nick -- )
- dup listeners-with-participant [ participants>> delete-at ] with each ;
+ dup listeners-with-participant [ (remove-participant) ] with each ;
: add-participant ( mode nick channel -- )
- listener> [ participants>> set-at ] [ 2drop ] if* ;
+ listener> [
+ [ participants>> set-at ]
+ [ [ +join+ <participant-changed> ] dip to-listener ] 2bi
+ ] [ 2drop ] if* ;
DEFER: me?
@@ -164,25 +171,6 @@ DEFER: me?
: broadcast-message-to-listeners ( message -- )
irc> listeners>> values [ to-listener ] with each ;
-GENERIC: handle-participant-change ( irc-message -- )
-
-M: join handle-participant-change ( join -- )
- [ prefix>> parse-name +join+ <participant-changed> ]
- [ trailing>> ] bi to-listener ;
-
-M: part handle-participant-change ( part -- )
- [ prefix>> parse-name +part+ <participant-changed> ]
- [ channel>> ] bi to-listener ;
-
-M: kick handle-participant-change ( kick -- )
- [ who>> +part+ <participant-changed> ]
- [ channel>> ] bi to-listener ;
-
-M: quit handle-participant-change ( quit -- )
- prefix>> parse-name
- [ +part+ <participant-changed> ] [ listeners-with-participant ] bi
- [ to-listener ] with each ;
-
GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- )
@@ -201,31 +189,27 @@ M: privmsg handle-incoming-irc ( privmsg -- )
dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- )
- { [ maybe-forward-join ]
- [ dup trailing>> to-listener ]
- [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
- [ handle-participant-change ]
- } cleave ;
+ [ maybe-forward-join ]
+ [ dup trailing>> to-listener ]
+ [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
+ tri ;
M: part handle-incoming-irc ( part -- )
[ dup channel>> to-listener ]
[ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
- [ handle-participant-change ]
- tri ;
+ bi ;
M: kick handle-incoming-irc ( kick -- )
- { [ dup channel>> to-listener ]
- [ [ who>> ] [ channel>> ] bi remove-participant ]
- [ handle-participant-change ]
- [ dup who>> me? [ unregister-listener ] [ drop ] if ]
- } cleave ;
+ [ dup channel>> to-listener ]
+ [ [ who>> ] [ channel>> ] bi remove-participant ]
+ [ dup who>> me? [ unregister-listener ] [ drop ] if ]
+ tri ;
M: quit handle-incoming-irc ( quit -- )
[ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ]
- [ handle-participant-change ]
[ prefix>> parse-name remove-participant-from-all ]
- tri ;
+ bi ;
! FIXME: implement this
! M: mode handle-incoming-irc ( mode -- ) call-next-method ;
@@ -367,7 +351,7 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- )
in-messages>> [ irc-connected ] dip mailbox-put ;
: with-irc-client ( irc-client quot: ( -- ) -- )
- [ current-irc-client ] dip with-variable ; inline
+ [ \ current-irc-client ] dip with-variable ; inline
PRIVATE>
From cd77f8ba503997b9894fca442dc05f2707689b15 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Thu, 7 Aug 2008 23:02:29 -0300
Subject: [PATCH 02/44] irc.client: Handle nick changes in participant lists
and forward to channels with the participant. Forward mode messages to
channels.
---
extra/irc/client/client-tests.factor | 37 +++++++++++++++++++++++-----
extra/irc/client/client.factor | 31 +++++++++++++++++------
2 files changed, 55 insertions(+), 13 deletions(-)
diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor
index 97532cbd95..2b4b501952 100644
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@@ -30,7 +30,7 @@ M: mb-writer stream-nl ( mb-writer -- )
! to be used inside with-irc-client quotations
: %add-named-listener ( listener -- ) [ name>> ] keep set+run-listener ;
: %join ( channel -- ) <irc-channel-listener> irc> add-listener ;
-: %push-line ( line -- ) irc> stream>> in>> push-line yield yield ;
+: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
: read-matching-message ( listener quot: ( msg -- ? ) -- irc-message )
[ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
@@ -96,7 +96,14 @@ M: mb-writer stream-nl ( mb-writer -- )
] unit-test
] with-irc
-! Participants lists tests
+[ { mode } [
+ "#factortest" <irc-channel-listener> [ %add-named-listener ] keep
+ ":ircserver.net MODE #factortest +ns" %push-line
+ [ mode? ] read-matching-message class
+ ] unit-test
+] with-irc
+
+! Participant lists tests
[ { H{ { "somedude" +normal+ } } } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep
":somedude!n=user@isp.net JOIN :#factortest" %push-line
@@ -134,8 +141,17 @@ M: mb-writer stream-nl ( mb-writer -- )
] unit-test
] with-irc
+[ { H{ { "somedude2" +normal+ } } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+ participants>>
+ ] unit-test
+] with-irc
+
! Namelist change notification
-[ { T{ participant-changed f f f } } [
+[ { T{ participant-changed f f f f } } [
"#factortest" <irc-channel-listener> [ %add-named-listener ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
@@ -143,11 +159,20 @@ M: mb-writer stream-nl ( mb-writer -- )
] unit-test
] with-irc
-[ { T{ participant-changed f "somedude" +part+ } } [
+[ { T{ participant-changed f "somedude" +part+ f } } [
"#factortest" <irc-channel-listener>
- H{ { "somedude" +normal+ } } clone >>participants
+ H{ { "somedude" +normal+ } } clone >>participants
[ %add-named-listener ] keep
":somedude!n=user@isp.net QUIT" %push-line
[ participant-changed? ] read-matching-message
] unit-test
-] with-irc
\ No newline at end of file
+] with-irc
+
+[ { T{ participant-changed f "somedude" +nick+ "somedude2" } } [
+ "#factortest" <irc-channel-listener>
+ H{ { "somedude" +normal+ } } clone >>participants
+ [ %add-named-listener ] keep
+ ":somedude!n=user2@isp.net NICK :somedude2" %push-line
+ [ participant-changed? ] read-matching-message
+ ] unit-test
+] with-irc
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 07885a3f82..e91767b22d 100644
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -41,6 +41,7 @@ SYMBOL: +normal+
SYMBOL: +join+
SYMBOL: +part+
SYMBOL: +mode+
+SYMBOL: +nick+
! listener objects
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
@@ -59,7 +60,7 @@ SYMBOL: +mode+
! Message objects
! ======================================
-TUPLE: participant-changed nick action ;
+TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed
SINGLETON: irc-listener-end ! send to a listener to stop its execution
@@ -111,7 +112,7 @@ M: irc-listener to-listener ( message irc-listener -- )
: (remove-participant) ( nick listener -- )
[ participants>> delete-at ]
- [ [ +part+ <participant-changed> ] dip to-listener ] 2bi ;
+ [ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
: remove-participant ( nick channel -- )
listener> [ (remove-participant) ] [ drop ] if* ;
@@ -124,10 +125,21 @@ M: irc-listener to-listener ( message irc-listener -- )
: remove-participant-from-all ( nick -- )
dup listeners-with-participant [ (remove-participant) ] with each ;
+: notify-rename ( newnick oldnick listener -- )
+ [ participant-changed new +nick+ >>action
+ [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ;
+
+: rename-participant ( newnick oldnick listener -- )
+ [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ]
+ [ notify-rename ] 3bi ;
+
+: rename-participant-in-all ( oldnick newnick -- )
+ swap dup listeners-with-participant [ rename-participant ] with with each ;
+
: add-participant ( mode nick channel -- )
listener> [
[ participants>> set-at ]
- [ [ +join+ <participant-changed> ] dip to-listener ] 2bi
+ [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
] [ 2drop ] if* ;
DEFER: me?
@@ -211,9 +223,14 @@ M: quit handle-incoming-irc ( quit -- )
[ prefix>> parse-name remove-participant-from-all ]
bi ;
-! FIXME: implement this
-! M: mode handle-incoming-irc ( mode -- ) call-next-method ;
-! M: nick handle-incoming-irc ( nick -- ) call-next-method ;
+M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list
+ dup channel>> to-listener ;
+
+M: nick handle-incoming-irc ( nick -- )
+ [ dup prefix>> parse-name listeners-with-participant
+ [ to-listener ] with each ]
+ [ [ prefix>> parse-name ] [ trailing>> ] bi rename-participant-in-all ]
+ bi ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@@ -225,7 +242,7 @@ M: quit handle-incoming-irc ( quit -- )
M: names-reply handle-incoming-irc ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi [
[ (>>participants) ]
- [ [ f f <participant-changed> ] dip name>> to-listener ] bi
+ [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ;
M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
From d46b5387d506941bb3254098ead070a73e33f3a2 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Sat, 9 Aug 2008 22:33:58 -0400
Subject: [PATCH 03/44] backtrack: Added cut-amb
---
extra/backtrack/backtrack.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor
index 3c1a794121..db2c50173c 100755
--- a/extra/backtrack/backtrack.factor
+++ b/extra/backtrack/backtrack.factor
@@ -66,3 +66,5 @@ MACRO: amb-execute ( seq -- quot )
tri* if
] with-scope ; inline
+: cut-amb ( -- )
+ f failure set ;
From 8785b24e0493e45893f13b07ececc08b1a2f46fe Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Sun, 10 Aug 2008 16:44:17 -0500
Subject: [PATCH 04/44] Now with arbitrary accuracy
---
.../math/derivatives/derivatives-docs.factor | 50 +++++++++++-
extra/math/derivatives/derivatives.factor | 80 +++++++++++++++++--
2 files changed, 119 insertions(+), 11 deletions(-)
diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor
index 23847e82f7..70389f18ad 100644
--- a/extra/math/derivatives/derivatives-docs.factor
+++ b/extra/math/derivatives/derivatives-docs.factor
@@ -3,7 +3,51 @@ USING: help.markup help.syntax ;
IN: math.derivatives
HELP: derivative ( x function -- m )
-{ $values { "x" "the x-position on the function" } { "function" "a differentiable function" } }
-{ $description "Finds the slope of the tangent line at the given x-position on the given function." } ;
+{ $values { "x" "a position on the function" } { "function" "a differentiable function" } }
+{ $description
+ "Approximates the slope of the tangent line by using Ridders' "
+ "method of computing derivatives, from the chapter \"Accurate computation "
+ "of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, Vol. 4, pp. 75-76 ."
+}
+{ $examples
+ { $example
+ "USING: math.derivatives prettyprint ;"
+ "[ sq ] 4 derivative ."
+ "8"
+ }
+ { $notes
+ "For applied scientists, you may play with the settings "
+ "in the source file to achieve arbitrary accuracy."
+ }
+} ;
-{ derivative-func } related-words
+HELP: fast-derivative ( x function -- m )
+{ $values { "x" "a x-position on the function" } { "function" "a differentiable function" } }
+{ $description
+ "Approximates the slope of the tangent line of the provided function "
+ "by using a secant line with very near points. This implementation is "
+ "naive and is only provided because it is used in the much more "
+ "accurate " { $link derivative } " word. Use this word if accuracy "
+ "is of no importance."
+} ;
+
+HELP: derivative-func ( function -- der )
+{ $values { "func" "a differentiable function" } { "der" "the derivative" } }
+{ $description
+ "Provides the derivative of the function. The implementation simply "
+ "attaches the " { $link derivative } " word to the end of the function."
+}
+{ $examples
+ { $example
+ "USING: math.derivatives prettyprint ;"
+ "[ sq ] derivative-func ."
+ "[ [ sq ] derivative ]"
+ }
+} ;
+
+ARTICLE: "derivatives" "The Derivative Toolkit"
+"A toolkit for computing the derivative of functions."
+{ $subsection derivative }
+{ $subsection derivative-func }
+{ $subsection fast-derivative } ;
+ABOUT: "derivatives"
diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor
index d92066efaf..f77748d0b5 100644
--- a/extra/math/derivatives/derivatives.factor
+++ b/extra/math/derivatives/derivatives.factor
@@ -1,10 +1,74 @@
-! Copyright © 2008 Reginald Keith Ford II
-! Tool for computing the derivative of a function at a point
-USING: kernel math math.points math.function-tools ;
+! Copyright (c) 2008 Reginald Ford
+! Tools for approximating derivatives
+
+USING: kernel math math.functions locals generalizations float-arrays sequences
+math.constants namespaces math.function-tools math.points math.ranges math.order ;
IN: math.derivatives
-: small-amount ( -- n ) 1.0e-14 ;
-: some-more ( x -- y ) small-amount + ;
-: some-less ( x -- y ) small-amount - ;
-: derivative ( x function -- m ) [ [ some-more ] dip eval ] [ [ some-less ] dip eval ] 2bi slope ;
-: derivative-func ( function -- function ) [ derivative ] curry ;
\ No newline at end of file
+! Ridders' method of a derivative, from the chapter
+! "Accurate computation of F'(x) and F'(x)F''(x)",
+! From "Advances in Engineering Software, Vol. 4, pp. 75-76
+! \ fast-derivative has been factored out for use by children
+
+: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
+: ntab 10 ; ! max size of tableau (main accuracy setting)
+: con 1.41 ; ! stepsize is decreased by this per-iteration
+: con2 1.9881 ; ! con^2
+: initial-h 0.02 ; ! distance of the 2 points of the first secant line
+: safe 2.0 ; ! return when current err is SAFE worse than the best
+ ! \ safe probably should not be changed
+SYMBOL: i
+SYMBOL: j
+SYMBOL: err
+SYMBOL: errt
+SYMBOL: fac
+SYMBOL: h
+SYMBOL: ans
+SYMBOL: matrix
+
+: (derivative) ( x function -- m )
+ [ [ h get + ] dip eval ]
+ [ [ h get - ] dip eval ]
+ 2bi slope ; inline
+: fast-derivative ( x function -- m )
+ over epsilon sqrt * h set
+ (derivative) ; inline
+: init-matrix ( -- )
+ ntab [ ntab <float-array> ] replicate
+ matrix set ;
+: m-set ( value j i -- ) matrix get nth set-nth ;
+: m-get ( j i -- n ) matrix get nth nth ;
+:: derivative ( x func -- m )
+ init-matrix
+ initial-h h set
+ x func (derivative) 0 0 m-set
+ largest-float err set
+ ntab 1 - [1,b] [| i |
+ h [ con / ] change
+ x func (derivative) 0 i m-set
+ con2 fac set
+ i [1,b] [| j |
+ j 1 - i m-get fac get *
+ j 1 - i 1 - m-get
+ -
+ fac get 1 -
+ / j i m-set
+ fac [ con2 * ] change
+ j i m-get j 1 - i m-get - abs
+ j i m-get j 1 - i 1 - m-get - abs
+ max errt set
+ errt get err get <=
+ [
+ errt get err set
+ j i m-get ans set
+ ] [ ]
+ if
+ ] each
+ i i m-get i 1 - dup m-get - abs
+ err get safe *
+ <
+ ] all? drop
+ ans get ; inline
+: derivative-func ( function -- function ) [ derivative ] curry ; inline
+: fast-derivative-func ( function -- function ) [ fast-derivative ] curry ; inline
+
From aee8dbdba45abf06eab2e974b2985bc4e9c41ed5 Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Sun, 10 Aug 2008 16:45:13 -0500
Subject: [PATCH 05/44] peer review by myself
---
extra/24-game/24-game-docs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/24-game/24-game-docs.factor b/extra/24-game/24-game-docs.factor
index 12a558b2d2..cd82f335d8 100644
--- a/extra/24-game/24-game-docs.factor
+++ b/extra/24-game/24-game-docs.factor
@@ -31,12 +31,12 @@ HELP: 24-able ( -- vector )
"just using the provided commands and the 4 numbers. The Following are the "
"provided commands: "
{ $link + } ", " { $link - } ", " { $link * } ", "
- { $link / } ", and " { $link swap } "."
+ { $link / } ", " { $link swap } ", and " { $link rot } "."
}
{ $examples
{ $example
"USE: 24-game"
- "24-able vector-24-able?"
+ "24-able vector-24-able? ."
"t"
}
{ $notes { $link 24-able? } " is used in " { $link 24-able } "." }
From 9d0acc555d51b1aba9918b8fd73269f6a5bd40cb Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Sun, 10 Aug 2008 16:47:52 -0500
Subject: [PATCH 06/44] peer review by myself
---
extra/animations/animations-docs.factor | 63 ++++++++++++++++++-------
1 file changed, 47 insertions(+), 16 deletions(-)
diff --git a/extra/animations/animations-docs.factor b/extra/animations/animations-docs.factor
index 6a1e89a28e..000c0ce4cc 100644
--- a/extra/animations/animations-docs.factor
+++ b/extra/animations/animations-docs.factor
@@ -1,34 +1,65 @@
USING: help.markup help.syntax ;
-IN: extra.animations
+IN: animations
HELP: animate ( quot duration -- )
+
{ $values
{ "quot" "a quot which uses " { $link progress } }
{ "duration" "a duration of time" }
}
-{ $description { $link animate } " calls " { $link reset-progress } " , then continously calls the given quot until the duration of time has elapsed. The quot should use " { $link progress } " at least once." }
-{ $example
- "USING: extra.animations calendar threads prettyprint ;"
- "[ 1 sleep progress unparse write \" ms elapsed\" print ] 1/20 seconds animate ;"
- "46 ms elapsed\n17 ms elapsed"
+{ $description
+ { $link animate } " calls " { $link reset-progress }
+ " , then continously calls the given quot until the"
+ " duration of time has elapsed. The quot should use "
+ { $link progress } " at least once."
+}
+{ $examples
+ { $unchecked-example
+ "USING: animations calendar threads prettyprint ;"
+ "[ 1 sleep progress unparse write \" ms elapsed\" print ] "
+ "1/20 seconds animate ;"
+ "46 ms elapsed\n17 ms elapsed"
+ }
+ { $notes "The amount of time elapsed between these iterations will very." }
} ;
HELP: reset-progress ( -- )
-{ $description "Initiates the timer. Call this before using a loop which makes use of " { $link progress } "." } ;
+{ $description
+ "Initiates the timer. Call this before using "
+ "a loop which makes use of " { $link progress } "."
+} ;
HELP: progress ( -- time )
{ $values { "time" "an integer" } }
-{ $description "Gives the time elapsed since the last time this word was called, in milliseconds." }
-{ $example
- "USING: extra.animations threads prettyprint ;"
- "reset-progress 3 [ 1 sleep progress unparse write \"ms elapsed\" print ] times ;"
- "31 ms elapsed\n18 ms elapsed\n16 ms elapsed"
+{ $description
+ "Gives the time elapsed since the last time"
+ " this word was called, in milliseconds."
+}
+{ $examples
+ { $unchecked-example
+ "USING: animations threads prettyprint ;"
+ "reset-progress 3 "
+ "[ 1 sleep progress unparse write \"ms elapsed\" print ] "
+ "times ;"
+ "31 ms elapsed\n18 ms elapsed\n16 ms elapsed"
+ }
+ { $notes "The amount of time elapsed between these iterations will very." }
} ;
-ARTICLE: "extra.animations" "Animations"
-"Provides a lightweight framework for properly simulating continuous functions of real time. This framework helps one create animations that use rates which do not change across platforms. The speed of the computer should correlate with the smoothness of the animation, not the speed of the animation!"
+ARTICLE: "animations" "Animations"
+"Provides a lightweight framework for properly simulating continuous"
+" functions of real time. This framework helps one create animations "
+"that use rates which do not change across platforms. The speed of the "
+"computer should correlate with the smoothness of the animation, not "
+"the speed of the animation!"
{ $subsection animate }
{ $subsection reset-progress }
{ $subsection progress }
-{ $link progress } " specifically provides the length of time since " { $link reset-progress } " was called, and also calls " { $link reset-progress } " as its last action. This can be directly used when one's quote runs for a specific number of iterations, instead of a length of time. If the animation is like most, and is expected to run for a specific length of time, " { $link animate } " should be used." ;
-ABOUT: "extra.animations"
\ No newline at end of file
+! A little talk about when to use progress and when to use animate
+ { $link progress } " specifically provides the length of time since "
+ { $link reset-progress } " was called, and also calls "
+ { $link reset-progress } " as its last action. This can be directly "
+ "used when one's quote runs for a specific number of iterations, instead "
+ "of a length of time. If the animation is like most, and is expected to "
+ "run for a specific length of time, " { $link animate } " should be used." ;
+ABOUT: "animations"
\ No newline at end of file
From 6ab0f6b09c633f6543b1feee16babefd8aab287a Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Sun, 10 Aug 2008 16:48:54 -0500
Subject: [PATCH 07/44] No one else used middle name
---
extra/animations/authors.txt | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/animations/authors.txt b/extra/animations/authors.txt
index dac0cb42fe..137b1605da 100644
--- a/extra/animations/authors.txt
+++ b/extra/animations/authors.txt
@@ -1 +1 @@
-Reginald Keith Ford II
\ No newline at end of file
+Reginald Ford
\ No newline at end of file
From a44097af93cebbef61d8bee80da94c93618b3b49 Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Sun, 10 Aug 2008 16:49:40 -0500
Subject: [PATCH 08/44] combinators should inline
---
extra/math/function-tools/function-tools.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor
index 802bf9e14e..ec93a0891a 100644
--- a/extra/math/function-tools/function-tools.factor
+++ b/extra/math/function-tools/function-tools.factor
@@ -3,7 +3,7 @@
USING: kernel math arrays sequences sequences.lib ;
IN: math.function-tools
-: difference-func ( func func -- func ) [ bi - ] 2curry ;
-: eval ( x func -- pt ) dupd call 2array ;
-: eval-inverse ( y func -- pt ) dupd call swap 2array ;
-: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ;
+: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
+: eval ( x func -- pt ) dupd call 2array ; inline
+: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
+: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline
From 6df077805d5a89972aa1679a78565645c3a525ad Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Sun, 10 Aug 2008 18:20:14 -0500
Subject: [PATCH 09/44] minor fixes
---
extra/math/derivatives/derivatives-docs.factor | 15 ++-------------
extra/math/derivatives/derivatives.factor | 16 +++-------------
2 files changed, 5 insertions(+), 26 deletions(-)
diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor
index 70389f18ad..0db52adfa5 100644
--- a/extra/math/derivatives/derivatives-docs.factor
+++ b/extra/math/derivatives/derivatives-docs.factor
@@ -17,20 +17,10 @@ HELP: derivative ( x function -- m )
}
{ $notes
"For applied scientists, you may play with the settings "
- "in the source file to achieve arbitrary accuracy."
+ "in the source file to achieve arbitrary accuracy. "
}
} ;
-HELP: fast-derivative ( x function -- m )
-{ $values { "x" "a x-position on the function" } { "function" "a differentiable function" } }
-{ $description
- "Approximates the slope of the tangent line of the provided function "
- "by using a secant line with very near points. This implementation is "
- "naive and is only provided because it is used in the much more "
- "accurate " { $link derivative } " word. Use this word if accuracy "
- "is of no importance."
-} ;
-
HELP: derivative-func ( function -- der )
{ $values { "func" "a differentiable function" } { "der" "the derivative" } }
{ $description
@@ -48,6 +38,5 @@ HELP: derivative-func ( function -- der )
ARTICLE: "derivatives" "The Derivative Toolkit"
"A toolkit for computing the derivative of functions."
{ $subsection derivative }
-{ $subsection derivative-func }
-{ $subsection fast-derivative } ;
+{ $subsection derivative-func } ;
ABOUT: "derivatives"
diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor
index f77748d0b5..96d0fc3a81 100644
--- a/extra/math/derivatives/derivatives.factor
+++ b/extra/math/derivatives/derivatives.factor
@@ -1,19 +1,13 @@
-! Copyright (c) 2008 Reginald Ford
! Tools for approximating derivatives
USING: kernel math math.functions locals generalizations float-arrays sequences
math.constants namespaces math.function-tools math.points math.ranges math.order ;
IN: math.derivatives
-! Ridders' method of a derivative, from the chapter
-! "Accurate computation of F'(x) and F'(x)F''(x)",
-! From "Advances in Engineering Software, Vol. 4, pp. 75-76
-! \ fast-derivative has been factored out for use by children
-
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
-: ntab 10 ; ! max size of tableau (main accuracy setting)
-: con 1.41 ; ! stepsize is decreased by this per-iteration
-: con2 1.9881 ; ! con^2
+: ntab 10 ; ! max size of tableau (main accuracy setting)
+: con 1.41 ; ! stepsize is decreased by this per-iteration
+: con2 1.9881 ; ! con^2
: initial-h 0.02 ; ! distance of the 2 points of the first secant line
: safe 2.0 ; ! return when current err is SAFE worse than the best
! \ safe probably should not be changed
@@ -30,9 +24,6 @@ SYMBOL: matrix
[ [ h get + ] dip eval ]
[ [ h get - ] dip eval ]
2bi slope ; inline
-: fast-derivative ( x function -- m )
- over epsilon sqrt * h set
- (derivative) ; inline
: init-matrix ( -- )
ntab [ ntab <float-array> ] replicate
matrix set ;
@@ -70,5 +61,4 @@ SYMBOL: matrix
] all? drop
ans get ; inline
: derivative-func ( function -- function ) [ derivative ] curry ; inline
-: fast-derivative-func ( function -- function ) [ fast-derivative ] curry ; inline
From 6060b12ccb2d8e6a9ab4aafbe7d24e5e77cc75bf Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Sun, 10 Aug 2008 18:22:32 -0500
Subject: [PATCH 10/44] minor additions
---
extra/animations/animations.factor | 9 ++++++---
1 file changed, 6 insertions(+), 3 deletions(-)
diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor
index 7efd618bbf..db5b3448c1 100644
--- a/extra/animations/animations.factor
+++ b/extra/animations/animations.factor
@@ -2,11 +2,14 @@
USING: kernel shuffle system locals
prettyprint math io namespaces threads calendar ;
-IN: extra.animations
+IN: animations
SYMBOL: last-loop
+SYMBOL: sleep-period
+
: reset-progress ( -- ) millis last-loop set ;
: progress ( -- progress ) millis last-loop get - reset-progress ;
: set-end ( duration -- end-time ) dt>milliseconds millis + ;
-: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ;
-: animate ( quot duration -- ) reset-progress set-end loop ;
\ No newline at end of file
+: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline
+: animate ( quot duration -- ) reset-progress set-end loop ; inline
+: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline
\ No newline at end of file
From a483a5afd5d0cea839f9090278fd963498cbeb44 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 23:36:46 -0500
Subject: [PATCH 11/44] Fix effect>string
---
core/effects/effects.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index c221ad073b..022490a907 100755
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces sequences strings words assocs
-combinators accessors arrays ;
+USING: kernel math math.parser namespaces sequences strings
+words assocs combinators accessors arrays ;
IN: effects
TUPLE: effect in out terminated? ;
@@ -25,7 +25,7 @@ TUPLE: effect in out terminated? ;
GENERIC: effect>string ( obj -- str )
M: string effect>string ;
M: word effect>string name>> ;
-M: integer effect>string drop "object" ;
+M: integer effect>string number>string ;
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
: stack-picture ( seq -- string )
From b411d896a4124416a3c659961d466cdbf9d01974 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 23:37:12 -0500
Subject: [PATCH 12/44] Port optimizer report
---
.../tree/debugger/debugger-tests.factor | 6 +
.../compiler/tree/debugger/debugger.factor | 141 ++++++++++++++++++
.../tree/loop/inversion/inversion.factor | 5 +
.../tree/optimizer/optimizer-tests.factor | 4 +
.../compiler/tree/optimizer/optimizer.factor | 1 +
5 files changed, 157 insertions(+)
create mode 100644 unfinished/compiler/tree/debugger/debugger-tests.factor
create mode 100644 unfinished/compiler/tree/debugger/debugger.factor
create mode 100644 unfinished/compiler/tree/loop/inversion/inversion.factor
create mode 100644 unfinished/compiler/tree/optimizer/optimizer-tests.factor
diff --git a/unfinished/compiler/tree/debugger/debugger-tests.factor b/unfinished/compiler/tree/debugger/debugger-tests.factor
new file mode 100644
index 0000000000..e6a4385c3e
--- /dev/null
+++ b/unfinished/compiler/tree/debugger/debugger-tests.factor
@@ -0,0 +1,6 @@
+IN: compiler.tree.debugger.tests
+USING: compiler.tree.debugger tools.test ;
+
+\ optimized-quot. must-infer
+\ optimized-word. must-infer
+\ optimizer-report. must-infer
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
new file mode 100644
index 0000000000..804d6ea240
--- /dev/null
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -0,0 +1,141 @@
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs fry match accessors namespaces effects
+sequences sequences.private quotations generic macros arrays
+prettyprint prettyprint.backend prettyprint.sections math words
+combinators io sorting
+compiler.tree
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.tree.combinators
+compiler.tree.propagation.info ;
+IN: compiler.tree.debugger
+
+! A simple tool for turning tree IR into quotations and
+! printing reports, for debugging purposes.
+
+GENERIC: node>quot ( node -- )
+
+MACRO: match-choose ( alist -- )
+ [ '[ , ] ] assoc-map '[ , match-cond ] ;
+
+MATCH-VARS: ?a ?b ?c ;
+
+: pretty-shuffle ( in out -- word/f )
+ 2array {
+ { { { ?a } { ?a } } [ ] }
+ { { { ?a ?b } { ?a ?b } } [ ] }
+ { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
+ { { { ?a } { } } [ drop ] }
+ { { { ?a ?b } { } } [ 2drop ] }
+ { { { ?a ?b ?c } { } } [ 3drop ] }
+ { { { ?a } { ?a ?a } } [ dup ] }
+ { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
+ { { { ?a ?b } { ?a ?b ?a } } [ over ] }
+ { { { ?b ?a } { ?a ?b } } [ swap ] }
+ { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
+ { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
+ { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
+ { { { ?a ?b } { ?b } } [ nip ] }
+ { { { ?a ?b ?c } { ?c } } [ 2nip ] }
+ { _ f }
+ } match-choose ;
+
+TUPLE: shuffle effect ;
+
+M: shuffle pprint* effect>> effect>string text ;
+
+: shuffle-inputs/outputs ( node -- in out )
+ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
+ [ at ] curry map ;
+
+M: #shuffle node>quot
+ shuffle-inputs/outputs 2dup pretty-shuffle dup
+ [ 2nip % ] [ drop <effect> shuffle boa , ] if ;
+
+: pushed-literals ( node -- seq )
+ dup out-d>> [ node-value-info literal>> literalize ] with map ;
+
+M: #push node>quot pushed-literals % ;
+
+M: #call node>quot word>> , ;
+
+M: #call-recursive node>quot label>> id>> , ;
+
+DEFER: nodes>quot
+
+DEFER: label
+
+M: #recursive node>quot
+ [ label>> id>> literalize , ]
+ [ child>> nodes>quot , \ label , ]
+ bi ;
+
+M: #if node>quot
+ children>> [ nodes>quot ] map % \ if , ;
+
+M: #dispatch node>quot
+ children>> [ nodes>quot ] map , \ dispatch , ;
+
+M: #>r node>quot in-d>> length \ >r <repetition> % ;
+
+M: #r> node>quot out-d>> length \ r> <repetition> % ;
+
+M: node node>quot drop ;
+
+: nodes>quot ( node -- quot )
+ [ [ node>quot ] each ] [ ] make ;
+
+: optimized-quot. ( quot -- )
+ dup word? [ specialized-def ] when
+ build-tree optimize-tree nodes>quot . ;
+
+SYMBOL: words-called
+SYMBOL: generics-called
+SYMBOL: methods-called
+SYMBOL: intrinsics-called
+SYMBOL: node-count
+
+: make-report ( word/quot -- assoc )
+ [
+ dup word? [ build-tree-from-word nip ] [ build-tree ] if
+ optimize-tree
+
+ H{ } clone words-called set
+ H{ } clone generics-called set
+ H{ } clone methods-called set
+ H{ } clone intrinsics-called set
+
+ 0 swap [
+ >r 1+ r>
+ dup #call? [
+ word>> {
+ { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
+ { [ dup generic? ] [ generics-called ] }
+ { [ dup method-body? ] [ methods-called ] }
+ [ words-called ]
+ } cond 1 -rot get at+
+ ] [ drop ] if
+ ] each-node
+ node-count set
+ ] H{ } make-assoc ;
+
+: report. ( report -- )
+ [
+ "==== Total number of IR nodes:" print
+ node-count get .
+
+ {
+ { generics-called "==== Generic word calls:" }
+ { words-called "==== Ordinary word calls:" }
+ { methods-called "==== Non-inlined method calls:" }
+ { intrinsics-called "==== Open-coded intrinsic calls:" }
+ } [
+ nl print get keys natural-sort stack.
+ ] assoc-each
+ ] bind ;
+
+: optimizer-report. ( word -- )
+ make-report report. ;
diff --git a/unfinished/compiler/tree/loop/inversion/inversion.factor b/unfinished/compiler/tree/loop/inversion/inversion.factor
new file mode 100644
index 0000000000..719fc4ad70
--- /dev/null
+++ b/unfinished/compiler/tree/loop/inversion/inversion.factor
@@ -0,0 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.loop.inversion
+
+: invert-loops ( nodes -- nodes' ) ;
diff --git a/unfinished/compiler/tree/optimizer/optimizer-tests.factor b/unfinished/compiler/tree/optimizer/optimizer-tests.factor
new file mode 100644
index 0000000000..1075e441e7
--- /dev/null
+++ b/unfinished/compiler/tree/optimizer/optimizer-tests.factor
@@ -0,0 +1,4 @@
+USING: compiler.tree.optimizer tools.test ;
+IN: compiler.tree.optimizer.tests
+
+\ optimize-tree must-infer
diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor
index 24df9b5af3..2d2a376bc0 100644
--- a/unfinished/compiler/tree/optimizer/optimizer.factor
+++ b/unfinished/compiler/tree/optimizer/optimizer.factor
@@ -9,6 +9,7 @@ compiler.tree.def-use
compiler.tree.dead-code
compiler.tree.strength-reduction
compiler.tree.loop.detection
+compiler.tree.loop.inversion
compiler.tree.branch-fusion ;
IN: compiler.tree.optimizer
From 1ef85fe1bc373996729f1287a041206566cbfcf4 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Mon, 11 Aug 2008 01:22:26 -0400
Subject: [PATCH 13/44] irc.ui: Various added features
---
extra/irc/ui/commands/commands.factor | 11 +++-
extra/irc/ui/ui.factor | 72 ++++++++++++++++-----------
extra/ui/gadgets/tabs/tabs.factor | 5 +-
3 files changed, 56 insertions(+), 32 deletions(-)
diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor
index 59f4526d23..ddae783f06 100755
--- a/extra/irc/ui/commands/commands.factor
+++ b/extra/irc/ui/commands/commands.factor
@@ -6,8 +6,15 @@ USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
IN: irc.ui.commands
: say ( string -- )
- [ client get profile>> nickname>> <own-message> print-irc ]
- [ listener get write-message ] bi ;
+ irc-tab get
+ [ window>> client>> profile>> nickname>> <own-message> print-irc ]
+ [ listener>> write-message ] 2bi ;
+
+: join ( string -- )
+ irc-tab get window>> join-channel ;
+
+: query ( string -- )
+ irc-tab get window>> query-nick ;
: quote ( string -- )
drop ; ! THIS WILL CHANGE
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index a524168d54..4757e36660 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -19,9 +19,9 @@ SYMBOL: listener
SYMBOL: client
-TUPLE: ui-window client tabs ;
+TUPLE: ui-window < tabbed client ;
-TUPLE: irc-tab < frame listener client userlist ;
+TUPLE: irc-tab < frame listener client window userlist ;
: write-color ( str color -- )
foreground associate format ;
@@ -161,44 +161,54 @@ M: object handle-inbox
<scrolling-pane>
[ <pane-stream> swap display ] 2keep ;
-TUPLE: irc-editor < editor outstream listener client ;
+TUPLE: irc-editor < editor outstream tab ;
: <irc-editor> ( tab pane -- tab editor )
- over irc-editor new-editor
- swap listener>> >>listener swap <pane-stream> >>outstream
- over client>> >>client ;
+ irc-editor new-editor
+ swap <pane-stream> >>outstream ;
: editor-send ( irc-editor -- )
{ [ outstream>> ]
- [ listener>> ]
- [ client>> ]
+ [ [ irc-tab? ] find-parent ]
[ editor-string ]
[ "" swap set-editor-string ] } cleave
- '[ , listener set , client set , parse-message ] with-output-stream ;
+ '[ , irc-tab set , parse-message ] with-output-stream ;
irc-editor "general" f {
{ T{ key-down f f "RET" } editor-send }
{ T{ key-down f f "ENTER" } editor-send }
} define-command-map
-: <irc-tab> ( listener client -- irc-tab )
- irc-tab new-frame
- swap client>> >>client swap >>listener
+: new-irc-tab ( listener ui-window class -- irc-tab )
+ new-frame
+ swap >>window
+ swap >>listener
<irc-pane> [ <scroller> @center grid-add ] keep
<irc-editor> <scroller> @bottom grid-add ;
-: <irc-channel-tab> ( listener client -- irc-tab )
- <irc-tab>
- <pile> [ <scroller> @right grid-add ] keep >>userlist ;
-
-: <irc-server-tab> ( listener client -- irc-tab )
- <irc-tab> ;
-
M: irc-tab graft*
- [ listener>> ] [ client>> ] bi add-listener ;
+ [ listener>> ] [ window>> client>> ] bi add-listener ;
M: irc-tab ungraft*
- [ listener>> ] [ client>> ] bi remove-listener ;
+ [ listener>> ] [ window>> client>> ] bi remove-listener ;
+
+TUPLE: irc-channel-tab < irc-tab userlist ;
+
+: <irc-channel-tab> ( listener ui-window -- irc-tab )
+ irc-tab new-irc-tab
+ <pile> [ <scroller> @right grid-add ] keep >>userlist ;
+
+TUPLE: irc-server-tab < irc-tab ;
+
+: <irc-server-tab> ( listener -- irc-tab )
+ f irc-server-tab new-irc-tab ;
+
+M: irc-server-tab ungraft*
+ [ window>> client>> terminate-irc ]
+ [ listener>> ] [ window>> client>> ] tri remove-listener ;
+
+: <irc-nick-tab> ( listener ui-window -- irc-tab )
+ irc-tab new-irc-tab ;
M: irc-tab pref-dim*
drop { 480 480 } ;
@@ -206,19 +216,25 @@ M: irc-tab pref-dim*
: join-channel ( name ui-window -- )
[ dup <irc-channel-listener> ] dip
[ <irc-channel-tab> swap ] keep
- tabs>> add-page ;
+ add-page ;
+
+: query-nick ( nick ui-window -- )
+ [ dup <irc-nick-listener> ] dip
+ [ <irc-nick-tab> swap ] keep
+ add-page ;
: irc-window ( ui-window -- )
- [ tabs>> ]
+ [ ]
[ client>> profile>> server>> ] bi
open-window ;
: ui-connect ( profile -- ui-window )
- <irc-client> ui-window new over >>client swap
- [ connect-irc ]
- [ [ <irc-server-listener> ] dip add-listener ]
- [ listeners>> +server-listener+ swap at over <irc-tab>
- "Server" associate <tabbed> >>tabs ] tri ;
+ <irc-client>
+ { [ [ <irc-server-listener> ] dip add-listener ]
+ [ listeners>> +server-listener+ swap at <irc-server-tab> dup
+ "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]
+ [ >>client ]
+ [ connect-irc ] } cleave ;
: server-open ( server port nick password channels -- )
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor
index 12031e5911..50e2df2e9e 100755
--- a/extra/ui/gadgets/tabs/tabs.factor
+++ b/extra/ui/gadgets/tabs/tabs.factor
@@ -48,8 +48,8 @@ DEFER: (del-page)
: del-page ( name tabbed -- )
[ names>> index ] 2keep (del-page) ;
-: <tabbed> ( assoc -- tabbed )
- tabbed new-frame
+: new-tabbed ( assoc class -- tabbed )
+ new-frame
0 <model> >>model
<pile> 1 >>fill >>toggler
dup toggler>> @left grid-add
@@ -59,3 +59,4 @@ DEFER: (del-page)
bi
dup redo-toggler ;
+: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;
From 5e9a323ac1e6eadcef7c255b279c23d68120c1d7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 11 Aug 2008 02:49:37 -0500
Subject: [PATCH 14/44] Updating CFG builder
---
.../compiler/cfg/builder/builder-tests.factor | 4 +
.../compiler/cfg/builder/builder.factor | 176 ++++++++----------
.../debug.factor => debugger/debugger.factor} | 24 ++-
.../compiler/tree/debugger/debugger.factor | 5 +-
4 files changed, 104 insertions(+), 105 deletions(-)
create mode 100644 unfinished/compiler/cfg/builder/builder-tests.factor
rename unfinished/compiler/machine/{debug/debug.factor => debugger/debugger.factor} (58%)
diff --git a/unfinished/compiler/cfg/builder/builder-tests.factor b/unfinished/compiler/cfg/builder/builder-tests.factor
new file mode 100644
index 0000000000..098919c868
--- /dev/null
+++ b/unfinished/compiler/cfg/builder/builder-tests.factor
@@ -0,0 +1,4 @@
+IN: compiler.cfg.builder.tests
+USING: compiler.cfg.builder tools.test ;
+
+\ build-cfg must-infer
diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor
index 2f68864e81..76a1b67dd2 100644
--- a/unfinished/compiler/cfg/builder/builder.factor
+++ b/unfinished/compiler/cfg/builder/builder.factor
@@ -1,29 +1,33 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel assocs sequences sequences.lib fry accessors
-compiler.cfg compiler.vops compiler.vops.builder
-namespaces math inference.dataflow optimizer.allot combinators
-math.order ;
+namespaces math combinators math.order
+compiler.tree
+compiler.tree.combinators
+compiler.tree.propagation.info
+compiler.cfg
+compiler.vops
+compiler.vops.builder ;
IN: compiler.cfg.builder
-! Convert dataflow IR to procedure CFG.
+! Convert tree SSA IR to CFG SSA IR.
+
! We construct the graph and set successors first, then we
! set predecessors in a separate pass. This simplifies the
! logic.
SYMBOL: procedures
-SYMBOL: values>vregs
-
SYMBOL: loop-nesting
-GENERIC: convert* ( node -- )
+SYMBOL: values>vregs
GENERIC: convert ( node -- )
+M: #introduce convert drop ;
+
: init-builder ( -- )
- H{ } clone values>vregs set
- V{ } clone loop-nesting set ;
+ H{ } clone values>vregs set ;
: end-basic-block ( -- )
basic-block get [ %b emit ] when ;
@@ -40,15 +44,12 @@ GENERIC: convert ( node -- )
set-basic-block ;
: convert-nodes ( node -- )
- dup basic-block get and [
- [ convert ] [ successor>> convert-nodes ] bi
- ] [ drop ] if ;
+ [ convert ] each ;
: (build-cfg) ( node word -- )
init-builder
begin-basic-block
basic-block get swap procedures get set-at
- %prolog emit
convert-nodes ;
: build-cfg ( node word -- procedures )
@@ -73,10 +74,9 @@ GENERIC: convert ( node -- )
2bi
] if ;
-: load-inputs ( node -- )
- [ in-d>> %data (load-inputs) ]
- [ in-r>> %retain (load-inputs) ]
- bi ;
+: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
+
+: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
: (store-outputs) ( seq stack -- )
over empty? [ 2drop ] [
@@ -86,40 +86,21 @@ GENERIC: convert ( node -- )
2bi
] if ;
-: store-outputs ( node -- )
- [ out-d>> %data (store-outputs) ]
- [ out-r>> %retain (store-outputs) ]
- bi ;
+: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
-M: #push convert*
- out-d>> [
- [ produce-vreg ] [ value-literal ] bi
- emit-literal
- ] each ;
-
-M: #shuffle convert* drop ;
-
-M: #>r convert* drop ;
-
-M: #r> convert* drop ;
-
-M: node convert
- [ load-inputs ]
- [ convert* ]
- [ store-outputs ]
- tri ;
+: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
: (emit-call) ( word -- )
begin-basic-block %call emit begin-basic-block ;
: intrinsic-inputs ( node -- )
- [ load-inputs ]
+ [ load-in-d ]
[ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
bi ;
: intrinsic-outputs ( node -- )
[ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
- [ store-outputs ]
+ [ store-out-d ]
bi ;
: intrinsic ( node quot -- )
@@ -132,19 +113,17 @@ M: node convert
tri
] with-scope ; inline
-USING: kernel.private math.private slots.private
-optimizer.allot ;
+USING: kernel.private math.private slots.private ;
: maybe-emit-fixnum-shift-fast ( node -- node )
- dup dup in-d>> second node-literal? [
- dup dup in-d>> second node-literal
+ dup dup in-d>> second node-value-info literal>> dup fixnum? [
'[ , emit-fixnum-shift-fast ] intrinsic
] [
- dup param>> (emit-call)
+ drop dup word>> (emit-call)
] if ;
: emit-call ( node -- )
- dup param>> {
+ dup word>> {
{ \ tag [ [ emit-tag ] intrinsic ] }
{ \ slot [ [ dup emit-slot ] intrinsic ] }
@@ -175,24 +154,43 @@ optimizer.allot ;
{ \ float> [ [ emit-float> ] intrinsic ] }
{ \ float? [ [ emit-float= ] intrinsic ] }
- { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
- { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
- { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
+ ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
+ ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
+ ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
[ (emit-call) ]
} case drop ;
M: #call convert emit-call ;
-M: #call-label convert
- dup param>> loop-nesting get at [
- basic-block get successors>> push
- end-basic-block
- basic-block off
- drop
- ] [
- (emit-call)
- ] if* ;
+: emit-call-loop ( #recursive -- )
+ dup label>> loop-nesting get at basic-block get successors>> push
+ end-basic-block
+ basic-block off
+ drop ;
+
+: emit-call-recursive ( #recursive -- )
+ label>> id>> (emit-call) ;
+
+M: #call-recursive convert
+ dup label>> loop?>>
+ [ emit-call-loop ] [ emit-call-recursive ] if ;
+
+M: #push convert
+ [
+ [ out-d>> first produce-vreg ]
+ [ node-output-infos first literal>> ]
+ bi emit-literal
+ ]
+ [ store-out-d ] bi ;
+
+M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
+
+M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
+
+M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
+
+M: #terminate convert drop ;
: integer-conditional ( in1 in2 cc -- )
[ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
@@ -221,50 +219,38 @@ M: #call-label convert
[ set-basic-block ]
bi ;
-: phi-inputs ( #if -- vregs-seq )
- children>>
- [ last-node ] map
- [ #values? ] filter
- [ in-d>> [ value>vreg ] map ] map ;
-
-: phi-outputs ( #if -- vregs )
- successor>> out-d>> [ produce-vreg ] map ;
-
-: emit-phi ( #if -- )
- [ phi-outputs ] [ phi-inputs ] bi %phi emit ;
-
M: #if convert
- {
- [ load-inputs ]
- [ emit-if ]
- [ convert-if-children ]
- [ emit-phi ]
- } cleave ;
+ [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
-M: #values convert drop ;
+M: #dispatch convert
+ "Unimplemented" throw ;
-M: #merge convert drop ;
-
-M: #entry convert drop ;
+M: #phi convert drop ;
M: #declare convert drop ;
-M: #terminate convert drop ;
+M: #return convert drop %return emit ;
-M: #label convert
- #! Labels create a new procedure.
- [ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ;
+: convert-recursive ( #recursive -- )
+ [ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
+ [ (emit-call) ]
+ bi ;
-M: #loop convert
- #! Loops become part of the current CFG.
- begin-basic-block
- [ param>> basic-block get 2array loop-nesting get push ]
- [ node-child convert-nodes ]
- bi
+: begin-loop ( #recursive -- )
+ label>> basic-block get 2array loop-nesting get push ;
+
+: end-loop ( -- )
loop-nesting get pop* ;
-M: #return convert
- param>> loop-nesting get key? [
- %epilog emit
- %return emit
- ] unless ;
+: convert-loop ( #recursive -- )
+ begin-basic-block
+ [ begin-loop ]
+ [ child>> convert-nodes ]
+ [ drop end-loop ]
+ tri ;
+
+M: #recursive convert
+ dup label>> loop?>>
+ [ convert-loop ] [ convert-recursive ] if ;
+
+M: #copy convert drop ;
diff --git a/unfinished/compiler/machine/debug/debug.factor b/unfinished/compiler/machine/debugger/debugger.factor
similarity index 58%
rename from unfinished/compiler/machine/debug/debug.factor
rename to unfinished/compiler/machine/debugger/debugger.factor
index f83dadadec..adc84d771f 100644
--- a/unfinished/compiler/machine/debug/debug.factor
+++ b/unfinished/compiler/machine/debugger/debugger.factor
@@ -1,12 +1,17 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces sequences assocs io
-prettyprint inference generator optimizer compiler.vops
-compiler.cfg.builder compiler.cfg.simplifier
-compiler.machine.builder compiler.machine.simplifier ;
-IN: compiler.machine.debug
+prettyprint inference generator optimizer
+compiler.vops
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.cfg.builder
+compiler.cfg.simplifier
+compiler.machine.builder
+compiler.machine.simplifier ;
+IN: compiler.machine.debugger
-: dataflow>linear ( dataflow word -- linear )
+: tree>linear ( tree word -- linear )
[
init-counter
build-cfg
@@ -20,15 +25,16 @@ IN: compiler.machine.debug
] assoc-each ;
: linearized-quot. ( quot -- )
- dataflow optimize
- "Anonymous quotation" dataflow>linear
+ build-tree optimize-tree
+ "Anonymous quotation" tree>linear
linear. ;
: linearized-word. ( word -- )
- dup word-dataflow nip optimize swap dataflow>linear linear. ;
+ dup build-tree-from-word nip optimize-tree
+ dup word-dataflow nip optimize swap tree>linear linear. ;
: >basic-block ( quot -- basic-block )
- dataflow optimize
+ build-tree optimize-tree
[
init-counter
"Anonymous quotation" build-cfg
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
index 804d6ea240..5e8b8888ee 100644
--- a/unfinished/compiler/tree/debugger/debugger.factor
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -23,6 +23,7 @@ MATCH-VARS: ?a ?b ?c ;
: pretty-shuffle ( in out -- word/f )
2array {
+ { { { } { } } [ ] }
{ { { ?a } { ?a } } [ ] }
{ { { ?a ?b } { ?a ?b } } [ ] }
{ { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
@@ -34,6 +35,8 @@ MATCH-VARS: ?a ?b ?c ;
{ { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
{ { { ?a ?b } { ?a ?b ?a } } [ over ] }
{ { { ?b ?a } { ?a ?b } } [ swap ] }
+ { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
+ { { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
{ { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
@@ -88,7 +91,7 @@ M: node node>quot drop ;
: nodes>quot ( node -- quot )
[ [ node>quot ] each ] [ ] make ;
-: optimized-quot. ( quot -- )
+: optimized. ( quot/word -- )
dup word? [ specialized-def ] when
build-tree optimize-tree nodes>quot . ;
From ed848621a3adc38e77b98ccee43c264a24cb80b8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 11 Aug 2008 02:49:43 -0500
Subject: [PATCH 15/44] Fix
---
core/effects/effects.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index 022490a907..2e0aa4c279 100755
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -29,6 +29,7 @@ M: integer effect>string number>string ;
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
: stack-picture ( seq -- string )
+ dup integer? [ "object" <repetition> ] when
[ [ effect>string % CHAR: \s , ] each ] "" make ;
M: effect effect>string ( effect -- string )
From bd168d06f258860a2d8c074d1e0335b02d6e1ec5 Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Tue, 12 Aug 2008 00:28:22 -0400
Subject: [PATCH 16/44] now with progress-peek
---
extra/animations/animations.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor
index db5b3448c1..803536a51c 100644
--- a/extra/animations/animations.factor
+++ b/extra/animations/animations.factor
@@ -8,7 +8,9 @@ SYMBOL: last-loop
SYMBOL: sleep-period
: reset-progress ( -- ) millis last-loop set ;
+! : my-progress ( -- progress ) millis
: progress ( -- progress ) millis last-loop get - reset-progress ;
+: progress-peek ( -- progress ) millis last-loop get - ;
: set-end ( duration -- end-time ) dt>milliseconds millis + ;
: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline
: animate ( quot duration -- ) reset-progress set-end loop ; inline
From d42edecffba30584bcc8c1534932d3085319442c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 11 Aug 2008 23:30:18 -0500
Subject: [PATCH 17/44] Updating codegen for new optimizer
---
unfinished/compiler/generator/authors.txt | 1 +
.../compiler/generator/fixup/authors.txt | 1 +
.../generator/fixup/fixup-docs.factor | 16 +
.../compiler/generator/fixup/fixup.factor | 154 ++++
.../compiler/generator/fixup/summary.txt | 1 +
.../compiler/generator/generator-docs.factor | 88 +++
.../compiler/generator/generator.factor | 269 +++++++
.../generator/iterator/iterator.factor | 41 ++
.../compiler/generator/registers/authors.txt | 1 +
.../generator/registers/registers.factor | 660 ++++++++++++++++++
.../compiler/generator/registers/summary.txt | 1 +
unfinished/compiler/generator/summary.txt | 1 +
unfinished/compiler/generator/tags.txt | 1 +
.../compiler/tree/debugger/debugger.factor | 12 +-
unfinished/compiler/tree/tree.factor | 5 +
.../stack-checker/inlining/inlining.factor | 4 +-
16 files changed, 1247 insertions(+), 9 deletions(-)
create mode 100644 unfinished/compiler/generator/authors.txt
create mode 100644 unfinished/compiler/generator/fixup/authors.txt
create mode 100644 unfinished/compiler/generator/fixup/fixup-docs.factor
create mode 100755 unfinished/compiler/generator/fixup/fixup.factor
create mode 100644 unfinished/compiler/generator/fixup/summary.txt
create mode 100755 unfinished/compiler/generator/generator-docs.factor
create mode 100755 unfinished/compiler/generator/generator.factor
create mode 100644 unfinished/compiler/generator/iterator/iterator.factor
create mode 100644 unfinished/compiler/generator/registers/authors.txt
create mode 100755 unfinished/compiler/generator/registers/registers.factor
create mode 100644 unfinished/compiler/generator/registers/summary.txt
create mode 100644 unfinished/compiler/generator/summary.txt
create mode 100644 unfinished/compiler/generator/tags.txt
diff --git a/unfinished/compiler/generator/authors.txt b/unfinished/compiler/generator/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/unfinished/compiler/generator/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/unfinished/compiler/generator/fixup/authors.txt b/unfinished/compiler/generator/fixup/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/unfinished/compiler/generator/fixup/fixup-docs.factor b/unfinished/compiler/generator/fixup/fixup-docs.factor
new file mode 100644
index 0000000000..a4ff549e8e
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/fixup-docs.factor
@@ -0,0 +1,16 @@
+USING: help.syntax help.markup math kernel
+words strings alien ;
+IN: compiler.generator.fixup
+
+HELP: frame-required
+{ $values { "n" "a non-negative integer" } }
+{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
+
+HELP: add-literal
+{ $values { "obj" object } { "n" integer } }
+{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
+
+HELP: rel-dlsym
+{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
+{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
+} ;
diff --git a/unfinished/compiler/generator/fixup/fixup.factor b/unfinished/compiler/generator/fixup/fixup.factor
new file mode 100755
index 0000000000..e1b4e42e67
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/fixup.factor
@@ -0,0 +1,154 @@
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays generic assocs hashtables io.binary
+kernel kernel.private math namespaces sequences words
+quotations strings alien.accessors alien.strings layouts system
+combinators math.bitfields words.private cpu.architecture
+math.order accessors growable ;
+IN: compiler.generator.fixup
+
+: no-stack-frame -1 ; inline
+
+TUPLE: frame-required n ;
+
+: frame-required ( n -- ) \ frame-required boa , ;
+
+: stack-frame-size ( code -- n )
+ no-stack-frame [
+ dup frame-required? [ frame-required-n max ] [ drop ] if
+ ] reduce ;
+
+GENERIC: fixup* ( frame-size obj -- frame-size )
+
+: code-format 22 getenv ;
+
+: compiled-offset ( -- n ) building get length code-format * ;
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+
+M: label fixup*
+ compiled-offset swap set-label-offset ;
+
+: define-label ( name -- ) <label> swap set ;
+
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
+
+: if-stack-frame ( frame-size quot -- )
+ swap dup no-stack-frame =
+ [ 2drop ] [ stack-frame swap call ] if ; inline
+
+M: word fixup*
+ {
+ { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
+ { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
+ } case ;
+
+SYMBOL: relocation-table
+SYMBOL: label-table
+
+! Relocation classes
+: rc-absolute-cell 0 ;
+: rc-absolute 1 ;
+: rc-relative 2 ;
+: rc-absolute-ppc-2/2 3 ;
+: rc-relative-ppc-2 4 ;
+: rc-relative-ppc-3 5 ;
+: rc-relative-arm-3 6 ;
+: rc-indirect-arm 7 ;
+: rc-indirect-arm-pc 8 ;
+
+: rc-absolute? ( n -- ? )
+ dup rc-absolute-cell =
+ over rc-absolute =
+ rot rc-absolute-ppc-2/2 = or or ;
+
+! Relocation types
+: rt-primitive 0 ;
+: rt-dlsym 1 ;
+: rt-literal 2 ;
+: rt-dispatch 3 ;
+: rt-xt 4 ;
+: rt-here 5 ;
+: rt-label 6 ;
+: rt-immediate 7 ;
+
+TUPLE: label-fixup label class ;
+
+: label-fixup ( label class -- ) \ label-fixup boa , ;
+
+M: label-fixup fixup*
+ dup class>> rc-absolute?
+ [ "Absolute labels not supported" throw ] when
+ dup label>> swap class>> compiled-offset 4 - rot
+ 3array label-table get push ;
+
+TUPLE: rel-fixup arg class type ;
+
+: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
+
+: push-4 ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+ swap set-alien-unsigned-4 ;
+
+M: rel-fixup fixup*
+ [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+ [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+ [ relocation-table get push-4 ] bi@ ;
+
+M: frame-required fixup* drop ;
+
+M: integer fixup* , ;
+
+: adjoin* ( obj table -- n )
+ 2dup swap [ eq? ] curry find drop
+ [ 2nip ] [ dup length >r push r> ] if* ;
+
+SYMBOL: literal-table
+
+: add-literal ( obj -- n ) literal-table get adjoin* ;
+
+: add-dlsym-literals ( symbol dll -- )
+ >r string>symbol r> 2array literal-table get push-all ;
+
+: rel-dlsym ( name dll class -- )
+ >r literal-table get length >r
+ add-dlsym-literals
+ r> r> rt-dlsym rel-fixup ;
+
+: rel-word ( word class -- )
+ >r add-literal r> rt-xt rel-fixup ;
+
+: rel-primitive ( word class -- )
+ >r def>> first r> rt-primitive rel-fixup ;
+
+: rel-literal ( literal class -- )
+ >r add-literal r> rt-literal rel-fixup ;
+
+: rel-this ( class -- )
+ 0 swap rt-label rel-fixup ;
+
+: rel-here ( class -- )
+ 0 swap rt-here rel-fixup ;
+
+: init-fixup ( -- )
+ BV{ } clone relocation-table set
+ V{ } clone label-table set ;
+
+: resolve-labels ( labels -- labels' )
+ [
+ first3 label-offset
+ [ "Unresolved label" throw ] unless*
+ 3array
+ ] map concat ;
+
+: fixup ( code -- literals relocation labels code )
+ [
+ init-fixup
+ dup stack-frame-size swap [ fixup* ] each drop
+
+ literal-table get >array
+ relocation-table get >byte-array
+ label-table get resolve-labels
+ ] { } make ;
diff --git a/unfinished/compiler/generator/fixup/summary.txt b/unfinished/compiler/generator/fixup/summary.txt
new file mode 100644
index 0000000000..ce83e6d253
--- /dev/null
+++ b/unfinished/compiler/generator/fixup/summary.txt
@@ -0,0 +1 @@
+Support for generation of relocatable code
diff --git a/unfinished/compiler/generator/generator-docs.factor b/unfinished/compiler/generator/generator-docs.factor
new file mode 100755
index 0000000000..e00b8d5b28
--- /dev/null
+++ b/unfinished/compiler/generator/generator-docs.factor
@@ -0,0 +1,88 @@
+USING: help.markup help.syntax words debugger generator.fixup
+generator.registers quotations kernel vectors arrays effects
+sequences ;
+IN: compiler.generator
+
+ARTICLE: "generator" "Compiled code generator"
+"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
+$nl
+"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
+{ $subsection compiled-stack-traces? }
+"Assembler intrinsics can be defined for low-level optimization:"
+{ $subsection define-intrinsic }
+{ $subsection define-intrinsics }
+{ $subsection define-if-intrinsic }
+{ $subsection define-if-intrinsics }
+"The main entry point into the code generator:"
+{ $subsection generate } ;
+
+ABOUT: "generator"
+
+HELP: compiled
+{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
+
+HELP: compiling-word
+{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
+
+HELP: compiling-label
+{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
+
+HELP: compiled-stack-traces?
+{ $values { "?" "a boolean" } }
+{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
+
+HELP: literal-table
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
+
+HELP: begin-compiling
+{ $values { "word" word } { "label" word } }
+{ $description "Prepares to generate machine code for a word." } ;
+
+HELP: with-generator
+{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
+{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
+
+HELP: generate-node
+{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
+{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
+
+HELP: generate-nodes
+{ $values { "node" "a dataflow node" } }
+{ $description "Recursively generate machine code for a dataflow graph." }
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
+
+HELP: generate
+{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }
+{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
+
+HELP: define-intrinsics
+{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
+{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
+$nl
+"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
+
+HELP: define-intrinsic
+{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
+{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
+$nl
+"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
+
+HELP: if>boolean-intrinsic
+{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
+{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
+
+HELP: define-if-intrinsics
+{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
+{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
+$nl
+"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
+$nl
+"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
+{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
+
+HELP: define-if-intrinsic
+{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
+{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
+$nl
+"See " { $link define-if-intrinsics } " for a description of the parameters." } ;
diff --git a/unfinished/compiler/generator/generator.factor b/unfinished/compiler/generator/generator.factor
new file mode 100755
index 0000000000..19e60ae19c
--- /dev/null
+++ b/unfinished/compiler/generator/generator.factor
@@ -0,0 +1,269 @@
+ ! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes combinators
+cpu.architecture effects generic hashtables io kernel
+kernel.private layouts math namespaces prettyprint quotations
+sequences system threads words vectors sets dequeues cursors
+stack-checker.inlining
+compiler.tree compiler.tree.builder compiler.tree.combinators
+compiler.tree.propagation.info compiler.generator.fixup
+compiler.generator.registers compiler.generator.iterator ;
+IN: compiler.generator
+
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+ {
+ { [ dup "forgotten" word-prop ] [ ] }
+ { [ dup compiled get key? ] [ ] }
+ { [ dup inlined-block? ] [ ] }
+ { [ dup primitive? ] [ ] }
+ [ dup compile-queue get push-front ]
+ } cond drop ;
+
+: maybe-compile ( word -- )
+ dup compiled>> [ drop ] [ queue-compile ] if ;
+
+SYMBOL: compiling-word
+
+SYMBOL: compiling-label
+
+SYMBOL: compiling-loops
+
+! Label of current word, after prologue, makes recursion faster
+SYMBOL: current-label-start
+
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
+
+: begin-compiling ( word label -- )
+ H{ } clone compiling-loops set
+ compiling-label set
+ compiling-word set
+ compiled-stack-traces?
+ compiling-word get f ?
+ 1vector literal-table set
+ f compiling-label get compiled get set-at ;
+
+: save-machine-code ( literals relocation labels code -- )
+ 4array compiling-label get compiled get set-at ;
+
+: with-generator ( node word label quot -- )
+ [
+ >r begin-compiling r>
+ { } make fixup
+ save-machine-code
+ ] with-scope ; inline
+
+GENERIC: generate-node ( node -- next )
+
+: generate-nodes ( nodes -- )
+ [ current-node generate-node ] iterate-nodes end-basic-block ;
+
+: init-generate-nodes ( -- )
+ init-templates
+ %save-word-xt
+ %prologue-later
+ current-label-start define-label
+ current-label-start resolve-label ;
+
+: generate ( nodes word label -- )
+ [
+ init-generate-nodes
+ [ generate-nodes ] with-node-iterator
+ ] with-generator ;
+
+: intrinsics ( #call -- quot )
+ word>> "intrinsics" word-prop ;
+
+: if-intrinsics ( #call -- quot )
+ word>> "if-intrinsics" word-prop ;
+
+! node
+M: node generate-node drop iterate-next ;
+
+: %jump ( word -- )
+ dup compiling-label get eq?
+ [ drop current-label-start get ] [ %epilogue-later ] if
+ %jump-label ;
+
+: generate-call ( label -- next )
+ dup maybe-compile
+ end-basic-block
+ dup compiling-loops get at [
+ %jump-label f
+ ] [
+ tail-call? [
+ %jump f
+ ] [
+ 0 frame-required
+ %call
+ iterate-next
+ ] if
+ ] ?if ;
+
+! #recursive
+: compile-recursive ( node -- )
+ dup label>> id>> generate-call >r
+ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
+ r> ;
+
+: compiling-loop ( word -- )
+ <label> dup resolve-label swap compiling-loops get set-at ;
+
+: compile-loop ( node -- )
+ end-basic-block
+ [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
+ iterate-next ;
+
+M: #recursive generate-node
+ dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+
+! #if
+: end-false-branch ( label -- )
+ tail-call? [ %return drop ] [ %jump-label ] if ;
+
+: generate-branch ( nodes -- )
+ [ copy-templates generate-nodes ] with-scope ;
+
+: generate-if ( node label -- next )
+ <label> [
+ >r >r children>> first2 swap generate-branch
+ r> r> end-false-branch resolve-label
+ generate-branch
+ init-templates
+ ] keep resolve-label iterate-next ;
+
+M: #if generate-node
+ [ <label> dup %jump-f ]
+ H{ { +input+ { { f "flag" } } } }
+ with-template
+ generate-if ;
+
+! #dispatch
+: dispatch-branch ( nodes word -- label )
+ gensym [
+ [
+ copy-templates
+ %save-dispatch-xt
+ %prologue-later
+ [ generate-nodes ] with-node-iterator
+ ] with-generator
+ ] keep ;
+
+: dispatch-branches ( node -- )
+ children>> [
+ compiling-word get dispatch-branch
+ %dispatch-label
+ ] each ;
+
+: generate-dispatch ( node -- )
+ %dispatch dispatch-branches init-templates ;
+
+M: #dispatch generate-node
+ #! The order here is important, dispatch-branches must
+ #! run after %dispatch, so that each branch gets the
+ #! correct register state
+ tail-call? [
+ generate-dispatch iterate-next
+ ] [
+ compiling-word get gensym [
+ [
+ init-generate-nodes
+ generate-dispatch
+ ] with-generator
+ ] keep generate-call
+ ] if ;
+
+! #call
+: define-intrinsics ( word intrinsics -- )
+ "intrinsics" set-word-prop ;
+
+: define-intrinsic ( word quot assoc -- )
+ 2array 1array define-intrinsics ;
+
+: define-if>branch-intrinsics ( word intrinsics -- )
+ "if-intrinsics" set-word-prop ;
+
+: if>boolean-intrinsic ( quot -- )
+ "false" define-label
+ "end" define-label
+ "false" get swap call
+ t "if-scratch" get load-literal
+ "end" get %jump-label
+ "false" resolve-label
+ f "if-scratch" get load-literal
+ "end" resolve-label
+ "if-scratch" get phantom-push ; inline
+
+: define-if>boolean-intrinsics ( word intrinsics -- )
+ [
+ >r [ if>boolean-intrinsic ] curry r>
+ { { f "if-scratch" } } +scratch+ associate assoc-union
+ ] assoc-map "intrinsics" set-word-prop ;
+
+: define-if-intrinsics ( word intrinsics -- )
+ [ +input+ associate ] assoc-map
+ 2dup define-if>branch-intrinsics
+ define-if>boolean-intrinsics ;
+
+: define-if-intrinsic ( word quot inputs -- )
+ 2array 1array define-if-intrinsics ;
+
+: do-if-intrinsic ( pair -- next )
+ <label> [
+ swap do-template
+ node> next dup >node
+ ] keep generate-if ;
+
+: find-intrinsic ( #call -- pair/f )
+ intrinsics find-template ;
+
+: find-if-intrinsic ( #call -- pair/f )
+ node@ next #if? [
+ if-intrinsics find-template
+ ] [
+ drop f
+ ] if ;
+
+M: #call generate-node
+ dup node-input-infos [ class>> ] map set-operand-classes
+ dup find-if-intrinsic [
+ do-if-intrinsic
+ ] [
+ dup find-intrinsic [
+ do-template iterate-next
+ ] [
+ word>> generate-call
+ ] ?if
+ ] ?if ;
+
+! #call-recursive
+M: #call-recursive generate-node label>> id>> generate-call ;
+
+! #push
+M: #push generate-node
+ literal>> <constant> phantom-push iterate-next ;
+
+! #shuffle
+M: #shuffle generate-node
+ shuffle-effect phantom-shuffle iterate-next ;
+
+M: #>r generate-node
+ in-d>> length
+ phantom->r
+ iterate-next ;
+
+M: #r> generate-node
+ out-d>> length
+ phantom-r>
+ iterate-next ;
+
+! #return
+M: #return generate-node
+ drop end-basic-block %return f ;
+
+M: #return-recursive generate-node
+ end-basic-block
+ label>> id>> compiling-loops get key?
+ [ %return ] unless f ;
diff --git a/unfinished/compiler/generator/iterator/iterator.factor b/unfinished/compiler/generator/iterator/iterator.factor
new file mode 100644
index 0000000000..68881990be
--- /dev/null
+++ b/unfinished/compiler/generator/iterator/iterator.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences cursors kernel compiler.tree ;
+IN: compiler.generator.iterator
+
+SYMBOL: node-stack
+
+: >node ( cursor -- ) node-stack get push ;
+: node> ( -- cursor ) node-stack get pop ;
+: node@ ( -- cursor ) node-stack get peek ;
+: current-node ( -- node ) node@ value ;
+
+: iterate-next ( -- cursor ) node@ next ;
+
+: iterate-nodes ( cursor quot: ( -- ) -- )
+ over [
+ [ swap >node call node> drop ] keep iterate-nodes
+ ] [
+ 2drop
+ ] if ; inline recursive
+
+: with-node-iterator ( quot -- )
+ >r V{ } clone node-stack r> with-variable ; inline
+
+DEFER: (tail-call?)
+
+: tail-phi? ( cursor -- ? )
+ [ value #phi? ] [ next (tail-call?) ] bi and ;
+
+: (tail-call?) ( cursor -- ? )
+ [ value [ #return? ] [ #terminate? ] bi or ]
+ [ tail-phi? ]
+ bi or ;
+
+: tail-call? ( -- ? )
+ node-stack get [
+ next
+ [ (tail-call?) ]
+ [ value #terminate? not ]
+ bi and
+ ] all? ;
diff --git a/unfinished/compiler/generator/registers/authors.txt b/unfinished/compiler/generator/registers/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/unfinished/compiler/generator/registers/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/unfinished/compiler/generator/registers/registers.factor b/unfinished/compiler/generator/registers/registers.factor
new file mode 100755
index 0000000000..dc32afb264
--- /dev/null
+++ b/unfinished/compiler/generator/registers/registers.factor
@@ -0,0 +1,660 @@
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs classes classes.private classes.algebra
+combinators cpu.architecture generator.fixup hashtables kernel
+layouts math namespaces quotations sequences system vectors
+words effects alien byte-arrays
+accessors sets math.order ;
+IN: compiler.generator.registers
+
+SYMBOL: +input+
+SYMBOL: +output+
+SYMBOL: +scratch+
+SYMBOL: +clobber+
+SYMBOL: known-tag
+
+<PRIVATE
+
+! Value protocol
+GENERIC: set-operand-class ( class obj -- )
+GENERIC: operand-class* ( operand -- class )
+GENERIC: move-spec ( obj -- spec )
+GENERIC: live-vregs* ( obj -- )
+GENERIC: live-loc? ( actual current -- ? )
+GENERIC# (lazy-load) 1 ( value spec -- value )
+GENERIC: lazy-store ( dst src -- )
+GENERIC: minimal-ds-loc* ( min obj -- min )
+
+! This will be a multimethod soon
+DEFER: %move
+
+MIXIN: value
+
+PRIVATE>
+
+: operand-class ( operand -- class )
+ operand-class* object or ;
+
+! Default implementation
+M: value set-operand-class 2drop ;
+M: value operand-class* drop f ;
+M: value live-vregs* drop ;
+M: value live-loc? 2drop f ;
+M: value minimal-ds-loc* drop ;
+M: value lazy-store 2drop ;
+
+! A scratch register for computations
+TUPLE: vreg n reg-class ;
+
+C: <vreg> vreg ( n reg-class -- vreg )
+
+M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
+M: vreg live-vregs* , ;
+M: vreg move-spec reg-class>> move-spec ;
+
+INSTANCE: vreg value
+
+M: float-regs move-spec drop float ;
+M: float-regs operand-class* drop float ;
+
+! Temporary register for stack shuffling
+SINGLETON: temp-reg
+
+M: temp-reg move-spec drop f ;
+
+INSTANCE: temp-reg value
+
+! A data stack location.
+TUPLE: ds-loc n class ;
+
+: <ds-loc> ( n -- loc ) f ds-loc boa ;
+
+M: ds-loc minimal-ds-loc* ds-loc-n min ;
+M: ds-loc operand-class* ds-loc-class ;
+M: ds-loc set-operand-class set-ds-loc-class ;
+M: ds-loc live-loc?
+ over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
+
+! A retain stack location.
+TUPLE: rs-loc n class ;
+
+: <rs-loc> ( n -- loc ) f rs-loc boa ;
+M: rs-loc operand-class* rs-loc-class ;
+M: rs-loc set-operand-class set-rs-loc-class ;
+M: rs-loc live-loc?
+ over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
+
+UNION: loc ds-loc rs-loc ;
+
+M: loc move-spec drop loc ;
+
+INSTANCE: loc value
+
+M: f move-spec drop loc ;
+M: f operand-class* ;
+
+! A stack location which has been loaded into a register. To
+! read the location, we just read the register, but when time
+! comes to save it back to the stack, we know the register just
+! contains a stack value so we don't have to redundantly write
+! it back.
+TUPLE: cached loc vreg ;
+
+C: <cached> cached
+
+M: cached set-operand-class cached-vreg set-operand-class ;
+M: cached operand-class* cached-vreg operand-class* ;
+M: cached move-spec drop cached ;
+M: cached live-vregs* cached-vreg live-vregs* ;
+M: cached live-loc? cached-loc live-loc? ;
+M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
+M: cached lazy-store
+ 2dup cached-loc live-loc?
+ [ "live-locs" get at %move ] [ 2drop ] if ;
+M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
+
+INSTANCE: cached value
+
+! A tagged pointer
+TUPLE: tagged vreg class ;
+
+: <tagged> ( vreg -- tagged )
+ f tagged boa ;
+
+M: tagged v>operand tagged-vreg v>operand ;
+M: tagged set-operand-class set-tagged-class ;
+M: tagged operand-class* tagged-class ;
+M: tagged move-spec drop f ;
+M: tagged live-vregs* tagged-vreg , ;
+
+INSTANCE: tagged value
+
+! Unboxed alien pointers
+TUPLE: unboxed-alien vreg ;
+C: <unboxed-alien> unboxed-alien
+M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
+M: unboxed-alien operand-class* drop simple-alien ;
+M: unboxed-alien move-spec class ;
+M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
+
+INSTANCE: unboxed-alien value
+
+TUPLE: unboxed-byte-array vreg ;
+C: <unboxed-byte-array> unboxed-byte-array
+M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
+M: unboxed-byte-array operand-class* drop c-ptr ;
+M: unboxed-byte-array move-spec class ;
+M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
+
+INSTANCE: unboxed-byte-array value
+
+TUPLE: unboxed-f vreg ;
+C: <unboxed-f> unboxed-f
+M: unboxed-f v>operand unboxed-f-vreg v>operand ;
+M: unboxed-f operand-class* drop \ f ;
+M: unboxed-f move-spec class ;
+M: unboxed-f live-vregs* unboxed-f-vreg , ;
+
+INSTANCE: unboxed-f value
+
+TUPLE: unboxed-c-ptr vreg ;
+C: <unboxed-c-ptr> unboxed-c-ptr
+M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
+M: unboxed-c-ptr operand-class* drop c-ptr ;
+M: unboxed-c-ptr move-spec class ;
+M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
+
+INSTANCE: unboxed-c-ptr value
+
+! A constant value
+TUPLE: constant value ;
+C: <constant> constant
+M: constant operand-class* constant-value class ;
+M: constant move-spec class ;
+
+INSTANCE: constant value
+
+<PRIVATE
+
+! Moving values between locations and registers
+: %move-bug ( -- * ) "Bug in generator.registers" throw ;
+
+: %unbox-c-ptr ( dst src -- )
+ dup operand-class {
+ { [ dup \ f class<= ] [ drop %unbox-f ] }
+ { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
+ [ drop %unbox-any-c-ptr ]
+ } cond ; inline
+
+: %move-via-temp ( dst src -- )
+ #! For many transfers, such as loc to unboxed-alien, we
+ #! don't have an intrinsic, so we transfer the source to
+ #! temp then temp to the destination.
+ temp-reg over %move
+ operand-class temp-reg
+ tagged new
+ swap >>vreg
+ swap >>class
+ %move ;
+
+: %move ( dst src -- )
+ 2dup [ move-spec ] bi@ 2array {
+ { { f f } [ %move-bug ] }
+ { { f unboxed-c-ptr } [ %move-bug ] }
+ { { f unboxed-byte-array } [ %move-bug ] }
+
+ { { f constant } [ constant-value swap load-literal ] }
+
+ { { f float } [ %box-float ] }
+ { { f unboxed-alien } [ %box-alien ] }
+ { { f loc } [ %peek ] }
+
+ { { float f } [ %unbox-float ] }
+ { { unboxed-alien f } [ %unbox-alien ] }
+ { { unboxed-byte-array f } [ %unbox-byte-array ] }
+ { { unboxed-f f } [ %unbox-f ] }
+ { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
+ { { loc f } [ swap %replace ] }
+
+ [ drop %move-via-temp ]
+ } case ;
+
+! A compile-time stack
+TUPLE: phantom-stack height stack ;
+
+M: phantom-stack clone
+ call-next-method [ clone ] change-stack ;
+
+GENERIC: finalize-height ( stack -- )
+
+: new-phantom-stack ( class -- stack )
+ >r 0 V{ } clone r> boa ; inline
+
+: (loc) ( m stack -- n )
+ #! Utility for methods on <loc>
+ height>> - ;
+
+: (finalize-height) ( stack word -- )
+ #! We consolidate multiple stack height changes until the
+ #! last moment, and we emit the final height changing
+ #! instruction here.
+ [
+ over zero? [ 2drop ] [ execute ] if 0
+ ] curry change-height drop ; inline
+
+GENERIC: <loc> ( n stack -- loc )
+
+TUPLE: phantom-datastack < phantom-stack ;
+
+: <phantom-datastack> ( -- stack )
+ phantom-datastack new-phantom-stack ;
+
+M: phantom-datastack <loc> (loc) <ds-loc> ;
+
+M: phantom-datastack finalize-height
+ \ %inc-d (finalize-height) ;
+
+TUPLE: phantom-retainstack < phantom-stack ;
+
+: <phantom-retainstack> ( -- stack )
+ phantom-retainstack new-phantom-stack ;
+
+M: phantom-retainstack <loc> (loc) <rs-loc> ;
+
+M: phantom-retainstack finalize-height
+ \ %inc-r (finalize-height) ;
+
+: phantom-locs ( n phantom -- locs )
+ #! A sequence of n ds-locs or rs-locs indexing the stack.
+ >r <reversed> r> [ <loc> ] curry map ;
+
+: phantom-locs* ( phantom -- locs )
+ [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+ phantom-datastack get phantom-retainstack get ;
+
+: (each-loc) ( phantom quot -- )
+ >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
+
+: each-loc ( quot -- )
+ phantoms 2array swap [ (each-loc) ] curry each ; inline
+
+: adjust-phantom ( n phantom -- )
+ swap [ + ] curry change-height drop ;
+
+: cut-phantom ( n phantom -- seq )
+ swap [ cut* swap ] curry change-stack drop ;
+
+: phantom-append ( seq stack -- )
+ over length over adjust-phantom stack>> push-all ;
+
+: add-locs ( n phantom -- )
+ 2dup stack>> length <= [
+ 2drop
+ ] [
+ [ phantom-locs ] keep
+ [ stack>> length head-slice* ] keep
+ [ append >vector ] change-stack drop
+ ] if ;
+
+: phantom-input ( n phantom -- seq )
+ 2dup add-locs
+ 2dup cut-phantom
+ >r >r neg r> adjust-phantom r> ;
+
+: each-phantom ( quot -- ) phantoms rot bi@ ; inline
+
+: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
+
+: live-vregs ( -- seq )
+ [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
+
+: (live-locs) ( phantom -- seq )
+ #! Discard locs which haven't moved
+ [ phantom-locs* ] [ stack>> ] bi zip
+ [ live-loc? ] assoc-filter
+ values ;
+
+: live-locs ( -- seq )
+ [ (live-locs) ] each-phantom append prune ;
+
+! Operands holding pointers to freshly-allocated objects which
+! are guaranteed to be in the nursery
+SYMBOL: fresh-objects
+
+! Computing free registers and initializing allocator
+: reg-spec>class ( spec -- class )
+ float eq? double-float-regs int-regs ? ;
+
+: free-vregs ( reg-class -- seq )
+ #! Free vregs in a given register class
+ \ free-vregs get at ;
+
+: alloc-vreg ( spec -- reg )
+ [ reg-spec>class free-vregs pop ] keep {
+ { f [ <tagged> ] }
+ { unboxed-alien [ <unboxed-alien> ] }
+ { unboxed-byte-array [ <unboxed-byte-array> ] }
+ { unboxed-f [ <unboxed-f> ] }
+ { unboxed-c-ptr [ <unboxed-c-ptr> ] }
+ [ drop ]
+ } case ;
+
+: compatible? ( value spec -- ? )
+ >r move-spec r> {
+ { [ 2dup = ] [ t ] }
+ { [ dup unboxed-c-ptr eq? ] [
+ over { unboxed-byte-array unboxed-alien } member?
+ ] }
+ [ f ]
+ } cond 2nip ;
+
+: allocation ( value spec -- reg-class )
+ {
+ { [ dup quotation? ] [ 2drop f ] }
+ { [ 2dup compatible? ] [ 2drop f ] }
+ [ nip reg-spec>class ]
+ } cond ;
+
+: alloc-vreg-for ( value spec -- vreg )
+ alloc-vreg swap operand-class
+ over tagged? [ >>class ] [ drop ] if ;
+
+M: value (lazy-load)
+ 2dup allocation [
+ dupd alloc-vreg-for dup rot %move
+ ] [
+ drop
+ ] if ;
+
+: (compute-free-vregs) ( used class -- vector )
+ #! Find all vregs in 'class' which are not in 'used'.
+ [ vregs length reverse ] keep
+ [ <vreg> ] curry map swap diff
+ >vector ;
+
+: compute-free-vregs ( -- )
+ #! Create a new hashtable for thee free-vregs variable.
+ live-vregs
+ { int-regs double-float-regs }
+ [ 2dup (compute-free-vregs) ] H{ } map>assoc
+ \ free-vregs set
+ drop ;
+
+M: loc lazy-store
+ 2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
+
+: do-shuffle ( hash -- )
+ dup assoc-empty? [
+ drop
+ ] [
+ "live-locs" set
+ [ lazy-store ] each-loc
+ ] if ;
+
+: fast-shuffle ( locs -- )
+ #! We have enough free registers to load all shuffle inputs
+ #! at once
+ [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
+
+: minimal-ds-loc ( phantom -- n )
+ #! When shuffling more values than can fit in registers, we
+ #! need to find an area on the data stack which isn't in
+ #! use.
+ [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
+
+: find-tmp-loc ( -- n )
+ #! Find an area of the data stack which is not referenced
+ #! from the phantom stacks. We can clobber there all we want
+ [ minimal-ds-loc ] each-phantom min 1- ;
+
+: slow-shuffle-mapping ( locs tmp -- pairs )
+ >r dup length r>
+ [ swap - <ds-loc> ] curry map zip ;
+
+: slow-shuffle ( locs -- )
+ #! We don't have enough free registers to load all shuffle
+ #! inputs, so we use a single temporary register, together
+ #! with the area of the data stack above the stack pointer
+ find-tmp-loc slow-shuffle-mapping [
+ [
+ swap dup cached? [ cached-vreg ] when %move
+ ] assoc-each
+ ] keep >hashtable do-shuffle ;
+
+: fast-shuffle? ( live-locs -- ? )
+ #! Test if we have enough free registers to load all
+ #! shuffle inputs at once.
+ int-regs free-vregs [ length ] bi@ <= ;
+
+: finalize-locs ( -- )
+ #! Perform any deferred stack shuffling.
+ [
+ \ free-vregs [ [ clone ] assoc-map ] change
+ live-locs dup fast-shuffle?
+ [ fast-shuffle ] [ slow-shuffle ] if
+ ] with-scope ;
+
+: finalize-vregs ( -- )
+ #! Store any vregs to their final stack locations.
+ [
+ dup loc? over cached? or [ 2drop ] [ %move ] if
+ ] each-loc ;
+
+: reset-phantom ( phantom -- )
+ #! Kill register assignments but preserve constants and
+ #! class information.
+ dup phantom-locs*
+ over stack>> [
+ dup constant? [ nip ] [
+ operand-class over set-operand-class
+ ] if
+ ] 2map
+ over stack>> delete-all
+ swap stack>> push-all ;
+
+: reset-phantoms ( -- )
+ [ reset-phantom ] each-phantom ;
+
+: finalize-contents ( -- )
+ finalize-locs finalize-vregs reset-phantoms ;
+
+! Loading stacks to vregs
+: free-vregs? ( int# float# -- ? )
+ double-float-regs free-vregs length <=
+ >r int-regs free-vregs length <= r> and ;
+
+: phantom&spec ( phantom spec -- phantom' spec' )
+ >r stack>> r>
+ [ length f pad-left ] keep
+ [ <reversed> ] bi@ ; inline
+
+: phantom&spec-agree? ( phantom spec quot -- ? )
+ >r phantom&spec r> 2all? ; inline
+
+: vreg-substitution ( value vreg -- pair )
+ dupd <cached> 2array ;
+
+: substitute-vreg? ( old new -- ? )
+ #! We don't substitute locs for float or alien vregs,
+ #! since in those cases the boxing overhead might kill us.
+ cached-vreg tagged? >r loc? r> and ;
+
+: substitute-vregs ( values vregs -- )
+ [ vreg-substitution ] 2map
+ [ substitute-vreg? ] assoc-filter >hashtable
+ [ >r stack>> r> substitute-here ] curry each-phantom ;
+
+: set-operand ( value var -- )
+ >r dup constant? [ constant-value ] when r> set ;
+
+: lazy-load ( values template -- )
+ #! Set operand vars here.
+ 2dup [ first (lazy-load) ] 2map
+ dup rot [ second set-operand ] 2each
+ substitute-vregs ;
+
+: load-inputs ( -- )
+ +input+ get
+ [ length phantom-datastack get phantom-input ] keep
+ lazy-load ;
+
+: output-vregs ( -- seq seq )
+ +output+ +clobber+ [ get [ get ] map ] bi@ ;
+
+: clash? ( seq -- ? )
+ phantoms [ stack>> ] bi@ append [
+ dup cached? [ cached-vreg ] when swap member?
+ ] with contains? ;
+
+: outputs-clash? ( -- ? )
+ output-vregs append clash? ;
+
+: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
+
+: count-input-vregs ( phantom spec -- )
+ phantom&spec [
+ >r dup cached? [ cached-vreg ] when r> first allocation
+ ] 2map count-vregs ;
+
+: count-scratch-regs ( spec -- )
+ [ first reg-spec>class ] map count-vregs ;
+
+: guess-vregs ( dinput rinput scratch -- int# float# )
+ [
+ 0 int-regs set
+ 0 double-float-regs set
+ count-scratch-regs
+ phantom-retainstack get swap count-input-vregs
+ phantom-datastack get swap count-input-vregs
+ int-regs get double-float-regs get
+ ] with-scope ;
+
+: alloc-scratch ( -- )
+ +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
+
+: guess-template-vregs ( -- int# float# )
+ +input+ get { } +scratch+ get guess-vregs ;
+
+: template-inputs ( -- )
+ ! Load input values into registers
+ load-inputs
+ ! Allocate scratch registers
+ alloc-scratch
+ ! If outputs clash, we write values back to the stack
+ outputs-clash? [ finalize-contents ] when ;
+
+: template-outputs ( -- )
+ +output+ get [ get ] map phantom-datastack get phantom-append ;
+
+: value-matches? ( value spec -- ? )
+ #! If the spec is a quotation and the value is a literal
+ #! fixnum, see if the quotation yields true when applied
+ #! to the fixnum. Otherwise, the values don't match. If the
+ #! spec is not a quotation, its a reg-class, in which case
+ #! the value is always good.
+ dup quotation? [
+ over constant?
+ [ >r constant-value r> call ] [ 2drop f ] if
+ ] [
+ 2drop t
+ ] if ;
+
+: class-matches? ( actual expected -- ? )
+ {
+ { f [ drop t ] }
+ { known-tag [ dup [ class-tag >boolean ] when ] }
+ [ class<= ]
+ } case ;
+
+: spec-matches? ( value spec -- ? )
+ 2dup first value-matches?
+ >r >r operand-class 2 r> ?nth class-matches? r> and ;
+
+: template-matches? ( spec -- ? )
+ phantom-datastack get +input+ rot at
+ [ spec-matches? ] phantom&spec-agree? ;
+
+: ensure-template-vregs ( -- )
+ guess-template-vregs free-vregs? [
+ finalize-contents compute-free-vregs
+ ] unless ;
+
+: clear-phantoms ( -- )
+ [ stack>> delete-all ] each-phantom ;
+
+PRIVATE>
+
+: set-operand-classes ( classes -- )
+ phantom-datastack get
+ over length over add-locs
+ stack>> [ set-operand-class ] 2reverse-each ;
+
+: end-basic-block ( -- )
+ #! Commit all deferred stacking shuffling, and ensure the
+ #! in-memory data and retain stacks are up to date with
+ #! respect to the compiler's current picture.
+ finalize-contents
+ clear-phantoms
+ finalize-heights
+ fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
+
+: with-template ( quot hash -- )
+ clone [
+ ensure-template-vregs
+ template-inputs call template-outputs
+ ] bind
+ compute-free-vregs ; inline
+
+: do-template ( pair -- )
+ #! Use with return value from find-template
+ first2 with-template ;
+
+: fresh-object ( obj -- ) fresh-objects get push ;
+
+: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
+
+: init-templates ( -- )
+ #! Initialize register allocator.
+ V{ } clone fresh-objects set
+ <phantom-datastack> phantom-datastack set
+ <phantom-retainstack> phantom-retainstack set
+ compute-free-vregs ;
+
+: copy-templates ( -- )
+ #! Copies register allocator state, used when compiling
+ #! branches.
+ fresh-objects [ clone ] change
+ phantom-datastack [ clone ] change
+ phantom-retainstack [ clone ] change
+ compute-free-vregs ;
+
+: find-template ( templates -- pair/f )
+ #! Pair has shape { quot hash }
+ [ second template-matches? ] find nip ;
+
+: operand-tag ( operand -- tag/f )
+ operand-class dup [ class-tag ] when ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: operand-immediate? ( operand -- ? )
+ operand-class immediate class<= ;
+
+: phantom-push ( obj -- )
+ 1 phantom-datastack get adjust-phantom
+ phantom-datastack get stack>> push ;
+
+: phantom-shuffle ( shuffle -- )
+ [ effect-in length phantom-datastack get phantom-input ] keep
+ shuffle* phantom-datastack get phantom-append ;
+
+: phantom->r ( n -- )
+ phantom-datastack get phantom-input
+ phantom-retainstack get phantom-append ;
+
+: phantom-r> ( n -- )
+ phantom-retainstack get phantom-input
+ phantom-datastack get phantom-append ;
diff --git a/unfinished/compiler/generator/registers/summary.txt b/unfinished/compiler/generator/registers/summary.txt
new file mode 100644
index 0000000000..89a46afc03
--- /dev/null
+++ b/unfinished/compiler/generator/registers/summary.txt
@@ -0,0 +1 @@
+Register allocation and intrinsic selection
diff --git a/unfinished/compiler/generator/summary.txt b/unfinished/compiler/generator/summary.txt
new file mode 100644
index 0000000000..cf857ad971
--- /dev/null
+++ b/unfinished/compiler/generator/summary.txt
@@ -0,0 +1 @@
+Final stage of compilation generates machine code from dataflow IR
diff --git a/unfinished/compiler/generator/tags.txt b/unfinished/compiler/generator/tags.txt
new file mode 100644
index 0000000000..86a7c8e637
--- /dev/null
+++ b/unfinished/compiler/generator/tags.txt
@@ -0,0 +1 @@
+compiler
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
index 5e8b8888ee..c5b35438b1 100644
--- a/unfinished/compiler/tree/debugger/debugger.factor
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -21,8 +21,8 @@ MACRO: match-choose ( alist -- )
MATCH-VARS: ?a ?b ?c ;
-: pretty-shuffle ( in out -- word/f )
- 2array {
+: pretty-shuffle ( effect -- word/f )
+ [ in>> ] [ out>> ] bi {
{ { { } { } } [ ] }
{ { { ?a } { ?a } } [ ] }
{ { { ?a ?b } { ?a ?b } } [ ] }
@@ -50,13 +50,9 @@ TUPLE: shuffle effect ;
M: shuffle pprint* effect>> effect>string text ;
-: shuffle-inputs/outputs ( node -- in out )
- [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
- [ at ] curry map ;
-
M: #shuffle node>quot
- shuffle-inputs/outputs 2dup pretty-shuffle dup
- [ 2nip % ] [ drop <effect> shuffle boa , ] if ;
+ shuffle-effect dup pretty-shuffle
+ [ % ] [ shuffle boa , ] ?if ;
: pushed-literals ( node -- seq )
dup out-d>> [ node-value-info literal>> literalize ] with map ;
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 016afc3e89..3db97fdfe0 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -153,6 +153,11 @@ M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
+: shuffle-effect ( #shuffle -- effect )
+ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
+ [ at ] curry map
+ <effect> ;
+
M: vector child-visitor V{ } clone ;
M: vector #introduce, #introduce node, ;
M: vector #call, #call node, ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index 6442bc5740..fcbf18f01c 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -28,9 +28,11 @@ loop? ;
M: inline-recursive hashcode* id>> hashcode* ;
+: inlined-block? ( word -- ? ) "inlined-block" word-prop ;
+
: <inline-recursive> ( word -- label )
inline-recursive new
- gensym >>id
+ gensym t "inlined-block" set-word-prop >>id
swap >>word ;
: quotation-param? ( obj -- ? )
From 759a939ecc713a331f6ea96fb4b0b6a1b4da060b Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Tue, 12 Aug 2008 02:58:12 -0300
Subject: [PATCH 18/44] irc.client: Refactorings
---
extra/irc/client/client-tests.factor | 4 +-
extra/irc/client/client.factor | 96 ++++++++++++------------
extra/irc/messages/messages-tests.factor | 4 +-
extra/irc/messages/messages.factor | 5 ++
4 files changed, 60 insertions(+), 49 deletions(-)
diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor
index 2b4b501952..932bdda472 100644
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@@ -49,10 +49,10 @@ M: mb-writer stream-nl ( mb-writer -- )
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- parse-irc-line irc-message-origin ] unit-test
+ parse-irc-line forward-name ] unit-test
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
- parse-irc-line irc-message-origin ] unit-test
+ parse-irc-line forward-name ] unit-test
] with-irc
! Test login and nickname set
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index e91767b22d..575c26972f 100644
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -3,7 +3,7 @@
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
accessors destructors namespaces io assocs arrays qualified fry
continuations threads strings classes combinators splitting hashtables
- ascii irc.messages irc.messages.private ;
+ ascii irc.messages ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
IN: irc.client
@@ -67,7 +67,6 @@ SINGLETON: irc-listener-end ! send to a listener to stop its execution
SINGLETON: irc-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
-UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
: terminate-irc ( irc-client -- )
[ is-running>> ] keep and [
@@ -122,6 +121,9 @@ M: irc-listener to-listener ( message irc-listener -- )
[ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
with filter ;
+: to-listeners-with-participant ( message nickname -- )
+ listeners-with-participant [ to-listener ] with each ;
+
: remove-participant-from-all ( nick -- )
dup listeners-with-participant [ (remove-participant) ] with each ;
@@ -145,7 +147,7 @@ M: irc-listener to-listener ( message irc-listener -- )
DEFER: me?
: maybe-forward-join ( join -- )
- [ prefix>> parse-name me? ] keep and
+ [ irc-message-sender me? ] keep and
[ irc> join-messages>> mailbox-put ] when* ;
! ======================================
@@ -177,60 +179,64 @@ DEFER: me?
: me? ( string -- ? )
irc> profile>> nickname>> = ;
-: irc-message-origin ( irc-message -- name )
- dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
+GENERIC: forward-name ( irc-message -- name )
+M: join forward-name ( join -- name ) trailing>> ;
+M: part forward-name ( part -- name ) channel>> ;
+M: kick forward-name ( kick -- name ) channel>> ;
+M: mode forward-name ( mode -- name ) channel>> ;
+M: privmsg forward-name ( privmsg -- name )
+ dup name>> me? [ irc-message-sender ] [ name>> ] if ;
-: broadcast-message-to-listeners ( message -- )
- irc> listeners>> values [ to-listener ] with each ;
+UNION: single-forward join part kick mode privmsg ;
+UNION: multiple-forward nick quit ;
+UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
+GENERIC: forward-message ( irc-message -- )
-GENERIC: handle-incoming-irc ( irc-message -- )
-
-M: irc-message handle-incoming-irc ( irc-message -- )
+M: irc-message forward-message ( irc-message -- )
+server-listener+ listener> [ to-listener ] [ drop ] if* ;
-M: logged-in handle-incoming-irc ( logged-in -- )
+M: single-forward forward-message ( forward-single -- )
+ dup forward-name to-listener ;
+
+M: multiple-forward forward-message ( multiple-forward -- )
+ dup irc-message-sender to-listeners-with-participant ;
+
+M: join forward-message ( join -- )
+ [ maybe-forward-join ] [ call-next-method ] bi ;
+
+M: broadcast-forward forward-message ( irc-broadcasted-message -- )
+ irc> listeners>> values [ to-listener ] with each ;
+
+GENERIC: process-message ( irc-message -- )
+
+M: object process-message ( object -- )
+ drop ;
+
+M: logged-in process-message ( logged-in -- )
name>> irc> profile>> (>>nickname) ;
-M: ping handle-incoming-irc ( ping -- )
+M: ping process-message ( ping -- )
trailing>> /PONG ;
-M: nick-in-use handle-incoming-irc ( nick-in-use -- )
+M: nick-in-use process-message ( nick-in-use -- )
name>> "_" append /NICK ;
-M: privmsg handle-incoming-irc ( privmsg -- )
- dup irc-message-origin to-listener ;
+M: join process-message ( join -- )
+ [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
-M: join handle-incoming-irc ( join -- )
- [ maybe-forward-join ]
- [ dup trailing>> to-listener ]
- [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
- tri ;
+M: part process-message ( part -- )
+ [ irc-message-sender ] [ channel>> ] bi remove-participant ;
-M: part handle-incoming-irc ( part -- )
- [ dup channel>> to-listener ]
- [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
- bi ;
-
-M: kick handle-incoming-irc ( kick -- )
- [ dup channel>> to-listener ]
+M: kick process-message ( kick -- )
[ [ who>> ] [ channel>> ] bi remove-participant ]
[ dup who>> me? [ unregister-listener ] [ drop ] if ]
- tri ;
-
-M: quit handle-incoming-irc ( quit -- )
- [ dup prefix>> parse-name listeners-with-participant
- [ to-listener ] with each ]
- [ prefix>> parse-name remove-participant-from-all ]
bi ;
-M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list
- dup channel>> to-listener ;
+M: quit process-message ( quit -- )
+ irc-message-sender remove-participant-from-all ;
-M: nick handle-incoming-irc ( nick -- )
- [ dup prefix>> parse-name listeners-with-participant
- [ to-listener ] with each ]
- [ [ prefix>> parse-name ] [ trailing>> ] bi rename-participant-in-all ]
- bi ;
+M: nick process-message ( nick -- )
+ [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
@@ -239,22 +245,20 @@ M: nick handle-incoming-irc ( nick -- )
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
-M: names-reply handle-incoming-irc ( names-reply -- )
+M: names-reply process-message ( names-reply -- )
[ names-reply>participants ] [ channel>> listener> ] bi [
[ (>>participants) ]
[ [ f f f <participant-changed> ] dip name>> to-listener ] bi
] [ drop ] if* ;
-M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
- broadcast-message-to-listeners ;
+: handle-incoming-irc ( irc-message -- )
+ [ forward-message ] [ process-message ] bi ;
! ======================================
! Client message handling
! ======================================
-GENERIC: handle-outgoing-irc ( obj -- )
-
-M: irc-message handle-outgoing-irc ( irc-message -- )
+: handle-outgoing-irc ( irc-message -- )
irc-message>client-line irc-print ;
! ======================================
diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor
index 7ee0f41ab0..20f4f1b277 100644
--- a/extra/irc/messages/messages-tests.factor
+++ b/extra/irc/messages/messages-tests.factor
@@ -3,7 +3,9 @@ USING: kernel tools.test accessors arrays qualified
EXCLUDE: sequences => join ;
IN: irc.messages.tests
-! Parsing tests
+
+{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
+
irc-message new
":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line
"someuser!n=user@some.where" >>prefix
diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor
index 3b9cf0af2c..64fa9fc2c2 100644
--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@@ -98,6 +98,11 @@ M: irc-message irc-message>server-line ( irc-message -- string )
PRIVATE>
+UNION: sender-in-prefix privmsg join part quit kick mode nick ;
+GENERIC: irc-message-sender ( irc-message -- sender )
+M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
+ prefix>> parse-name ;
+
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
From 2271aae7f070b5c373547f122d07861d239e74d1 Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Tue, 12 Aug 2008 02:42:23 -0400
Subject: [PATCH 19/44] compatible with demos menu
---
extra/24-game/24-game.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor
index 52f0cd6833..126215ab13 100644
--- a/extra/24-game/24-game.factor
+++ b/extra/24-game/24-game.factor
@@ -59,4 +59,5 @@ DEFER: check-status
: 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
: set-commands ( -- ) { + - * / rot swap q } commands set ;
-: play-game ( -- ) set-commands 24-able repeat ;
\ No newline at end of file
+: play-game ( -- ) set-commands 24-able repeat ;
+MAIN: play-game
\ No newline at end of file
From aededc406fc23ce687f3e75dfdc1d85914cc1bdc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 12 Aug 2008 02:41:18 -0500
Subject: [PATCH 20/44] Adding FFI to new front-end
---
basis/alien/c-types/c-types-tests.factor | 6 ++
basis/alien/c-types/c-types.factor | 13 ++-
.../backward/backward.factor | 6 ++
.../compiler/tree/dead-code/dead-code.factor | 6 ++
.../tree/debugger/debugger-tests.factor | 3 +-
.../compiler/tree/debugger/debugger.factor | 2 +-
.../tree/escape-analysis/simple/simple.factor | 10 +++
.../tree/propagation/simple/simple.factor | 6 ++
unfinished/compiler/tree/tree.factor | 27 ++++++
.../tree/tuple-unboxing/tuple-unboxing.factor | 4 +
unfinished/stack-checker/alien/alien.factor | 84 +++++++++++++++++++
.../stack-checker/inlining/inlining.factor | 2 +-
.../known-words/known-words.factor | 22 +++--
.../stack-checker/visitor/dummy/dummy.factor | 3 +
.../stack-checker/visitor/visitor.factor | 3 +
15 files changed, 181 insertions(+), 16 deletions(-)
create mode 100644 unfinished/stack-checker/alien/alien.factor
diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor
index 276dd581c5..edda9e7fdb 100755
--- a/basis/alien/c-types/c-types-tests.factor
+++ b/basis/alien/c-types/c-types-tests.factor
@@ -2,6 +2,12 @@ IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
+\ expand-constants must-infer
+
+: xyz 123 ;
+
+[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
[ 123 ] [ foo ] unit-test
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index c553ca5cfb..a9b39f80ab 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects ;
+accessors combinators effects continuations ;
IN: alien.c-types
DEFER: <int>
@@ -239,15 +239,20 @@ M: long-long-type box-return ( type -- )
} 2cleave ;
: expand-constants ( c-type -- c-type' )
- #! We use def>> call instead of execute to get around
- #! staging violations
dup array? [
- unclip >r [ dup word? [ def>> call ] when ] map r> prefix
+ unclip >r [
+ dup word? [
+ def>> { } swap with-datastack first
+ ] when
+ ] map r> prefix
] when ;
: malloc-file-contents ( path -- alien len )
binary file-contents dup malloc-byte-array swap length ;
+: if-void ( type true false -- )
+ pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
[
<c-type>
[ alien-cell ] >>getter
diff --git a/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
index c9caeb864b..d69202c7ad 100644
--- a/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
+++ b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
@@ -35,6 +35,12 @@ M: #phi backward
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
2bi ;
+M: #alien-invoke backward
+ nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect backward
+ nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
M: node backward 2drop ;
: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor
index 6703f924fd..652fa19af3 100644
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@@ -23,6 +23,12 @@ M: #call mark-live-values
dup word>> "flushable" word-prop
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
+M: #alien-invoke mark-live-values
+ [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect mark-live-values
+ [ look-at-inputs ] [ look-at-outputs ] bi ;
+
M: #return mark-live-values
look-at-inputs ;
diff --git a/unfinished/compiler/tree/debugger/debugger-tests.factor b/unfinished/compiler/tree/debugger/debugger-tests.factor
index e6a4385c3e..eb0bbd5ce6 100644
--- a/unfinished/compiler/tree/debugger/debugger-tests.factor
+++ b/unfinished/compiler/tree/debugger/debugger-tests.factor
@@ -1,6 +1,5 @@
IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test ;
-\ optimized-quot. must-infer
-\ optimized-word. must-infer
+\ optimized. must-infer
\ optimizer-report. must-infer
diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
index c5b35438b1..c541311ef2 100644
--- a/unfinished/compiler/tree/debugger/debugger.factor
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -22,7 +22,7 @@ MACRO: match-choose ( alist -- )
MATCH-VARS: ?a ?b ?c ;
: pretty-shuffle ( effect -- word/f )
- [ in>> ] [ out>> ] bi {
+ [ in>> ] [ out>> ] bi 2array {
{ { { } { } } [ ] }
{ { { ?a } { ?a } } [ ] }
{ { { ?a ?b } { ?a ?b } } [ ] }
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index c6c407b048..af42dc5145 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -80,3 +80,13 @@ M: #call escape-analysis*
M: #return escape-analysis*
in-d>> add-escaping-values ;
+
+M: #alien-invoke escape-analysis*
+ [ in-d>> add-escaping-values ]
+ [ out-d>> unknown-allocation ]
+ bi ;
+
+M: #alien-indirect escape-analysis*
+ [ in-d>> add-escaping-values ]
+ [ out-d>> unknown-allocation ]
+ bi ;
diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index 4237738625..45bbbf19db 100644
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -115,3 +115,9 @@ M: #call propagate-before
M: #call propagate-after
dup word>> "input-classes" word-prop dup
[ propagate-input-classes ] [ 2drop ] if ;
+
+M: #alien-invoke propagate-before
+ out-d>> [ object-info swap set-value-info ] each ;
+
+M: #alien-indirect propagate-before
+ out-d>> [ object-info swap set-value-info ] each ;
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 3db97fdfe0..175c1ddfdd 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -143,6 +143,30 @@ TUPLE: #copy < #renaming in-d out-d ;
swap >>out-d
swap >>in-d ;
+TUPLE: #alien-node < node params ;
+
+: new-alien-node ( params class -- node )
+ new
+ over in-d>> >>in-d
+ over out-d>> >>out-d
+ swap >>params ; inline
+
+TUPLE: #alien-invoke < #alien-node in-d out-d ;
+
+: #alien-invoke ( params -- node )
+ \ #alien-invoke new-alien-node ;
+
+TUPLE: #alien-indirect < #alien-node in-d out-d ;
+
+: #alien-indirect ( params -- node )
+ \ #alien-indirect new-alien-node ;
+
+TUPLE: #alien-callback < #alien-node ;
+
+: #alien-callback ( params -- node )
+ \ #alien-callback new
+ swap >>params ;
+
: node, ( node -- ) stack-visitor get push ;
GENERIC: inputs/outputs ( #renaming -- inputs outputs )
@@ -177,3 +201,6 @@ M: vector #phi, #phi node, ;
M: vector #declare, #declare node, ;
M: vector #recursive, #recursive node, ;
M: vector #copy, #copy node, ;
+M: vector #alien-invoke, #alien-invoke node, ;
+M: vector #alien-indirect, #alien-indirect node, ;
+M: vector #alien-callback, #alien-callback node, ;
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 3b832917d8..1b92d66db4 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -128,4 +128,8 @@ M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
+M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
+
: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
diff --git a/unfinished/stack-checker/alien/alien.factor b/unfinished/stack-checker/alien/alien.factor
new file mode 100644
index 0000000000..f81b7fdaa3
--- /dev/null
+++ b/unfinished/stack-checker/alien/alien.factor
@@ -0,0 +1,84 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors combinators math namespaces
+init sets words
+alien alien.c-types
+stack-checker.backend stack-checker.errors stack-checker.visitor ;
+IN: stack-checker.alien
+
+TUPLE: alien-node-params return parameters abi in-d out-d ;
+
+TUPLE: alien-invoke-params < alien-node-params library function ;
+
+TUPLE: alien-indirect-params < alien-node-params ;
+
+TUPLE: alien-callback-params < alien-node-params quot xt ;
+
+: pop-parameters ( -- seq )
+ pop-literal nip [ expand-constants ] map ;
+
+: param-prep-quot ( node -- quot )
+ parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
+
+: alien-stack ( params extra -- )
+ over parameters>> length + consume-d >>in-d
+ dup return>> "void" = 0 1 ? produce-d >>out-d
+ drop ;
+
+: return-prep-quot ( node -- quot )
+ return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
+
+: infer-alien-invoke ( -- )
+ alien-invoke-params new
+ ! Compile-time parameters
+ pop-parameters >>parameters
+ pop-literal nip >>function
+ pop-literal nip >>library
+ pop-literal nip >>return
+ ! Quotation which coerces parameters to required types
+ dup param-prep-quot recursive-state get infer-quot
+ ! Set ABI
+ dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
+ ! Magic #: consume exactly the number of inputs
+ dup 0 alien-stack
+ ! Add node to IR
+ dup #alien-invoke,
+ ! Quotation which coerces return value to required type
+ return-prep-quot recursive-state get infer-quot ;
+
+: infer-alien-indirect ( -- )
+ alien-indirect-params new
+ ! Compile-time parameters
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
+ ! Quotation which coerces parameters to required types
+ dup param-prep-quot [ dip ] curry recursive-state get infer-quot
+ ! Magic #: consume the function pointer, too
+ dup 1 alien-stack
+ ! Add node to IR
+ dup #alien-indirect,
+ ! Quotation which coerces return value to required type
+ return-prep-quot recursive-state get infer-quot ;
+
+! Callbacks are registered in a global hashtable. If you clear
+! this hashtable, they will all be blown away by code GC, beware
+SYMBOL: callbacks
+
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
+
+: register-callback ( word -- ) callbacks get conjoin ;
+
+: callback-bottom ( params -- )
+ xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
+ recursive-state get infer-quot ;
+
+: infer-alien-callback ( -- )
+ alien-callback-params new
+ pop-literal nip >>quot
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
+ gensym >>xt
+ dup callback-bottom
+ #alien-callback, ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index fcbf18f01c..3be2e21b7e 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -32,7 +32,7 @@ M: inline-recursive hashcode* id>> hashcode* ;
: <inline-recursive> ( word -- label )
inline-recursive new
- gensym t "inlined-block" set-word-prop >>id
+ gensym dup t "inlined-block" set-word-prop >>id
swap >>word ;
: quotation-param? ( obj -- ? )
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index 2e0c979f98..eb9a9dbdf7 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -10,10 +10,14 @@ sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
-combinators locals.backend stack-checker.state
-stack-checker.backend stack-checker.branches
-stack-checker.errors stack-checker.transforms
-stack-checker.visitor ;
+combinators locals.backend
+stack-checker.state
+stack-checker.backend
+stack-checker.branches
+stack-checker.errors
+stack-checker.transforms
+stack-checker.visitor
+stack-checker.alien ;
IN: stack-checker.known-words
: infer-primitive ( word -- )
@@ -153,13 +157,15 @@ M: object infer-call*
{ \ get-local [ infer-get-local ] }
{ \ drop-locals [ infer-drop-locals ] }
{ \ do-primitive [ \ do-primitive cannot-infer-effect ] }
+ { \ alien-invoke [ infer-alien-invoke ] }
+ { \ alien-indirect [ infer-alien-indirect ] }
+ { \ alien-callback [ infer-alien-callback ] }
} case ;
{
- >r r> declare call curry compose
- execute if dispatch <tuple-boa>
- (throw) load-locals get-local drop-locals
- do-primitive
+ >r r> declare call curry compose execute if dispatch
+ <tuple-boa> (throw) load-locals get-local drop-locals
+ do-primitive alien-invoke alien-indirect alien-callback
} [ t +special+ set-word-prop ] each
{ call execute dispatch load-locals get-local drop-locals }
diff --git a/unfinished/stack-checker/visitor/dummy/dummy.factor b/unfinished/stack-checker/visitor/dummy/dummy.factor
index a1ed5c83a1..381405bd31 100644
--- a/unfinished/stack-checker/visitor/dummy/dummy.factor
+++ b/unfinished/stack-checker/visitor/dummy/dummy.factor
@@ -22,3 +22,6 @@ M: f #declare, drop ;
M: f #recursive, 2drop 2drop ;
M: f #copy, 2drop ;
M: f #drop, drop ;
+M: f #alien-invoke, drop ;
+M: f #alien-indirect, drop ;
+M: f #alien-callback, drop ;
diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor
index 3afc8f752d..25775ca3f0 100644
--- a/unfinished/stack-checker/visitor/visitor.factor
+++ b/unfinished/stack-checker/visitor/visitor.factor
@@ -27,3 +27,6 @@ HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
HOOK: #copy, stack-visitor ( inputs outputs -- )
+HOOK: #alien-invoke, stack-visitor ( params -- )
+HOOK: #alien-indirect, stack-visitor ( params -- )
+HOOK: #alien-callback, stack-visitor ( params -- )
From 762007b28e0e9d47d4ce8cc59eb07c9898d0b92e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 12 Aug 2008 03:18:15 -0500
Subject: [PATCH 21/44] Debugging front-end, updating FFI codegen
---
.../compiler/generator/generator.factor | 321 +++++++++++++++++-
.../known-words/known-words.factor | 4 +-
.../transforms/transforms.factor | 6 +-
3 files changed, 323 insertions(+), 8 deletions(-)
diff --git a/unfinished/compiler/generator/generator.factor b/unfinished/compiler/generator/generator.factor
index 19e60ae19c..a4a7815d70 100755
--- a/unfinished/compiler/generator/generator.factor
+++ b/unfinished/compiler/generator/generator.factor
@@ -2,8 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes combinators
cpu.architecture effects generic hashtables io kernel
-kernel.private layouts math namespaces prettyprint quotations
-sequences system threads words vectors sets dequeues cursors
+kernel.private layouts math math.parser namespaces prettyprint
+quotations sequences system threads words vectors sets dequeues
+cursors continuations.private summary alien alien.c-types
+alien.structs alien.strings alien.arrays libc compiler.errors
stack-checker.inlining
compiler.tree compiler.tree.builder compiler.tree.combinators
compiler.tree.propagation.info compiler.generator.fixup
@@ -48,7 +50,7 @@ SYMBOL: current-label-start
: save-machine-code ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
-: with-generator ( node word label quot -- )
+: with-generator ( nodes word label quot -- )
[
>r begin-compiling r>
{ } make fixup
@@ -267,3 +269,316 @@ M: #return-recursive generate-node
end-basic-block
label>> id>> compiling-loops get key?
[ %return ] unless f ;
+
+! #alien-invoke
+: large-struct? ( ctype -- ? )
+ dup c-struct? [
+ heap-size struct-small-enough? not
+ ] [ drop f ] if ;
+
+: alien-parameters ( params -- seq )
+ dup parameters>>
+ swap return>> large-struct? [ "void*" prefix ] when ;
+
+: alien-return ( params -- ctype )
+ return>> dup large-struct? [ drop "void" ] when ;
+
+: c-type-stack-align ( type -- align )
+ dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
+
+: parameter-align ( n type -- n delta )
+ over >r c-type-stack-align align dup r> - ;
+
+: parameter-sizes ( types -- total offsets )
+ #! Compute stack frame locations.
+ [
+ 0 [
+ [ parameter-align drop dup , ] keep stack-size +
+ ] reduce cell align
+ ] { } make ;
+
+: return-size ( ctype -- n )
+ #! Amount of space we reserve for a return value.
+ dup large-struct? [ heap-size ] [ drop 0 ] if ;
+
+: alien-stack-frame ( params -- n )
+ alien-parameters parameter-sizes drop ;
+
+: alien-invoke-frame ( params -- n )
+ #! One cell is temporary storage, temp@
+ dup return>> return-size
+ swap alien-stack-frame +
+ cell + ;
+
+: set-stack-frame ( n -- )
+ dup [ frame-required ] when* \ stack-frame set ;
+
+: with-stack-frame ( n quot -- )
+ swap set-stack-frame
+ call
+ f set-stack-frame ; inline
+
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
+
+GENERIC: inc-reg-class ( register-class -- )
+
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
+ fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: float-regs inc-reg-class
+ dup call-next-method
+ fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+
+: reg-class-full? ( class -- ? )
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
+
+: spill-param ( reg-class -- n reg-class )
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
+
+: fastcall-param ( reg-class -- n reg-class )
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
+
+: alloc-parameter ( parameter -- reg reg-class )
+ c-type-reg-class dup reg-class-full?
+ [ spill-param ] [ fastcall-param ] if
+ [ param-reg ] keep ;
+
+: (flatten-int-type) ( size -- )
+ cell /i "void*" c-type <repetition> % ;
+
+GENERIC: flatten-value-type ( type -- )
+
+M: object flatten-value-type , ;
+
+M: struct-type flatten-value-type ( type -- )
+ stack-size cell align (flatten-int-type) ;
+
+M: long-long-type flatten-value-type ( type -- )
+ stack-size cell align (flatten-int-type) ;
+
+: flatten-value-types ( params -- params )
+ #! Convert value type structs to consecutive void*s.
+ [
+ 0 [
+ c-type
+ [ parameter-align (flatten-int-type) ] keep
+ [ stack-size cell align + ] keep
+ flatten-value-type
+ ] reduce drop
+ ] { } make ;
+
+: each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2each ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+ >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
+
+: reset-freg-counts ( -- )
+ { int-regs float-regs stack-params } [ 0 swap set ] each ;
+
+: with-param-regs ( quot -- )
+ #! In quot you can call alloc-parameter
+ [ reset-freg-counts call ] with-scope ; inline
+
+: move-parameters ( node word -- )
+ #! Moves values from C stack to registers (if word is
+ #! %load-param-reg) and registers to C stack (if word is
+ #! %save-param-reg).
+ >r
+ alien-parameters
+ flatten-value-types
+ r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+ inline
+
+: unbox-parameters ( offset node -- )
+ parameters>> [
+ %prepare-unbox >r over + r> unbox-parameter
+ ] reverse-each-parameter drop ;
+
+: prepare-box-struct ( node -- offset )
+ #! Return offset on C stack where to store unboxed
+ #! parameters. If the C function is returning a structure,
+ #! the first parameter is an implicit target area pointer,
+ #! so we need to use a different offset.
+ return>> dup large-struct?
+ [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+
+: objects>registers ( params -- )
+ #! Generate code for unboxing a list of C types, then
+ #! generate code for moving these parameters to register on
+ #! architectures where parameters are passed in registers.
+ [
+ [ prepare-box-struct ] keep
+ [ unbox-parameters ] keep
+ \ %load-param-reg move-parameters
+ ] with-param-regs ;
+
+: box-return* ( node -- )
+ return>> [ ] [ box-return ] if-void ;
+
+TUPLE: no-such-library name ;
+
+M: no-such-library summary
+ drop "Library not found" ;
+
+M: no-such-library compiler-error-type
+ drop +linkage+ ;
+
+: no-such-library ( name -- )
+ \ no-such-library boa
+ compiling-word get compiler-error ;
+
+TUPLE: no-such-symbol name ;
+
+M: no-such-symbol summary
+ drop "Symbol not found" ;
+
+M: no-such-symbol compiler-error-type
+ drop +linkage+ ;
+
+: no-such-symbol ( name -- )
+ \ no-such-symbol boa
+ compiling-word get compiler-error ;
+
+: check-dlsym ( symbols dll -- )
+ dup dll-valid? [
+ dupd [ dlsym ] curry contains?
+ [ drop ] [ no-such-symbol ] if
+ ] [
+ dll-path no-such-library drop
+ ] if ;
+
+: stdcall-mangle ( symbol node -- symbol )
+ "@"
+ swap parameters>> parameter-sizes drop
+ number>string 3append ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
+ 2dup check-dlsym ;
+
+M: #alien-invoke generate-node
+ params>>
+ dup alien-invoke-frame [
+ end-basic-block
+ %prepare-alien-invoke
+ dup objects>registers
+ %prepare-var-args
+ dup alien-invoke-dlsym %alien-invoke
+ dup %cleanup
+ box-return*
+ iterate-next
+ ] with-stack-frame ;
+
+! #alien-indirect
+M: #alien-indirect generate-node
+ params>>
+ dup alien-invoke-frame [
+ ! Flush registers
+ end-basic-block
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Save alien at top of stack to temporary storage
+ %prepare-alien-indirect
+ dup objects>registers
+ %prepare-var-args
+ ! Call alien in temporary storage
+ %alien-indirect
+ dup %cleanup
+ box-return*
+ iterate-next
+ ] with-stack-frame ;
+
+! #alien-callback
+: box-parameters ( params -- )
+ alien-parameters [ box-parameter ] each-parameter ;
+
+: registers>objects ( node -- )
+ [
+ dup \ %save-param-reg move-parameters
+ "nest_stacks" f %alien-invoke
+ box-parameters
+ ] with-param-regs ;
+
+TUPLE: callback-context ;
+
+: current-callback 2 getenv ;
+
+: wait-to-return ( token -- )
+ dup current-callback eq? [
+ drop
+ ] [
+ yield wait-to-return
+ ] if ;
+
+: do-callback ( quot token -- )
+ init-catchstack
+ dup 2 setenv
+ slip
+ wait-to-return ; inline
+
+: callback-return-quot ( ctype -- quot )
+ return>> {
+ { [ dup "void" = ] [ drop [ ] ] }
+ { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+ [ c-type c-type-unboxer-quot ]
+ } cond ;
+
+: callback-prep-quot ( params -- quot )
+ parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+ [
+ [ callback-prep-quot ]
+ [ quot>> ]
+ [ callback-return-quot ] tri 3append ,
+ [ callback-context new do-callback ] %
+ ] [ ] make ;
+
+: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+
+: callback-unwind ( params -- n )
+ {
+ { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
+ [ drop 0 ]
+ } cond ;
+
+: %callback-return ( params -- )
+ #! All the extra book-keeping for %unwind is only for x86.
+ #! On other platforms its an alias for %return.
+ dup alien-return
+ [ %unnest-stacks ] [ %callback-value ] if-void
+ callback-unwind %unwind ;
+
+: generate-callback ( params -- )
+ dup xt>> dup [
+ init-templates
+ %prologue-later
+ dup alien-stack-frame [
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ %callback-return ]
+ tri
+ ] with-stack-frame
+ ] with-generator ;
+
+M: #alien-callback generate-node
+ end-basic-block
+ params>> generate-callback iterate-next ;
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index eb9a9dbdf7..a0c91f679b 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -179,10 +179,10 @@ SYMBOL: +primitive+
{ [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
{ [ dup +special+ word-prop ] [ infer-special ] }
{ [ dup +primitive+ word-prop ] [ infer-primitive ] }
- { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
{ [ dup +transform-quot+ word-prop ] [ apply-transform ] }
- { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
{ [ dup "macro" word-prop ] [ apply-macro ] }
+ { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
+ { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
{ [ dup recursive-label ] [ call-recursive-word ] }
[ dup infer-word apply-word/effect ]
} cond ;
diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor
index d9e889f188..f22960dd39 100755
--- a/unfinished/stack-checker/transforms/transforms.factor
+++ b/unfinished/stack-checker/transforms/transforms.factor
@@ -23,10 +23,11 @@ SYMBOL: +transform-n+
inline
: (apply-transform) ( word quot n -- )
- consume-d dup [ known literal? ] all? [
+ dup ensure-d [ known literal? ] all? [
dup empty? [
drop recursive-state get 1array
] [
+ consume-d
[ #drop, ]
[ [ literal value>> ] map ]
[ first literal recursion>> ] tri prefix
@@ -123,7 +124,6 @@ SYMBOL: +transform-n+
: bit-member-quot ( seq -- newquot )
[
- [ drop ] % ! drop the sequence itself; we don't use it at run time
bit-member-seq ,
[
{
@@ -140,7 +140,7 @@ SYMBOL: +transform-n+
bit-member-quot
] [
[ literalize [ t ] ] { } map>assoc
- [ drop f ] suffix [ nip case ] curry
+ [ drop f ] suffix [ case ] curry
] if ;
\ member? [
From 359bff5f154caaaaa9ed5037e78d43033cdf48b3 Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Tue, 12 Aug 2008 11:24:00 -0400
Subject: [PATCH 22/44] Derivatives without dynamics OR locals
---
extra/math/derivatives/authors.txt | 3 +-
.../math/derivatives/derivatives-docs.factor | 66 ++++++-
extra/math/derivatives/derivatives.factor | 175 ++++++++++++------
3 files changed, 181 insertions(+), 63 deletions(-)
diff --git a/extra/math/derivatives/authors.txt b/extra/math/derivatives/authors.txt
index 137b1605da..3be8a6d4d3 100644
--- a/extra/math/derivatives/authors.txt
+++ b/extra/math/derivatives/authors.txt
@@ -1 +1,2 @@
-Reginald Ford
\ No newline at end of file
+Reginald Ford
+Eduardo Cavazos
\ No newline at end of file
diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor
index 0db52adfa5..a78a697b76 100644
--- a/extra/math/derivatives/derivatives-docs.factor
+++ b/extra/math/derivatives/derivatives-docs.factor
@@ -1,5 +1,4 @@
-USING: help.markup help.syntax ;
-
+USING: help.markup help.syntax math.functions ;
IN: math.derivatives
HELP: derivative ( x function -- m )
@@ -21,6 +20,46 @@ HELP: derivative ( x function -- m )
}
} ;
+HELP: (derivative) ( x function h err -- m )
+{ $values
+ { "x" "a position on the function" }
+ { "function" "a differentiable function" }
+ {
+ "h" "distance between the points of the first secant line used for "
+ "approximation of the tangent. This distance will be divided "
+ "constantly, by " { $link con } ". See " { $link init-hh }
+ " for the code which enforces this. H should be .001 to .5 -- too "
+ "small can cause bad convergence. Also, h should be small enough "
+ "to give the correct sgn(f'(x)). In other words, if you're expecting "
+ "a positive derivative, make h small enough to give the same "
+ "when plugged into the academic limit definition of a derivative. "
+ "See " { $link update-hh } " for the code which performs this task."
+ }
+ {
+ "err" "maximum tolerance of increase in error. For example, if this "
+ "is set to 2.0, the program will terminate with its nearest answer "
+ "when the error multiplies by 2. See " { $link check-safe } " for "
+ "the enforcing code."
+ }
+}
+{ $description
+ "Approximates the slope of the tangent line by using Ridders' "
+ "method of computing derivatives, from the chapter \"Accurate computation "
+ "of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, "
+ "Vol. 4, pp. 75-76 ."
+}
+{ $examples
+ { $example
+ "USING: math.derivatives prettyprint ;"
+ "[ sq ] 4 derivative ."
+ "8"
+ }
+ { $notes
+ "For applied scientists, you may play with the settings "
+ "in the source file to achieve arbitrary accuracy. "
+ }
+} ;
+
HELP: derivative-func ( function -- der )
{ $values { "func" "a differentiable function" } { "der" "the derivative" } }
{ $description
@@ -30,8 +69,27 @@ HELP: derivative-func ( function -- der )
{ $examples
{ $example
"USING: math.derivatives prettyprint ;"
- "[ sq ] derivative-func ."
- "[ [ sq ] derivative ]"
+ "60 deg>rad [ sin ] derivative-func call ."
+ "0.5000000000000173"
+ }
+ { $notes
+ "Without a heavy algebraic system, derivatives must be "
+ "approximated. With the current settings, there is a fair trade of "
+ "speed and accuracy; the first 12 digits "
+ "will always be correct with " { $link sin } " and " { $link cos }
+ ". The following code performs a minumum and maximum error test."
+ { $code
+ "USING: kernel math math.functions math.trig sequences sequences.lib ;"
+ "360"
+ "["
+ " deg>rad"
+ " [ [ sin ] derivative-func call ]"
+ " ! Note: the derivative of sin is cos"
+ " [ cos ]"
+ " bi - abs"
+ "] map minmax"
+
+ }
}
} ;
diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor
index 96d0fc3a81..ad8d944bfe 100644
--- a/extra/math/derivatives/derivatives.factor
+++ b/extra/math/derivatives/derivatives.factor
@@ -1,64 +1,123 @@
-! Tools for approximating derivatives
-USING: kernel math math.functions locals generalizations float-arrays sequences
-math.constants namespaces math.function-tools math.points math.ranges math.order ;
+USING: kernel continuations combinators sequences math
+ math.order math.ranges accessors float-arrays ;
+
IN: math.derivatives
+TUPLE: state x func h err i j errt fac hh ans a done ;
+
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
-: ntab 10 ; ! max size of tableau (main accuracy setting)
-: con 1.41 ; ! stepsize is decreased by this per-iteration
-: con2 1.9881 ; ! con^2
-: initial-h 0.02 ; ! distance of the 2 points of the first secant line
-: safe 2.0 ; ! return when current err is SAFE worse than the best
- ! \ safe probably should not be changed
-SYMBOL: i
-SYMBOL: j
-SYMBOL: err
-SYMBOL: errt
-SYMBOL: fac
-SYMBOL: h
-SYMBOL: ans
-SYMBOL: matrix
+: ntab ( -- val ) 8 ;
+: con ( -- val ) 1.6 ;
+: con2 ( -- val ) con con * ;
+: big ( -- val ) largest-float ;
+: safe ( -- val ) 2.0 ;
-: (derivative) ( x function -- m )
- [ [ h get + ] dip eval ]
- [ [ h get - ] dip eval ]
- 2bi slope ; inline
-: init-matrix ( -- )
- ntab [ ntab <float-array> ] replicate
- matrix set ;
-: m-set ( value j i -- ) matrix get nth set-nth ;
-: m-get ( j i -- n ) matrix get nth nth ;
-:: derivative ( x func -- m )
- init-matrix
- initial-h h set
- x func (derivative) 0 0 m-set
- largest-float err set
- ntab 1 - [1,b] [| i |
- h [ con / ] change
- x func (derivative) 0 i m-set
- con2 fac set
- i [1,b] [| j |
- j 1 - i m-get fac get *
- j 1 - i 1 - m-get
- -
- fac get 1 -
- / j i m-set
- fac [ con2 * ] change
- j i m-get j 1 - i m-get - abs
- j i m-get j 1 - i 1 - m-get - abs
- max errt set
- errt get err get <=
- [
- errt get err set
- j i m-get ans set
- ] [ ]
- if
- ] each
- i i m-get i 1 - dup m-get - abs
- err get safe *
- <
- ] all? drop
- ans get ; inline
-: derivative-func ( function -- function ) [ derivative ] curry ; inline
+! Yes, this was ported from C code.
+: a[i][i] ( state -- elt ) [ i>> ] [ i>> ] [ a>> ] tri nth nth ;
+: a[j][i] ( state -- elt ) [ i>> ] [ j>> ] [ a>> ] tri nth nth ;
+: a[j-1][i] ( state -- elt ) [ i>> ] [ j>> 1 - ] [ a>> ] tri nth nth ;
+: a[j-1][i-1] ( state -- elt ) [ i>> 1 - ] [ j>> 1 - ] [ a>> ] tri nth nth ;
+: a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
+: check-h ( state -- state )
+ dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+: init-a ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
+: init-hh ( state -- state ) dup h>> >>hh ;
+: init-err ( state -- state ) big >>err ;
+: update-hh ( state -- state ) dup hh>> con / >>hh ;
+: reset-fac ( state -- state ) con2 >>fac ;
+: update-fac ( state -- state ) dup fac>> con2 * >>fac ;
+
+! If error is decreased, save the improved answer
+: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
+: save-improved-answer ( state -- state )
+ dup err>> >>errt
+ dup a[j][i] >>ans ;
+
+! If higher order is worse by a significant factor SAFE, then quit early.
+: check-safe ( state -- state )
+ dup
+ [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >=
+ [ t >>done ]
+ when ;
+: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
+: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
+: limit-approx ( state -- val )
+ [
+ [ [ x+hh ] [ func>> ] bi call ]
+ [ [ x-hh ] [ func>> ] bi call ]
+ bi -
+ ]
+ [ hh>> 2.0 * ]
+ bi / ;
+: a[0][0]! ( state -- state )
+ { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+: a[0][i]! ( state -- state )
+ { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+: a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
+: new-a[j][i] ( state -- val )
+ [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
+ [ fac>> 1.0 - ]
+ bi / ;
+: a[j][i]! ( state -- state )
+ { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
+
+: update-errt ( state -- state )
+ dup
+ [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
+ [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
+ bi max
+ >>errt ;
+
+: not-done? ( state -- state ? ) dup done>> not ;
+
+: derive ( state -- state )
+ init-a
+ check-h
+ init-hh
+ a[0][0]!
+ init-err
+ 1 ntab [a,b)
+ [
+ >>i
+ not-done?
+ [
+ update-hh
+ a[0][i]!
+ reset-fac
+ 1 over i>> [a,b]
+ [
+ >>j
+ a[j][i]!
+ update-fac
+ update-errt
+ error-decreased? [ save-improved-answer ] when
+ ]
+ each
+ check-safe
+ ]
+ when
+ ]
+ each ;
+
+: derivative-state ( x func h err -- state )
+ state new
+ swap >>err
+ swap >>h
+ swap >>func
+ swap >>x ;
+
+! For scientists:
+! h should be .001 to .5 -- too small can cause bad convergence,
+! h should be small enough to give the correct sgn(f'(x))
+! err is the max tolerance of gain in error for a single iteration-
+: (derivative) ( x func h err -- ans error )
+ derivative-state
+ derive
+ [ ans>> ]
+ [ errt>> ]
+ bi ;
+
+: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
+: derivative-func ( func -- der ) [ derivative ] curry ;
\ No newline at end of file
From 6f767add2c4fada948553e2639888a6539d7ae1c Mon Sep 17 00:00:00 2001
From: Rex Ford <Rex@Macintosh-4.local>
Date: Tue, 12 Aug 2008 12:00:54 -0400
Subject: [PATCH 23/44] documentation for scientists
---
extra/math/derivatives/derivatives-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor
index a78a697b76..15dd954b1c 100644
--- a/extra/math/derivatives/derivatives-docs.factor
+++ b/extra/math/derivatives/derivatives-docs.factor
@@ -96,5 +96,6 @@ HELP: derivative-func ( function -- der )
ARTICLE: "derivatives" "The Derivative Toolkit"
"A toolkit for computing the derivative of functions."
{ $subsection derivative }
-{ $subsection derivative-func } ;
+{ $subsection derivative-func }
+{ $subsection (derivative) } ;
ABOUT: "derivatives"
From 8b3ce1ee841c78832671726066588d075226e008 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Wed, 13 Aug 2008 01:00:26 -0400
Subject: [PATCH 24/44] irc:Added whois command, fixed bug in parting
---
extra/irc/messages/messages.factor | 2 +-
extra/irc/ui/commands/commands.factor | 6 +++++-
2 files changed, 6 insertions(+), 2 deletions(-)
mode change 100644 => 100755 extra/irc/messages/messages.factor
diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor
old mode 100644
new mode 100755
index 3b9cf0af2c..fb56dd3a45
--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@@ -46,7 +46,7 @@ GENERIC: irc-command-parameters ( irc-message -- seq )
M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ;
M: ping irc-command-parameters ( ping -- seq ) drop { } ;
M: join irc-command-parameters ( join -- seq ) drop { } ;
-M: part irc-command-parameters ( part -- seq ) name>> 1array ;
+M: part irc-command-parameters ( part -- seq ) channel>> 1array ;
M: quit irc-command-parameters ( quit -- seq ) drop { } ;
M: nick irc-command-parameters ( nick -- seq ) drop { } ;
M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ;
diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor
index ddae783f06..184a2b4de8 100755
--- a/extra/irc/ui/commands/commands.factor
+++ b/extra/irc/ui/commands/commands.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 William Schlieper
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
+USING: accessors kernel arrays irc.client irc.messages irc.ui namespaces ;
IN: irc.ui.commands
@@ -16,5 +16,9 @@ IN: irc.ui.commands
: query ( string -- )
irc-tab get window>> query-nick ;
+: whois ( string -- )
+ "WHOIS" swap { } clone swap <irc-client-message>
+ irc-tab get listener>> write-message ;
+
: quote ( string -- )
drop ; ! THIS WILL CHANGE
From 6f78e38ab4c3dd474c3b16f747fd88e1056043a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 Aug 2008 14:19:48 -0500
Subject: [PATCH 25/44] Add a couple of words to disjoint-sets
---
basis/disjoint-sets/disjoint-sets.factor | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor
index f48129fbd4..77e4a53f7b 100644
--- a/basis/disjoint-sets/disjoint-sets.factor
+++ b/basis/disjoint-sets/disjoint-sets.factor
@@ -88,6 +88,14 @@ M:: disjoint-set equate ( a b disjoint-set -- )
disjoint-set link-sets
] if ;
+: equate-all-with ( seq a disjoint-set -- )
+ '[ , , equate ] each ;
+
+: equate-all ( seq disjoint-set -- )
+ over dup empty? [ 2drop ] [
+ [ unclip-slice ] dip equate-all-with
+ ] if ;
+
M: disjoint-set clone
[ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
disjoint-set boa ;
From 35a1ca3201a6af3b9354ea6a4e852e38c337ef69 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 Aug 2008 14:19:58 -0500
Subject: [PATCH 26/44] Improve ranges docs
---
basis/math/ranges/ranges-docs.factor | 40 ++++++++++++++++------------
1 file changed, 23 insertions(+), 17 deletions(-)
diff --git a/basis/math/ranges/ranges-docs.factor b/basis/math/ranges/ranges-docs.factor
index 714fc67c9f..f3c65e51a4 100644
--- a/basis/math/ranges/ranges-docs.factor
+++ b/basis/math/ranges/ranges-docs.factor
@@ -1,21 +1,27 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup arrays sequences ;
IN: math.ranges
ARTICLE: "ranges" "Ranges"
-
- "A " { $emphasis "range" } " is a virtual sequence with real elements "
- "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
-
- $nl
-
- "Creating ranges:"
-
- { $subsection <range> }
- { $subsection [a,b] }
- { $subsection (a,b] }
- { $subsection [a,b) }
- { $subsection (a,b) }
- { $subsection [0,b] }
- { $subsection [1,b] }
- { $subsection [0,b) } ;
\ No newline at end of file
+"A " { $emphasis "range" } " is a virtual sequence with real number elements "
+"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
+$nl
+"The class of ranges:"
+{ $subsection range }
+"Creating ranges with integer end-points. The standard mathematical convention is used, where " { $snippet "(" } " or " { $snippet ")" } " denotes that the end-point itself " { $emphasis "is not" } " part of the range; " { $snippet "[" } " or " { $snippet "]" } " denotes that the end-point " { $emphasis "is" } " part of the range:"
+{ $subsection [a,b] }
+{ $subsection (a,b] }
+{ $subsection [a,b) }
+{ $subsection (a,b) }
+{ $subsection [0,b] }
+{ $subsection [1,b] }
+{ $subsection [0,b) }
+"Creating general ranges:"
+{ $subsection <range> }
+"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example,"
+{ $code
+ "3 10 [a,b] [ sqrt ] map"
+}
+"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
+
+ABOUT: "ranges"
\ No newline at end of file
From f683c63da1c5a66a9e4a1ebc08bad7d7be79c9fe Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 Aug 2008 14:20:09 -0500
Subject: [PATCH 27/44] Fix code duplication
---
extra/math/combinatorics/combinatorics.factor | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor
index f7d7b76fa4..6193edfb91 100644
--- a/extra/math/combinatorics/combinatorics.factor
+++ b/extra/math/combinatorics/combinatorics.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.order math.ranges mirrors
-namespaces sequences sorting ;
+namespaces sequences sequences.lib sorting ;
IN: math.combinatorics
<PRIVATE
@@ -27,9 +27,6 @@ IN: math.combinatorics
: permutation-indices ( n seq -- permutation )
length [ factoradic ] dip 0 pad-left >permutation ;
-: reorder ( seq indices -- seq )
- [ [ over nth , ] each drop ] { } make ;
-
PRIVATE>
: factorial ( n -- n! )
@@ -42,7 +39,7 @@ PRIVATE>
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
- tuck permutation-indices reorder ;
+ tuck permutation-indices nths ;
: all-permutations ( seq -- seq )
[
From bbb3597ac2a45207d33455f4cc165607d859f25e Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@self.internal.stack-effects.com>
Date: Wed, 13 Aug 2008 15:13:55 -0500
Subject: [PATCH 28/44] add a couple constants for unix file access
---
basis/unix/bsd/bsd.factor | 17 +++++++++--------
basis/unix/linux/linux.factor | 17 +++++++++--------
basis/unix/unix.factor | 2 ++
3 files changed, 20 insertions(+), 16 deletions(-)
diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor
index 0c669d2258..68444de85f 100755
--- a/basis/unix/bsd/bsd.factor
+++ b/basis/unix/bsd/bsd.factor
@@ -7,13 +7,15 @@ IN: unix
: MAXPATHLEN 1024 ; inline
-: O_RDONLY HEX: 0000 ; inline
-: O_WRONLY HEX: 0001 ; inline
-: O_RDWR HEX: 0002 ; inline
-: O_APPEND HEX: 0008 ; inline
-: O_CREAT HEX: 0200 ; inline
-: O_TRUNC HEX: 0400 ; inline
-: O_EXCL HEX: 0800 ; inline
+: O_RDONLY HEX: 0000 ; inline
+: O_WRONLY HEX: 0001 ; inline
+: O_RDWR HEX: 0002 ; inline
+: O_NONBLOCK HEX: 0004 ; inline
+: O_APPEND HEX: 0008 ; inline
+: O_CREAT HEX: 0200 ; inline
+: O_TRUNC HEX: 0400 ; inline
+: O_EXCL HEX: 0800 ; inline
+: O_NOCTTY HEX: 20000 ; inline
: SOL_SOCKET HEX: ffff ; inline
: SO_REUSEADDR HEX: 4 ; inline
@@ -24,7 +26,6 @@ IN: unix
: F_SETFD 2 ; inline
: F_SETFL 4 ; inline
: FD_CLOEXEC 1 ; inline
-: O_NONBLOCK 4 ; inline
C-STRUCT: sockaddr-in
{ "uchar" "len" }
diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor
index 0efacee294..cc1e056b8b 100755
--- a/basis/unix/linux/linux.factor
+++ b/basis/unix/linux/linux.factor
@@ -7,13 +7,15 @@ USING: alien.syntax ;
: MAXPATHLEN 1024 ; inline
-: O_RDONLY HEX: 0000 ; inline
-: O_WRONLY HEX: 0001 ; inline
-: O_RDWR HEX: 0002 ; inline
-: O_CREAT HEX: 0040 ; inline
-: O_EXCL HEX: 0080 ; inline
-: O_TRUNC HEX: 0200 ; inline
-: O_APPEND HEX: 0400 ; inline
+: O_RDONLY HEX: 0000 ; inline
+: O_WRONLY HEX: 0001 ; inline
+: O_RDWR HEX: 0002 ; inline
+: O_CREAT HEX: 0040 ; inline
+: O_EXCL HEX: 0080 ; inline
+: O_NOCTTY HEX: 0100 ; inline
+: O_TRUNC HEX: 0200 ; inline
+: O_APPEND HEX: 0400 ; inline
+: O_NONBLOCK HEX: 0800 ; inline
: SOL_SOCKET 1 ; inline
@@ -28,7 +30,6 @@ USING: alien.syntax ;
: FD_CLOEXEC 1 ; inline
: F_SETFL 4 ; inline
-: O_NONBLOCK HEX: 800 ; inline
C-STRUCT: addrinfo
{ "int" "flags" }
diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor
index 083700493d..065087fa59 100755
--- a/basis/unix/unix.factor
+++ b/basis/unix/unix.factor
@@ -25,6 +25,8 @@ TYPEDEF: uint socklen_t
: NGROUPS_MAX 16 ; inline
+: O_NDELAY O_NONBLOCK ; inline
+
C-STRUCT: group
{ "char*" "gr_name" }
{ "char*" "gr_passwd" }
From 21fb13f4504aa5e8070c19d9a18c4b904f0135b9 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@self.internal.stack-effects.com>
Date: Wed, 13 Aug 2008 15:18:50 -0500
Subject: [PATCH 29/44] initial chicken of serial
---
extra/serial/authors.txt | 1 +
extra/serial/serial.factor | 23 ++++
extra/serial/summary.txt | 1 +
extra/serial/tags.txt | 1 +
extra/serial/unix/bsd/bsd.factor | 11 ++
extra/serial/unix/bsd/tags.txt | 1 +
extra/serial/unix/linux/linux.factor | 130 +++++++++++++++++++
extra/serial/unix/linux/tags.txt | 1 +
extra/serial/unix/tags.txt | 1 +
extra/serial/unix/termios/bsd/bsd.factor | 19 +++
extra/serial/unix/termios/bsd/tags.txt | 1 +
extra/serial/unix/termios/linux/linux.factor | 20 +++
extra/serial/unix/termios/linux/tags.txt | 1 +
extra/serial/unix/termios/tags.txt | 1 +
extra/serial/unix/termios/termios.factor | 9 ++
extra/serial/unix/unix-tests.factor | 21 +++
extra/serial/unix/unix.factor | 63 +++++++++
17 files changed, 305 insertions(+)
create mode 100644 extra/serial/authors.txt
create mode 100644 extra/serial/serial.factor
create mode 100644 extra/serial/summary.txt
create mode 100644 extra/serial/tags.txt
create mode 100644 extra/serial/unix/bsd/bsd.factor
create mode 100644 extra/serial/unix/bsd/tags.txt
create mode 100644 extra/serial/unix/linux/linux.factor
create mode 100644 extra/serial/unix/linux/tags.txt
create mode 100644 extra/serial/unix/tags.txt
create mode 100644 extra/serial/unix/termios/bsd/bsd.factor
create mode 100644 extra/serial/unix/termios/bsd/tags.txt
create mode 100644 extra/serial/unix/termios/linux/linux.factor
create mode 100644 extra/serial/unix/termios/linux/tags.txt
create mode 100644 extra/serial/unix/termios/tags.txt
create mode 100644 extra/serial/unix/termios/termios.factor
create mode 100644 extra/serial/unix/unix-tests.factor
create mode 100644 extra/serial/unix/unix.factor
diff --git a/extra/serial/authors.txt b/extra/serial/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/serial/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/serial/serial.factor b/extra/serial/serial.factor
new file mode 100644
index 0000000000..39a63927da
--- /dev/null
+++ b/extra/serial/serial.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators destructors
+kernel math math.bitfields math.parser sequences summary system
+vocabs.loader ;
+IN: serial
+
+TUPLE: serial stream path baud
+ termios iflag oflag cflag lflag ;
+
+ERROR: invalid-baud baud ;
+M: invalid-baud summary ( invalid-baud -- string )
+ "Baud rate "
+ swap baud>> number>string
+ " not supported" 3append ;
+
+HOOK: lookup-baud os ( m -- n )
+HOOK: open-serial os ( serial -- serial' )
+M: serial dispose ( serial -- ) stream>> dispose ;
+
+{
+ { [ os unix? ] [ "serial.unix" ] }
+} cond require
diff --git a/extra/serial/summary.txt b/extra/serial/summary.txt
new file mode 100644
index 0000000000..5ccd99dbaa
--- /dev/null
+++ b/extra/serial/summary.txt
@@ -0,0 +1 @@
+Serial port library
diff --git a/extra/serial/tags.txt b/extra/serial/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/serial/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/serial/unix/bsd/bsd.factor b/extra/serial/unix/bsd/bsd.factor
new file mode 100644
index 0000000000..68aaa03a23
--- /dev/null
+++ b/extra/serial/unix/bsd/bsd.factor
@@ -0,0 +1,11 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences system serial ;
+IN: serial.unix
+
+M: bsd lookup-baud ( m -- n )
+ dup {
+ 0 50 75 110 134 150 200 300 600 1200 1800 2400 4800
+ 7200 9600 14400 19200 28800 38400 57600 76800 115200
+ 230400 460800 921600
+ } member? [ invalid-baud ] unless ;
diff --git a/extra/serial/unix/bsd/tags.txt b/extra/serial/unix/bsd/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/serial/unix/bsd/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/serial/unix/linux/linux.factor b/extra/serial/unix/linux/linux.factor
new file mode 100644
index 0000000000..3ad5088fc8
--- /dev/null
+++ b/extra/serial/unix/linux/linux.factor
@@ -0,0 +1,130 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs alien.syntax kernel serial system unix ;
+IN: serial.unix
+
+: TCSANOW 0 ; inline
+: TCSADRAIN 1 ; inline
+: TCSAFLUSH 2 ; inline
+
+: TCIFLUSH 0 ; inline
+: TCOFLUSH 1 ; inline
+: TCIOFLUSH 2 ; inline
+
+: TCOOFF 0 ; inline
+: TCOON 1 ; inline
+: TCIOFF 2 ; inline
+: TCION 3 ; inline
+
+! iflag
+: IGNBRK OCT: 0000001 ; inline
+: BRKINT OCT: 0000002 ; inline
+: IGNPAR OCT: 0000004 ; inline
+: PARMRK OCT: 0000010 ; inline
+: INPCK OCT: 0000020 ; inline
+: ISTRIP OCT: 0000040 ; inline
+: INLCR OCT: 0000100 ; inline
+: IGNCR OCT: 0000200 ; inline
+: ICRNL OCT: 0000400 ; inline
+: IUCLC OCT: 0001000 ; inline
+: IXON OCT: 0002000 ; inline
+: IXANY OCT: 0004000 ; inline
+: IXOFF OCT: 0010000 ; inline
+: IMAXBEL OCT: 0020000 ; inline
+: IUTF8 OCT: 0040000 ; inline
+
+! oflag
+: OPOST OCT: 0000001 ; inline
+: OLCUC OCT: 0000002 ; inline
+: ONLCR OCT: 0000004 ; inline
+: OCRNL OCT: 0000010 ; inline
+: ONOCR OCT: 0000020 ; inline
+: ONLRET OCT: 0000040 ; inline
+: OFILL OCT: 0000100 ; inline
+: OFDEL OCT: 0000200 ; inline
+: NLDLY OCT: 0000400 ; inline
+: NL0 OCT: 0000000 ; inline
+: NL1 OCT: 0000400 ; inline
+: CRDLY OCT: 0003000 ; inline
+: CR0 OCT: 0000000 ; inline
+: CR1 OCT: 0001000 ; inline
+: CR2 OCT: 0002000 ; inline
+: CR3 OCT: 0003000 ; inline
+: TABDLY OCT: 0014000 ; inline
+: TAB0 OCT: 0000000 ; inline
+: TAB1 OCT: 0004000 ; inline
+: TAB2 OCT: 0010000 ; inline
+: TAB3 OCT: 0014000 ; inline
+: BSDLY OCT: 0020000 ; inline
+: BS0 OCT: 0000000 ; inline
+: BS1 OCT: 0020000 ; inline
+: FFDLY OCT: 0100000 ; inline
+: FF0 OCT: 0000000 ; inline
+: FF1 OCT: 0100000 ; inline
+
+! cflags
+: CSIZE OCT: 0000060 ; inline
+: CS5 OCT: 0000000 ; inline
+: CS6 OCT: 0000020 ; inline
+: CS7 OCT: 0000040 ; inline
+: CS8 OCT: 0000060 ; inline
+: CSTOPB OCT: 0000100 ; inline
+: CREAD OCT: 0000200 ; inline
+: PARENB OCT: 0000400 ; inline
+: PARODD OCT: 0001000 ; inline
+: HUPCL OCT: 0002000 ; inline
+: CLOCAL OCT: 0004000 ; inline
+: CIBAUD OCT: 002003600000 ; inline
+: CRTSCTS OCT: 020000000000 ; inline
+
+! lflags
+: ISIG OCT: 0000001 ; inline
+: ICANON OCT: 0000002 ; inline
+: XCASE OCT: 0000004 ; inline
+: ECHO OCT: 0000010 ; inline
+: ECHOE OCT: 0000020 ; inline
+: ECHOK OCT: 0000040 ; inline
+: ECHONL OCT: 0000100 ; inline
+: NOFLSH OCT: 0000200 ; inline
+: TOSTOP OCT: 0000400 ; inline
+: ECHOCTL OCT: 0001000 ; inline
+: ECHOPRT OCT: 0002000 ; inline
+: ECHOKE OCT: 0004000 ; inline
+: FLUSHO OCT: 0010000 ; inline
+: PENDIN OCT: 0040000 ; inline
+: IEXTEN OCT: 0100000 ; inline
+
+M: linux lookup-baud ( n -- n )
+ dup H{
+ { 0 OCT: 0000000 }
+ { 50 OCT: 0000001 }
+ { 75 OCT: 0000002 }
+ { 110 OCT: 0000003 }
+ { 134 OCT: 0000004 }
+ { 150 OCT: 0000005 }
+ { 200 OCT: 0000006 }
+ { 300 OCT: 0000007 }
+ { 600 OCT: 0000010 }
+ { 1200 OCT: 0000011 }
+ { 1800 OCT: 0000012 }
+ { 2400 OCT: 0000013 }
+ { 4800 OCT: 0000014 }
+ { 9600 OCT: 0000015 }
+ { 19200 OCT: 0000016 }
+ { 38400 OCT: 0000017 }
+ { 57600 OCT: 0010001 }
+ { 115200 OCT: 0010002 }
+ { 230400 OCT: 0010003 }
+ { 460800 OCT: 0010004 }
+ { 500000 OCT: 0010005 }
+ { 576000 OCT: 0010006 }
+ { 921600 OCT: 0010007 }
+ { 1000000 OCT: 0010010 }
+ { 1152000 OCT: 0010011 }
+ { 1500000 OCT: 0010012 }
+ { 2000000 OCT: 0010013 }
+ { 2500000 OCT: 0010014 }
+ { 3000000 OCT: 0010015 }
+ { 3500000 OCT: 0010016 }
+ { 4000000 OCT: 0010017 }
+ } at* [ nip ] [ drop invalid-baud ] if ;
diff --git a/extra/serial/unix/linux/tags.txt b/extra/serial/unix/linux/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/serial/unix/linux/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/serial/unix/tags.txt b/extra/serial/unix/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/serial/unix/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/serial/unix/termios/bsd/bsd.factor b/extra/serial/unix/termios/bsd/bsd.factor
new file mode 100644
index 0000000000..c8f1e8be54
--- /dev/null
+++ b/extra/serial/unix/termios/bsd/bsd.factor
@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences system ;
+IN: serial.unix.termios
+
+: NCCS 20 ; inline
+
+TYPEDEF: uint tcflag_t
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+
+C-STRUCT: termios
+ { "tcflag_t" "iflag" } ! input mode flags
+ { "tcflag_t" "oflag" } ! output mode flags
+ { "tcflag_t" "cflag" } ! control mode flags
+ { "tcflag_t" "lflag" } ! local mode flags
+ { { "cc_t" NCCS } "cc" } ! control characters
+ { "speed_t" "ispeed" } ! input speed
+ { "speed_t" "ospeed" } ; ! output speed
diff --git a/extra/serial/unix/termios/bsd/tags.txt b/extra/serial/unix/termios/bsd/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/serial/unix/termios/bsd/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/serial/unix/termios/linux/linux.factor b/extra/serial/unix/termios/linux/linux.factor
new file mode 100644
index 0000000000..de9906e2b9
--- /dev/null
+++ b/extra/serial/unix/termios/linux/linux.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel system unix ;
+IN: serial.unix.termios
+
+: NCCS 32 ; inline
+
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+TYPEDEF: uint tcflag_t
+
+C-STRUCT: termios
+ { "tcflag_t" "iflag" } ! input mode flags
+ { "tcflag_t" "oflag" } ! output mode flags
+ { "tcflag_t" "cflag" } ! control mode flags
+ { "tcflag_t" "lflag" } ! local mode flags
+ { "cc_t" "line" } ! line discipline
+ { { "cc_t" NCCS } "cc" } ! control characters
+ { "speed_t" "ispeed" } ! input speed
+ { "speed_t" "ospeed" } ; ! output speed
diff --git a/extra/serial/unix/termios/linux/tags.txt b/extra/serial/unix/termios/linux/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/serial/unix/termios/linux/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/serial/unix/termios/tags.txt b/extra/serial/unix/termios/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/serial/unix/termios/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/serial/unix/termios/termios.factor b/extra/serial/unix/termios/termios.factor
new file mode 100644
index 0000000000..901416d62c
--- /dev/null
+++ b/extra/serial/unix/termios/termios.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators system vocabs.loader ;
+IN: serial.unix.termios
+
+{
+ { [ os linux? ] [ "serial.unix.termios.linux" ] }
+ { [ os bsd? ] [ "serial.unix.termios.bsd" ] }
+} cond require
diff --git a/extra/serial/unix/unix-tests.factor b/extra/serial/unix/unix-tests.factor
new file mode 100644
index 0000000000..300cacf83e
--- /dev/null
+++ b/extra/serial/unix/unix-tests.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math.bitfields serial.unix ;
+IN: serial.unix
+
+: serial-obj ( -- obj )
+ serial new
+ "/dev/ttyS0" >>path
+ 19200 >>baud
+ { IGNPAR ICRNL } flags >>iflag
+ { } flags >>oflag
+ { CS8 CLOCAL CREAD } flags >>cflag
+ { ICANON } flags >>lflag ;
+
+: serial-test ( -- serial )
+ serial-obj
+ open-serial
+ dup get-termios >>termios
+ dup configure-termios
+ dup tciflush
+ dup apply-termios ;
diff --git a/extra/serial/unix/unix.factor b/extra/serial/unix/unix.factor
new file mode 100644
index 0000000000..6b48c758cc
--- /dev/null
+++ b/extra/serial/unix/unix.factor
@@ -0,0 +1,63 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax combinators io.ports
+io.streams.duplex io.unix.backend system kernel math math.bitfields
+vocabs.loader unix serial serial.unix.termios ;
+IN: serial.unix
+
+{
+ { [ os linux? ] [ "serial.unix.linux" ] }
+ { [ os bsd? ] [ "serial.unix.bsd" ] }
+} cond require
+
+FUNCTION: speed_t cfgetispeed ( termios* t ) ;
+FUNCTION: speed_t cfgetospeed ( termios* t ) ;
+FUNCTION: int cfsetispeed ( termios* t, speed_t s ) ;
+FUNCTION: int cfsetospeed ( termios* t, speed_t s ) ;
+FUNCTION: int tcgetattr ( int i1, termios* t ) ;
+FUNCTION: int tcsetattr ( int i1, int i2, termios* t ) ;
+FUNCTION: int tcdrain ( int i1 ) ;
+FUNCTION: int tcflow ( int i1, int i2 ) ;
+FUNCTION: int tcflush ( int i1, int i2 ) ;
+FUNCTION: int tcsendbreak ( int i1, int i2 ) ;
+FUNCTION: void cfmakeraw ( termios* t ) ;
+FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
+
+: fd>duplex-stream ( fd -- duplex-stream )
+ <fd> init-fd
+ [ <input-port> ] [ <output-port> ] bi <duplex-stream> ;
+
+: open-rw ( path -- fd ) O_RDWR file-mode open-file ;
+: <file-rw> ( path -- stream ) open-rw fd>duplex-stream ;
+
+M: unix open-serial ( serial -- serial' )
+ dup
+ path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
+ fd>duplex-stream >>stream ;
+
+: serial-fd ( serial -- fd )
+ stream>> in>> handle>> fd>> ;
+
+: get-termios ( serial -- termios )
+ serial-fd
+ "termios" <c-object> [ tcgetattr io-error ] keep ;
+
+: configure-termios ( serial -- )
+ dup termios>>
+ {
+ [ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ]
+ [ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ]
+ [
+ [
+ [ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor
+ ] dip set-termios-cflag
+ ]
+ [ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ]
+ } 2cleave ;
+
+: tciflush ( serial -- )
+ serial-fd TCIFLUSH tcflush io-error ;
+
+: apply-termios ( serial -- )
+ [ serial-fd TCSANOW ]
+ [ termios>> ] bi tcsetattr io-error ;
From bb76f2f61707364c41a4a47e5704c8047d873d98 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 13 Aug 2008 18:57:57 -0500
Subject: [PATCH 30/44] Fix combinatorics tests
---
extra/math/combinatorics/combinatorics-tests.factor | 5 -----
1 file changed, 5 deletions(-)
diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/extra/math/combinatorics/combinatorics-tests.factor
index e6a2824433..5ef435a4e0 100644
--- a/extra/math/combinatorics/combinatorics-tests.factor
+++ b/extra/math/combinatorics/combinatorics-tests.factor
@@ -13,11 +13,6 @@ IN: math.combinatorics.tests
[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
-[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } reorder ] unit-test
-[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } reorder ] unit-test
-[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } reorder ] unit-test
-[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } reorder ] unit-test
-
[ 1 ] [ 0 factorial ] unit-test
[ 1 ] [ 1 factorial ] unit-test
[ 3628800 ] [ 10 factorial ] unit-test
From ca27c897d092b4b4d5d80c73ea24fb0f635a27b6 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Wed, 13 Aug 2008 20:52:30 -0400
Subject: [PATCH 31/44] irc.ui: Removed reference to irc.messages.private
---
extra/irc/ui/ui.factor | 16 ++++++++--------
1 file changed, 8 insertions(+), 8 deletions(-)
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index 4757e36660..f144674ce9 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -8,7 +8,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
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.messages.private
+ irc.client irc.client.private irc.messages
irc.ui.commandparser irc.ui.load ;
RENAME: join sequences => sjoin
@@ -39,7 +39,7 @@ M: ping write-irc
M: privmsg write-irc
"<" blue write-color
- [ prefix>> parse-name write ] keep
+ [ irc-message-sender write ] keep
"> " blue write-color
trailing>> write ;
@@ -61,24 +61,24 @@ M: own-message write-irc
M: join write-irc
"* " dark-green write-color
- prefix>> parse-name write
+ irc-message-sender write
" has entered the channel." dark-green write-color ;
M: part write-irc
"* " dark-red write-color
- [ prefix>> parse-name write ] keep
+ [ irc-message-sender write ] keep
" has left the channel" dark-red write-color
trailing>> dot-or-parens dark-red write-color ;
M: quit write-irc
"* " dark-red write-color
- [ prefix>> parse-name write ] keep
+ [ irc-message-sender write ] keep
" has left IRC" dark-red write-color
trailing>> dot-or-parens dark-red write-color ;
M: kick write-irc
"* " dark-red write-color
- [ prefix>> parse-name write ] keep
+ [ irc-message-sender write ] keep
" has kicked " dark-red write-color
[ who>> write ] keep
" from the channel" dark-red write-color
@@ -89,7 +89,7 @@ M: kick write-irc
M: mode write-irc
"* " blue write-color
- [ prefix>> parse-name write ] keep
+ [ irc-message-sender write ] keep
" has applied mode " blue write-color
[ full-mode write ] keep
" to " blue write-color
@@ -97,7 +97,7 @@ M: mode write-irc
M: nick write-irc
"* " blue write-color
- [ prefix>> parse-name write ] keep
+ [ irc-message-sender write ] keep
" is now known as " blue write-color
trailing>> write ;
From 83574cb5ee01c152e58f0873ca568092c70b76cc Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Wed, 13 Aug 2008 20:58:05 -0400
Subject: [PATCH 32/44] irc.ui: Removed userlist slot from irc-tab
---
extra/irc/ui/ui.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index f144674ce9..956644dc52 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -21,7 +21,7 @@ SYMBOL: client
TUPLE: ui-window < tabbed client ;
-TUPLE: irc-tab < frame listener client window userlist ;
+TUPLE: irc-tab < frame listener client window ;
: write-color ( str color -- )
foreground associate format ;
From c5e3bdf66842e54e3a791eb2f28d3d0eb6832956 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 13 Aug 2008 21:51:25 -0500
Subject: [PATCH 33/44] add constants for bsd serial
---
extra/serial/unix/bsd/bsd.factor | 15 ++++++++++++++-
extra/serial/unix/termios/bsd/bsd.factor | 2 +-
extra/serial/unix/unix.factor | 4 ++--
3 files changed, 17 insertions(+), 4 deletions(-)
diff --git a/extra/serial/unix/bsd/bsd.factor b/extra/serial/unix/bsd/bsd.factor
index 68aaa03a23..7dac47193a 100644
--- a/extra/serial/unix/bsd/bsd.factor
+++ b/extra/serial/unix/bsd/bsd.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences system serial ;
+USING: alien.syntax kernel sequences system serial ;
IN: serial.unix
M: bsd lookup-baud ( m -- n )
@@ -9,3 +9,16 @@ M: bsd lookup-baud ( m -- n )
7200 9600 14400 19200 28800 38400 57600 76800 115200
230400 460800 921600
} member? [ invalid-baud ] unless ;
+
+: TCSANOW 0 ; inline
+: TCSADRAIN 1 ; inline
+: TCSAFLUSH 2 ; inline
+: TCSASOFT HEX: 10 ; inline
+
+: TCIFLUSH 1 ; inline
+: TCOFLUSH 2 ; inline
+: TCIOFLUSH 3 ; inline
+: TCOOFF 1 ; inline
+: TCOON 2 ; inline
+: TCIOFF 3 ; inline
+: TCION 4 ; inline
diff --git a/extra/serial/unix/termios/bsd/bsd.factor b/extra/serial/unix/termios/bsd/bsd.factor
index c8f1e8be54..5fbc571519 100644
--- a/extra/serial/unix/termios/bsd/bsd.factor
+++ b/extra/serial/unix/termios/bsd/bsd.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences system ;
+USING: alien.syntax kernel sequences system ;
IN: serial.unix.termios
: NCCS 20 ; inline
diff --git a/extra/serial/unix/unix.factor b/extra/serial/unix/unix.factor
index 6b48c758cc..7ed5bced37 100644
--- a/extra/serial/unix/unix.factor
+++ b/extra/serial/unix/unix.factor
@@ -5,10 +5,10 @@ io.streams.duplex io.unix.backend system kernel math math.bitfields
vocabs.loader unix serial serial.unix.termios ;
IN: serial.unix
-{
+<< {
{ [ os linux? ] [ "serial.unix.linux" ] }
{ [ os bsd? ] [ "serial.unix.bsd" ] }
-} cond require
+} cond require >>
FUNCTION: speed_t cfgetispeed ( termios* t ) ;
FUNCTION: speed_t cfgetospeed ( termios* t ) ;
From f98729eb91d6fe6187edd8fadd5f53915c03e18a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 13 Aug 2008 22:04:12 -0500
Subject: [PATCH 34/44] more bsd flags
---
extra/serial/unix/bsd/bsd.factor | 64 ++++++++++++++++++++++++++++-
extra/serial/unix/unix-tests.factor | 2 +-
2 files changed, 64 insertions(+), 2 deletions(-)
diff --git a/extra/serial/unix/bsd/bsd.factor b/extra/serial/unix/bsd/bsd.factor
index 7dac47193a..feed85348b 100644
--- a/extra/serial/unix/bsd/bsd.factor
+++ b/extra/serial/unix/bsd/bsd.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences system serial ;
+USING: alien.syntax kernel math.bitfields sequences system serial ;
IN: serial.unix
M: bsd lookup-baud ( m -- n )
@@ -22,3 +22,65 @@ M: bsd lookup-baud ( m -- n )
: TCOON 2 ; inline
: TCIOFF 3 ; inline
: TCION 4 ; inline
+
+! iflags
+: IGNBRK HEX: 00000001 ; inline
+: BRKINT HEX: 00000002 ; inline
+: IGNPAR HEX: 00000004 ; inline
+: PARMRK HEX: 00000008 ; inline
+: INPCK HEX: 00000010 ; inline
+: ISTRIP HEX: 00000020 ; inline
+: INLCR HEX: 00000040 ; inline
+: IGNCR HEX: 00000080 ; inline
+: ICRNL HEX: 00000100 ; inline
+: IXON HEX: 00000200 ; inline
+: IXOFF HEX: 00000400 ; inline
+: IXANY HEX: 00000800 ; inline
+: IMAXBEL HEX: 00002000 ; inline
+: IUTF8 HEX: 00004000 ; inline
+
+! oflags
+: OPOST HEX: 00000001 ; inline
+: ONLCR HEX: 00000002 ; inline
+: OXTABS HEX: 00000004 ; inline
+: ONOEOT HEX: 00000008 ; inline
+
+! cflags
+: CIGNORE HEX: 00000001 ; inline
+: CSIZE HEX: 00000300 ; inline
+: CS5 HEX: 00000000 ; inline
+: CS6 HEX: 00000100 ; inline
+: CS7 HEX: 00000200 ; inline
+: CS8 HEX: 00000300 ; inline
+: CSTOPB HEX: 00000400 ; inline
+: CREAD HEX: 00000800 ; inline
+: PARENB HEX: 00001000 ; inline
+: PARODD HEX: 00002000 ; inline
+: HUPCL HEX: 00004000 ; inline
+: CLOCAL HEX: 00008000 ; inline
+: CCTS_OFLOW HEX: 00010000 ; inline
+: CRTS_IFLOW HEX: 00020000 ; inline
+: CRTSCTS { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+: CDTR_IFLOW HEX: 00040000 ; inline
+: CDSR_OFLOW HEX: 00080000 ; inline
+: CCAR_OFLOW HEX: 00100000 ; inline
+: MDMBUF HEX: 00100000 ; inline
+
+! lflags
+: ECHOKE HEX: 00000001 ; inline
+: ECHOE HEX: 00000002 ; inline
+: ECHOK HEX: 00000004 ; inline
+: ECHO HEX: 00000008 ; inline
+: ECHONL HEX: 00000010 ; inline
+: ECHOPRT HEX: 00000020 ; inline
+: ECHOCTL HEX: 00000040 ; inline
+: ISIG HEX: 00000080 ; inline
+: ICANON HEX: 00000100 ; inline
+: ALTWERASE HEX: 00000200 ; inline
+: IEXTEN HEX: 00000400 ; inline
+: EXTPROC HEX: 00000800 ; inline
+: TOSTOP HEX: 00400000 ; inline
+: FLUSHO HEX: 00800000 ; inline
+: NOKERNINFO HEX: 02000000 ; inline
+: PENDIN HEX: 20000000 ; inline
+: NOFLSH HEX: 80000000 ; inline
diff --git a/extra/serial/unix/unix-tests.factor b/extra/serial/unix/unix-tests.factor
index 300cacf83e..bab6c3f4f1 100644
--- a/extra/serial/unix/unix-tests.factor
+++ b/extra/serial/unix/unix-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.bitfields serial.unix ;
+USING: accessors kernel math.bitfields serial serial.unix ;
IN: serial.unix
: serial-obj ( -- obj )
From 805cb650bd889221009b5841d6298fed8dee49c1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 13 Aug 2008 23:09:43 -0500
Subject: [PATCH 35/44] add find-hrefs word
---
extra/html/parser/analyzer/analyzer.factor | 6 ++++++
extra/html/parser/parser.factor | 10 ++++++----
2 files changed, 12 insertions(+), 4 deletions(-)
diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor
index dca727b9dc..f167feba06 100755
--- a/extra/html/parser/analyzer/analyzer.factor
+++ b/extra/html/parser/analyzer/analyzer.factor
@@ -140,6 +140,12 @@ TUPLE: link attributes clickable ;
: href-contains? ( str tag -- ? )
attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ;
+: find-hrefs ( vector -- vector' )
+ find-links
+ [ [
+ [ name>> "a" = ]
+ [ attributes>> "href" swap key? ] bi and ] filter
+ ] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index c8aa9aa9e6..dbf6c52a0d 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -1,4 +1,4 @@
-USING: arrays html.parser.utils hashtables io kernel
+USING: accessors arrays html.parser.utils hashtables io kernel
namespaces prettyprint quotations
sequences splitting state-parser strings unicode.categories unicode.case ;
IN: html.parser
@@ -23,8 +23,10 @@ SYMBOL: tagstack
] if ;
: <tag> ( name attributes closing? -- tag )
- { set-tag-name set-tag-attributes set-tag-closing? }
- tag construct ;
+ tag new
+ swap >>closing?
+ swap >>attributes
+ swap >>name ;
: make-tag ( str attribs -- tag )
>r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
@@ -75,7 +77,7 @@ SYMBOL: tagstack
read-quote
] [
read-token
- ] if ;
+ ] if [ blank? ] trim ;
: read-comment ( -- )
"-->" take-string* make-comment-tag push-tag ;
From d50afc2a35317618b1b3c5ca70b863edef3d6304 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 13 Aug 2008 23:13:13 -0500
Subject: [PATCH 36/44] remove unfinished code for now
---
extra/html/parser/printer/printer.factor | 10 +++-------
1 file changed, 3 insertions(+), 7 deletions(-)
diff --git a/extra/html/parser/printer/printer.factor b/extra/html/parser/printer/printer.factor
index d352a97688..27cb21a927 100644
--- a/extra/html/parser/printer/printer.factor
+++ b/extra/html/parser/printer/printer.factor
@@ -83,13 +83,6 @@ M: src-printer print-closing-named-tag ( tag -- )
SYMBOL: tab-width
SYMBOL: #indentations
-: html-pp ( vector -- )
- [
- 0 #indentations set
- 2 tab-width set
-
- ] with-scope ;
-
: print-tabs ( -- )
tab-width get #indentations get * CHAR: \s <repetition> write ;
@@ -125,3 +118,6 @@ M: printer print-tag ( tag -- )
! H{ { table-gap { 10 10 } } } [
! [ [ [ [ . ] with-cell ] each ] with-row ] each
! ] tabular-output
+
+! : html-pp ( vector -- )
+ ! [ 0 #indentations set 2 tab-width set ] with-scope ;
From d9074c9d4e0c5ba7b634c5d5e5dee13cfa447554 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 13 Aug 2008 23:20:44 -0500
Subject: [PATCH 37/44] fix bootstrap
---
basis/unix/bsd/bsd.factor | 1 +
basis/unix/linux/linux.factor | 1 +
basis/unix/unix.factor | 3 ---
3 files changed, 2 insertions(+), 3 deletions(-)
diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor
index 68444de85f..6934d5b8dc 100755
--- a/basis/unix/bsd/bsd.factor
+++ b/basis/unix/bsd/bsd.factor
@@ -16,6 +16,7 @@ IN: unix
: O_TRUNC HEX: 0400 ; inline
: O_EXCL HEX: 0800 ; inline
: O_NOCTTY HEX: 20000 ; inline
+: O_NDELAY O_NONBLOCK ; inline
: SOL_SOCKET HEX: ffff ; inline
: SO_REUSEADDR HEX: 4 ; inline
diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor
index cc1e056b8b..0c08cf0f2b 100755
--- a/basis/unix/linux/linux.factor
+++ b/basis/unix/linux/linux.factor
@@ -16,6 +16,7 @@ USING: alien.syntax ;
: O_TRUNC HEX: 0200 ; inline
: O_APPEND HEX: 0400 ; inline
: O_NONBLOCK HEX: 0800 ; inline
+: O_NDELAY O_NONBLOCK ; inline
: SOL_SOCKET 1 ; inline
diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor
index 065087fa59..4ae74f8267 100755
--- a/basis/unix/unix.factor
+++ b/basis/unix/unix.factor
@@ -25,8 +25,6 @@ TYPEDEF: uint socklen_t
: NGROUPS_MAX 16 ; inline
-: O_NDELAY O_NONBLOCK ; inline
-
C-STRUCT: group
{ "char*" "gr_name" }
{ "char*" "gr_passwd" }
@@ -194,4 +192,3 @@ FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
{ [ os bsd? ] [ "unix.bsd" require ] }
{ [ os solaris? ] [ "unix.solaris" require ] }
} cond
-
From 2186999fee2a7c66f79ba7cab9a5e2eba16d35a6 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Thu, 14 Aug 2008 00:52:29 -0400
Subject: [PATCH 38/44] irc.ui: Fixed userlist>> bug
---
extra/irc/ui/ui.factor | 27 +++++++++++++--------------
1 file changed, 13 insertions(+), 14 deletions(-)
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index 956644dc52..5d74c884c4 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -21,6 +21,9 @@ SYMBOL: client
TUPLE: ui-window < tabbed client ;
+M: ui-window ungraft*
+ client>> terminate-irc ;
+
TUPLE: irc-tab < frame listener client window ;
: write-color ( str color -- )
@@ -139,16 +142,6 @@ GENERIC: handle-inbox ( tab message -- )
: add-gadget-color ( pack seq color -- pack )
'[ , >>color add-gadget ] each ;
-: update-participants ( tab -- )
- [ userlist>> [ clear-gadget ] keep ]
- [ listener>> participants>> ] bi
- [ +operator+ value-labels dark-green add-gadget-color ]
- [ +voice+ value-labels blue add-gadget-color ]
- [ +normal+ value-labels black add-gadget-color ] tri drop ;
-
-M: participant-changed handle-inbox
- drop update-participants ;
-
M: object handle-inbox
nip print-irc ;
@@ -198,15 +191,21 @@ TUPLE: irc-channel-tab < irc-tab userlist ;
irc-tab new-irc-tab
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
+: update-participants ( tab -- )
+ [ userlist>> [ clear-gadget ] keep ]
+ [ listener>> participants>> ] bi
+ [ +operator+ value-labels dark-green add-gadget-color ]
+ [ +voice+ value-labels blue add-gadget-color ]
+ [ +normal+ value-labels black add-gadget-color ] tri drop ;
+
+M: participant-changed handle-inbox
+ drop update-participants ;
+
TUPLE: irc-server-tab < irc-tab ;
: <irc-server-tab> ( listener -- irc-tab )
f irc-server-tab new-irc-tab ;
-M: irc-server-tab ungraft*
- [ window>> client>> terminate-irc ]
- [ listener>> ] [ window>> client>> ] tri remove-listener ;
-
: <irc-nick-tab> ( listener ui-window -- irc-tab )
irc-tab new-irc-tab ;
From a84404bc0d2937baf143169ef59b08ff099e6444 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 14 Aug 2008 00:21:10 -0500
Subject: [PATCH 39/44] add some more utility words like when-empty
---
extra/sequences/lib/lib.factor | 11 +++++++----
1 file changed, 7 insertions(+), 4 deletions(-)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 1167a3b7b4..17f855c264 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -211,8 +211,11 @@ PRIVATE>
: insert-nth ( elt n seq -- seq' )
swap cut-slice [ swap 1array ] dip 3append ;
-: if-seq ( seq quot1 quot2 -- )
- [ f like ] 2dip if* ; inline
+: if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline
+
+: if-empty ( seq quot1 quot2 -- ) swap if-seq ; inline
+
+: when-empty ( seq quot1 -- ) [ ] if-empty ; inline
+
+: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline
-: if-empty ( seq quot1 quot2 -- )
- swap if-seq ; inline
From 7a701c9501735d95aed7ff252ef7cff0b8dd1e2d Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Thu, 14 Aug 2008 01:24:56 -0400
Subject: [PATCH 40/44] irc.ui: Fixed bug in constructor
---
extra/irc/ui/ui.factor | 9 ++++++---
1 file changed, 6 insertions(+), 3 deletions(-)
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index 5d74c884c4..1aebfcbfcb 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -123,8 +123,11 @@ M: irc-listener-end write-irc
M: irc-message write-irc
drop ; ! catch all unimplemented writes, THIS WILL CHANGE
-: time-happened ( irc-message -- timestamp )
- [ timestamp>> ] [ 2drop now ] recover ;
+GENERIC: time-happened ( message -- timestamp )
+
+M: irc-message time-happened timestamp>> ;
+
+M: object time-happened drop now ;
: print-irc ( irc-message -- )
[ time-happened timestamp>hms write " " write ]
@@ -188,7 +191,7 @@ M: irc-tab ungraft*
TUPLE: irc-channel-tab < irc-tab userlist ;
: <irc-channel-tab> ( listener ui-window -- irc-tab )
- irc-tab new-irc-tab
+ irc-channel-tab new-irc-tab
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
: update-participants ( tab -- )
From b06fe6fe9addf0ed54af47255b06f48605cc0f94 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 14 Aug 2008 23:35:35 -0500
Subject: [PATCH 41/44] Fix help lint
---
basis/help/lint/lint.factor | 16 ++++++++--------
1 file changed, 8 insertions(+), 8 deletions(-)
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 9cbffe2d33..c4f4a46710 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -3,9 +3,9 @@
USING: accessors sequences parser kernel help help.markup
help.topics words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors
-combinators splitting debugger hashtables sorting effects vocabs
-vocabs.loader assocs editors continuations classes.predicate
-macros math sets eval ;
+combinators combinators.short-circuit splitting debugger
+hashtables sorting effects vocabs vocabs.loader assocs editors
+continuations classes.predicate macros math sets eval ;
IN: help.lint
: check-example ( element -- )
@@ -43,15 +43,15 @@ IN: help.lint
: check-values ( word element -- )
{
- { [ over "declared-effect" word-prop ] [ 2drop ] }
- { [ dup contains-funky-elements? not ] [ 2drop ] }
- { [ over macro? not ] [ 2drop ] }
+ [ drop "declared-effect" word-prop not ]
+ [ nip contains-funky-elements? ]
+ [ drop macro? ]
[
[ effect-values >array ]
[ extract-values >array ]
- bi* assert=
+ bi* =
]
- } cond ;
+ } 2|| [ "$values don't match stack effect" throw ] unless ;
: check-see-also ( word element -- )
nip \ $see-also swap elements [
From 5cc5d347ae80dd81f24d00613b0868ccd8da22f0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 14 Aug 2008 23:44:39 -0500
Subject: [PATCH 42/44] moved serial to io.serial
---
extra/io/serial/authors.txt | 1 +
extra/io/serial/serial.factor | 23 ++++
extra/io/serial/summary.txt | 1 +
extra/io/serial/tags.txt | 1 +
extra/io/serial/unix/bsd/bsd.factor | 86 ++++++++++++
extra/io/serial/unix/bsd/tags.txt | 1 +
extra/io/serial/unix/linux/linux.factor | 130 ++++++++++++++++++
extra/io/serial/unix/linux/tags.txt | 1 +
extra/io/serial/unix/tags.txt | 1 +
extra/io/serial/unix/termios/bsd/bsd.factor | 19 +++
extra/io/serial/unix/termios/bsd/tags.txt | 1 +
.../io/serial/unix/termios/linux/linux.factor | 20 +++
extra/io/serial/unix/termios/linux/tags.txt | 1 +
extra/io/serial/unix/termios/tags.txt | 1 +
extra/io/serial/unix/termios/termios.factor | 9 ++
extra/io/serial/unix/unix-tests.factor | 21 +++
extra/io/serial/unix/unix.factor | 63 +++++++++
17 files changed, 380 insertions(+)
create mode 100644 extra/io/serial/authors.txt
create mode 100644 extra/io/serial/serial.factor
create mode 100644 extra/io/serial/summary.txt
create mode 100644 extra/io/serial/tags.txt
create mode 100644 extra/io/serial/unix/bsd/bsd.factor
create mode 100644 extra/io/serial/unix/bsd/tags.txt
create mode 100644 extra/io/serial/unix/linux/linux.factor
create mode 100644 extra/io/serial/unix/linux/tags.txt
create mode 100644 extra/io/serial/unix/tags.txt
create mode 100644 extra/io/serial/unix/termios/bsd/bsd.factor
create mode 100644 extra/io/serial/unix/termios/bsd/tags.txt
create mode 100644 extra/io/serial/unix/termios/linux/linux.factor
create mode 100644 extra/io/serial/unix/termios/linux/tags.txt
create mode 100644 extra/io/serial/unix/termios/tags.txt
create mode 100644 extra/io/serial/unix/termios/termios.factor
create mode 100644 extra/io/serial/unix/unix-tests.factor
create mode 100644 extra/io/serial/unix/unix.factor
diff --git a/extra/io/serial/authors.txt b/extra/io/serial/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/io/serial/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/io/serial/serial.factor b/extra/io/serial/serial.factor
new file mode 100644
index 0000000000..117ae7f80b
--- /dev/null
+++ b/extra/io/serial/serial.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators destructors
+kernel math math.bitfields math.parser sequences summary system
+vocabs.loader ;
+IN: io.serial
+
+TUPLE: serial stream path baud
+ termios iflag oflag cflag lflag ;
+
+ERROR: invalid-baud baud ;
+M: invalid-baud summary ( invalid-baud -- string )
+ "Baud rate "
+ swap baud>> number>string
+ " not supported" 3append ;
+
+HOOK: lookup-baud os ( m -- n )
+HOOK: open-serial os ( serial -- serial' )
+M: serial dispose ( serial -- ) stream>> dispose ;
+
+{
+ { [ os unix? ] [ "serial.unix" ] }
+} cond require
diff --git a/extra/io/serial/summary.txt b/extra/io/serial/summary.txt
new file mode 100644
index 0000000000..5ccd99dbaa
--- /dev/null
+++ b/extra/io/serial/summary.txt
@@ -0,0 +1 @@
+Serial port library
diff --git a/extra/io/serial/tags.txt b/extra/io/serial/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/io/serial/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/io/serial/unix/bsd/bsd.factor b/extra/io/serial/unix/bsd/bsd.factor
new file mode 100644
index 0000000000..915fd8ce08
--- /dev/null
+++ b/extra/io/serial/unix/bsd/bsd.factor
@@ -0,0 +1,86 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel math.bitfields sequences system serial ;
+IN: io.serial.unix
+
+M: bsd lookup-baud ( m -- n )
+ dup {
+ 0 50 75 110 134 150 200 300 600 1200 1800 2400 4800
+ 7200 9600 14400 19200 28800 38400 57600 76800 115200
+ 230400 460800 921600
+ } member? [ invalid-baud ] unless ;
+
+: TCSANOW 0 ; inline
+: TCSADRAIN 1 ; inline
+: TCSAFLUSH 2 ; inline
+: TCSASOFT HEX: 10 ; inline
+
+: TCIFLUSH 1 ; inline
+: TCOFLUSH 2 ; inline
+: TCIOFLUSH 3 ; inline
+: TCOOFF 1 ; inline
+: TCOON 2 ; inline
+: TCIOFF 3 ; inline
+: TCION 4 ; inline
+
+! iflags
+: IGNBRK HEX: 00000001 ; inline
+: BRKINT HEX: 00000002 ; inline
+: IGNPAR HEX: 00000004 ; inline
+: PARMRK HEX: 00000008 ; inline
+: INPCK HEX: 00000010 ; inline
+: ISTRIP HEX: 00000020 ; inline
+: INLCR HEX: 00000040 ; inline
+: IGNCR HEX: 00000080 ; inline
+: ICRNL HEX: 00000100 ; inline
+: IXON HEX: 00000200 ; inline
+: IXOFF HEX: 00000400 ; inline
+: IXANY HEX: 00000800 ; inline
+: IMAXBEL HEX: 00002000 ; inline
+: IUTF8 HEX: 00004000 ; inline
+
+! oflags
+: OPOST HEX: 00000001 ; inline
+: ONLCR HEX: 00000002 ; inline
+: OXTABS HEX: 00000004 ; inline
+: ONOEOT HEX: 00000008 ; inline
+
+! cflags
+: CIGNORE HEX: 00000001 ; inline
+: CSIZE HEX: 00000300 ; inline
+: CS5 HEX: 00000000 ; inline
+: CS6 HEX: 00000100 ; inline
+: CS7 HEX: 00000200 ; inline
+: CS8 HEX: 00000300 ; inline
+: CSTOPB HEX: 00000400 ; inline
+: CREAD HEX: 00000800 ; inline
+: PARENB HEX: 00001000 ; inline
+: PARODD HEX: 00002000 ; inline
+: HUPCL HEX: 00004000 ; inline
+: CLOCAL HEX: 00008000 ; inline
+: CCTS_OFLOW HEX: 00010000 ; inline
+: CRTS_IFLOW HEX: 00020000 ; inline
+: CRTSCTS { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+: CDTR_IFLOW HEX: 00040000 ; inline
+: CDSR_OFLOW HEX: 00080000 ; inline
+: CCAR_OFLOW HEX: 00100000 ; inline
+: MDMBUF HEX: 00100000 ; inline
+
+! lflags
+: ECHOKE HEX: 00000001 ; inline
+: ECHOE HEX: 00000002 ; inline
+: ECHOK HEX: 00000004 ; inline
+: ECHO HEX: 00000008 ; inline
+: ECHONL HEX: 00000010 ; inline
+: ECHOPRT HEX: 00000020 ; inline
+: ECHOCTL HEX: 00000040 ; inline
+: ISIG HEX: 00000080 ; inline
+: ICANON HEX: 00000100 ; inline
+: ALTWERASE HEX: 00000200 ; inline
+: IEXTEN HEX: 00000400 ; inline
+: EXTPROC HEX: 00000800 ; inline
+: TOSTOP HEX: 00400000 ; inline
+: FLUSHO HEX: 00800000 ; inline
+: NOKERNINFO HEX: 02000000 ; inline
+: PENDIN HEX: 20000000 ; inline
+: NOFLSH HEX: 80000000 ; inline
diff --git a/extra/io/serial/unix/bsd/tags.txt b/extra/io/serial/unix/bsd/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/io/serial/unix/bsd/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/io/serial/unix/linux/linux.factor b/extra/io/serial/unix/linux/linux.factor
new file mode 100644
index 0000000000..d8158ae8bb
--- /dev/null
+++ b/extra/io/serial/unix/linux/linux.factor
@@ -0,0 +1,130 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs alien.syntax kernel serial system unix ;
+IN: io.serial.unix
+
+: TCSANOW 0 ; inline
+: TCSADRAIN 1 ; inline
+: TCSAFLUSH 2 ; inline
+
+: TCIFLUSH 0 ; inline
+: TCOFLUSH 1 ; inline
+: TCIOFLUSH 2 ; inline
+
+: TCOOFF 0 ; inline
+: TCOON 1 ; inline
+: TCIOFF 2 ; inline
+: TCION 3 ; inline
+
+! iflag
+: IGNBRK OCT: 0000001 ; inline
+: BRKINT OCT: 0000002 ; inline
+: IGNPAR OCT: 0000004 ; inline
+: PARMRK OCT: 0000010 ; inline
+: INPCK OCT: 0000020 ; inline
+: ISTRIP OCT: 0000040 ; inline
+: INLCR OCT: 0000100 ; inline
+: IGNCR OCT: 0000200 ; inline
+: ICRNL OCT: 0000400 ; inline
+: IUCLC OCT: 0001000 ; inline
+: IXON OCT: 0002000 ; inline
+: IXANY OCT: 0004000 ; inline
+: IXOFF OCT: 0010000 ; inline
+: IMAXBEL OCT: 0020000 ; inline
+: IUTF8 OCT: 0040000 ; inline
+
+! oflag
+: OPOST OCT: 0000001 ; inline
+: OLCUC OCT: 0000002 ; inline
+: ONLCR OCT: 0000004 ; inline
+: OCRNL OCT: 0000010 ; inline
+: ONOCR OCT: 0000020 ; inline
+: ONLRET OCT: 0000040 ; inline
+: OFILL OCT: 0000100 ; inline
+: OFDEL OCT: 0000200 ; inline
+: NLDLY OCT: 0000400 ; inline
+: NL0 OCT: 0000000 ; inline
+: NL1 OCT: 0000400 ; inline
+: CRDLY OCT: 0003000 ; inline
+: CR0 OCT: 0000000 ; inline
+: CR1 OCT: 0001000 ; inline
+: CR2 OCT: 0002000 ; inline
+: CR3 OCT: 0003000 ; inline
+: TABDLY OCT: 0014000 ; inline
+: TAB0 OCT: 0000000 ; inline
+: TAB1 OCT: 0004000 ; inline
+: TAB2 OCT: 0010000 ; inline
+: TAB3 OCT: 0014000 ; inline
+: BSDLY OCT: 0020000 ; inline
+: BS0 OCT: 0000000 ; inline
+: BS1 OCT: 0020000 ; inline
+: FFDLY OCT: 0100000 ; inline
+: FF0 OCT: 0000000 ; inline
+: FF1 OCT: 0100000 ; inline
+
+! cflags
+: CSIZE OCT: 0000060 ; inline
+: CS5 OCT: 0000000 ; inline
+: CS6 OCT: 0000020 ; inline
+: CS7 OCT: 0000040 ; inline
+: CS8 OCT: 0000060 ; inline
+: CSTOPB OCT: 0000100 ; inline
+: CREAD OCT: 0000200 ; inline
+: PARENB OCT: 0000400 ; inline
+: PARODD OCT: 0001000 ; inline
+: HUPCL OCT: 0002000 ; inline
+: CLOCAL OCT: 0004000 ; inline
+: CIBAUD OCT: 002003600000 ; inline
+: CRTSCTS OCT: 020000000000 ; inline
+
+! lflags
+: ISIG OCT: 0000001 ; inline
+: ICANON OCT: 0000002 ; inline
+: XCASE OCT: 0000004 ; inline
+: ECHO OCT: 0000010 ; inline
+: ECHOE OCT: 0000020 ; inline
+: ECHOK OCT: 0000040 ; inline
+: ECHONL OCT: 0000100 ; inline
+: NOFLSH OCT: 0000200 ; inline
+: TOSTOP OCT: 0000400 ; inline
+: ECHOCTL OCT: 0001000 ; inline
+: ECHOPRT OCT: 0002000 ; inline
+: ECHOKE OCT: 0004000 ; inline
+: FLUSHO OCT: 0010000 ; inline
+: PENDIN OCT: 0040000 ; inline
+: IEXTEN OCT: 0100000 ; inline
+
+M: linux lookup-baud ( n -- n )
+ dup H{
+ { 0 OCT: 0000000 }
+ { 50 OCT: 0000001 }
+ { 75 OCT: 0000002 }
+ { 110 OCT: 0000003 }
+ { 134 OCT: 0000004 }
+ { 150 OCT: 0000005 }
+ { 200 OCT: 0000006 }
+ { 300 OCT: 0000007 }
+ { 600 OCT: 0000010 }
+ { 1200 OCT: 0000011 }
+ { 1800 OCT: 0000012 }
+ { 2400 OCT: 0000013 }
+ { 4800 OCT: 0000014 }
+ { 9600 OCT: 0000015 }
+ { 19200 OCT: 0000016 }
+ { 38400 OCT: 0000017 }
+ { 57600 OCT: 0010001 }
+ { 115200 OCT: 0010002 }
+ { 230400 OCT: 0010003 }
+ { 460800 OCT: 0010004 }
+ { 500000 OCT: 0010005 }
+ { 576000 OCT: 0010006 }
+ { 921600 OCT: 0010007 }
+ { 1000000 OCT: 0010010 }
+ { 1152000 OCT: 0010011 }
+ { 1500000 OCT: 0010012 }
+ { 2000000 OCT: 0010013 }
+ { 2500000 OCT: 0010014 }
+ { 3000000 OCT: 0010015 }
+ { 3500000 OCT: 0010016 }
+ { 4000000 OCT: 0010017 }
+ } at* [ nip ] [ drop invalid-baud ] if ;
diff --git a/extra/io/serial/unix/linux/tags.txt b/extra/io/serial/unix/linux/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/io/serial/unix/linux/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/io/serial/unix/tags.txt b/extra/io/serial/unix/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/io/serial/unix/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/io/serial/unix/termios/bsd/bsd.factor b/extra/io/serial/unix/termios/bsd/bsd.factor
new file mode 100644
index 0000000000..414ec98438
--- /dev/null
+++ b/extra/io/serial/unix/termios/bsd/bsd.factor
@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel sequences system ;
+IN: io.serial.unix.termios
+
+: NCCS 20 ; inline
+
+TYPEDEF: uint tcflag_t
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+
+C-STRUCT: termios
+ { "tcflag_t" "iflag" } ! input mode flags
+ { "tcflag_t" "oflag" } ! output mode flags
+ { "tcflag_t" "cflag" } ! control mode flags
+ { "tcflag_t" "lflag" } ! local mode flags
+ { { "cc_t" NCCS } "cc" } ! control characters
+ { "speed_t" "ispeed" } ! input speed
+ { "speed_t" "ospeed" } ; ! output speed
diff --git a/extra/io/serial/unix/termios/bsd/tags.txt b/extra/io/serial/unix/termios/bsd/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/io/serial/unix/termios/bsd/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/io/serial/unix/termios/linux/linux.factor b/extra/io/serial/unix/termios/linux/linux.factor
new file mode 100644
index 0000000000..c7da10a6f5
--- /dev/null
+++ b/extra/io/serial/unix/termios/linux/linux.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel system unix ;
+IN: io.serial.unix.termios
+
+: NCCS 32 ; inline
+
+TYPEDEF: uchar cc_t
+TYPEDEF: uint speed_t
+TYPEDEF: uint tcflag_t
+
+C-STRUCT: termios
+ { "tcflag_t" "iflag" } ! input mode flags
+ { "tcflag_t" "oflag" } ! output mode flags
+ { "tcflag_t" "cflag" } ! control mode flags
+ { "tcflag_t" "lflag" } ! local mode flags
+ { "cc_t" "line" } ! line discipline
+ { { "cc_t" NCCS } "cc" } ! control characters
+ { "speed_t" "ispeed" } ! input speed
+ { "speed_t" "ospeed" } ; ! output speed
diff --git a/extra/io/serial/unix/termios/linux/tags.txt b/extra/io/serial/unix/termios/linux/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/io/serial/unix/termios/linux/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/io/serial/unix/termios/tags.txt b/extra/io/serial/unix/termios/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/io/serial/unix/termios/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/io/serial/unix/termios/termios.factor b/extra/io/serial/unix/termios/termios.factor
new file mode 100644
index 0000000000..440d9114f0
--- /dev/null
+++ b/extra/io/serial/unix/termios/termios.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators system vocabs.loader ;
+IN: io.serial.unix.termios
+
+{
+ { [ os linux? ] [ "serial.unix.termios.linux" ] }
+ { [ os bsd? ] [ "serial.unix.termios.bsd" ] }
+} cond require
diff --git a/extra/io/serial/unix/unix-tests.factor b/extra/io/serial/unix/unix-tests.factor
new file mode 100644
index 0000000000..bbfd10b943
--- /dev/null
+++ b/extra/io/serial/unix/unix-tests.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math.bitfields serial serial.unix ;
+IN: io.serial.unix
+
+: serial-obj ( -- obj )
+ serial new
+ "/dev/ttyS0" >>path
+ 19200 >>baud
+ { IGNPAR ICRNL } flags >>iflag
+ { } flags >>oflag
+ { CS8 CLOCAL CREAD } flags >>cflag
+ { ICANON } flags >>lflag ;
+
+: serial-test ( -- serial )
+ serial-obj
+ open-serial
+ dup get-termios >>termios
+ dup configure-termios
+ dup tciflush
+ dup apply-termios ;
diff --git a/extra/io/serial/unix/unix.factor b/extra/io/serial/unix/unix.factor
new file mode 100644
index 0000000000..50849c5d36
--- /dev/null
+++ b/extra/io/serial/unix/unix.factor
@@ -0,0 +1,63 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax combinators io.ports
+io.streams.duplex io.unix.backend system kernel math math.bitfields
+vocabs.loader unix serial serial.unix.termios ;
+IN: io.serial.unix
+
+<< {
+ { [ os linux? ] [ "serial.unix.linux" ] }
+ { [ os bsd? ] [ "serial.unix.bsd" ] }
+} cond require >>
+
+FUNCTION: speed_t cfgetispeed ( termios* t ) ;
+FUNCTION: speed_t cfgetospeed ( termios* t ) ;
+FUNCTION: int cfsetispeed ( termios* t, speed_t s ) ;
+FUNCTION: int cfsetospeed ( termios* t, speed_t s ) ;
+FUNCTION: int tcgetattr ( int i1, termios* t ) ;
+FUNCTION: int tcsetattr ( int i1, int i2, termios* t ) ;
+FUNCTION: int tcdrain ( int i1 ) ;
+FUNCTION: int tcflow ( int i1, int i2 ) ;
+FUNCTION: int tcflush ( int i1, int i2 ) ;
+FUNCTION: int tcsendbreak ( int i1, int i2 ) ;
+FUNCTION: void cfmakeraw ( termios* t ) ;
+FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
+
+: fd>duplex-stream ( fd -- duplex-stream )
+ <fd> init-fd
+ [ <input-port> ] [ <output-port> ] bi <duplex-stream> ;
+
+: open-rw ( path -- fd ) O_RDWR file-mode open-file ;
+: <file-rw> ( path -- stream ) open-rw fd>duplex-stream ;
+
+M: unix open-serial ( serial -- serial' )
+ dup
+ path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
+ fd>duplex-stream >>stream ;
+
+: serial-fd ( serial -- fd )
+ stream>> in>> handle>> fd>> ;
+
+: get-termios ( serial -- termios )
+ serial-fd
+ "termios" <c-object> [ tcgetattr io-error ] keep ;
+
+: configure-termios ( serial -- )
+ dup termios>>
+ {
+ [ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ]
+ [ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ]
+ [
+ [
+ [ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor
+ ] dip set-termios-cflag
+ ]
+ [ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ]
+ } 2cleave ;
+
+: tciflush ( serial -- )
+ serial-fd TCIFLUSH tcflush io-error ;
+
+: apply-termios ( serial -- )
+ [ serial-fd TCSANOW ]
+ [ termios>> ] bi tcsetattr io-error ;
From b333583da4401560b6e137cd8131025754d41d1d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 14 Aug 2008 23:54:57 -0500
Subject: [PATCH 43/44] fix usings
---
extra/io/serial/serial.factor | 5 ++---
extra/io/serial/unix/bsd/bsd.factor | 2 +-
extra/io/serial/unix/linux/linux.factor | 2 +-
extra/io/serial/unix/termios/termios.factor | 4 ++--
extra/io/serial/unix/unix.factor | 9 ++++-----
5 files changed, 10 insertions(+), 12 deletions(-)
diff --git a/extra/io/serial/serial.factor b/extra/io/serial/serial.factor
index 117ae7f80b..c24f08906c 100644
--- a/extra/io/serial/serial.factor
+++ b/extra/io/serial/serial.factor
@@ -15,9 +15,8 @@ M: invalid-baud summary ( invalid-baud -- string )
" not supported" 3append ;
HOOK: lookup-baud os ( m -- n )
-HOOK: open-serial os ( serial -- serial' )
-M: serial dispose ( serial -- ) stream>> dispose ;
+HOOK: open-serial os ( serial -- stream )
{
- { [ os unix? ] [ "serial.unix" ] }
+ { [ os unix? ] [ "io.serial.unix" ] }
} cond require
diff --git a/extra/io/serial/unix/bsd/bsd.factor b/extra/io/serial/unix/bsd/bsd.factor
index 915fd8ce08..3c5ce62c63 100644
--- a/extra/io/serial/unix/bsd/bsd.factor
+++ b/extra/io/serial/unix/bsd/bsd.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math.bitfields sequences system serial ;
+USING: alien.syntax kernel math.bitfields sequences system io.serial ;
IN: io.serial.unix
M: bsd lookup-baud ( m -- n )
diff --git a/extra/io/serial/unix/linux/linux.factor b/extra/io/serial/unix/linux/linux.factor
index d8158ae8bb..342ff4499f 100644
--- a/extra/io/serial/unix/linux/linux.factor
+++ b/extra/io/serial/unix/linux/linux.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs alien.syntax kernel serial system unix ;
+USING: assocs alien.syntax kernel io.serial system unix ;
IN: io.serial.unix
: TCSANOW 0 ; inline
diff --git a/extra/io/serial/unix/termios/termios.factor b/extra/io/serial/unix/termios/termios.factor
index 440d9114f0..e5ccd37e87 100644
--- a/extra/io/serial/unix/termios/termios.factor
+++ b/extra/io/serial/unix/termios/termios.factor
@@ -4,6 +4,6 @@ USING: combinators system vocabs.loader ;
IN: io.serial.unix.termios
{
- { [ os linux? ] [ "serial.unix.termios.linux" ] }
- { [ os bsd? ] [ "serial.unix.termios.bsd" ] }
+ { [ os linux? ] [ "io.serial.unix.termios.linux" ] }
+ { [ os bsd? ] [ "io.serial.unix.termios.bsd" ] }
} cond require
diff --git a/extra/io/serial/unix/unix.factor b/extra/io/serial/unix/unix.factor
index 50849c5d36..ed60d941dd 100644
--- a/extra/io/serial/unix/unix.factor
+++ b/extra/io/serial/unix/unix.factor
@@ -2,12 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax combinators io.ports
io.streams.duplex io.unix.backend system kernel math math.bitfields
-vocabs.loader unix serial serial.unix.termios ;
+vocabs.loader unix io.serial io.serial.unix.termios ;
IN: io.serial.unix
<< {
- { [ os linux? ] [ "serial.unix.linux" ] }
- { [ os bsd? ] [ "serial.unix.bsd" ] }
+ { [ os linux? ] [ "io.serial.unix.linux" ] }
+ { [ os bsd? ] [ "io.serial.unix.bsd" ] }
} cond require >>
FUNCTION: speed_t cfgetispeed ( termios* t ) ;
@@ -31,9 +31,8 @@ FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
: <file-rw> ( path -- stream ) open-rw fd>duplex-stream ;
M: unix open-serial ( serial -- serial' )
- dup
path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
- fd>duplex-stream >>stream ;
+ fd>duplex-stream ;
: serial-fd ( serial -- fd )
stream>> in>> handle>> fd>> ;
From cf556faf6600057530aafc35c7bfcfb3ce469ca4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 15 Aug 2008 04:09:34 -0500
Subject: [PATCH 44/44] Cleanup
---
basis/prettyprint/sections/sections.factor | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor
index 23a50700b3..168e118d4b 100644
--- a/basis/prettyprint/sections/sections.factor
+++ b/basis/prettyprint/sections/sections.factor
@@ -171,10 +171,11 @@ M: block section-fits? ( section -- ? )
line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
- swap sections>> [ line-break? not ] filter
- unclip pprint-section [
- dup rot call pprint-section
- ] with each ; inline
+ [
+ sections>> [ line-break? not ] filter
+ unclip-slice pprint-section
+ ] dip
+ [ [ pprint-section ] bi ] curry each ; inline
M: block short-section ( block -- )
[ advance ] pprint-sections ;