From 271ef297220202ab492fb8517bc699ebca7526c2 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Sun, 30 Mar 2008 12:18:42 -0500
Subject: [PATCH 001/288] Formatting license
---
license.txt | 46 ++++++++++++++++++++++------------------------
1 file changed, 22 insertions(+), 24 deletions(-)
diff --git a/license.txt b/license.txt
index 87f170da8c..768c13c549 100644
--- a/license.txt
+++ b/license.txt
@@ -1,24 +1,22 @@
-/*
- * Copyright (C) 2003, 2007 Slava Pestov and friends.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * 1. Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- *
- * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
- * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
- * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
- * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
- * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
- * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
- * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- */
+Copyright (C) 2003, 2008 Slava Pestov and friends.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
From 23bdf2faa7ac92bd433671539e5153166839122c Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@self.internal.stack-effects.com>
Date: Mon, 31 Mar 2008 08:57:16 -0500
Subject: [PATCH 002/288] add using
---
extra/io/unix/sockets/sockets.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index dea7dc17b5..c7931c6f0c 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators ;
+combinators io.backend ;
IN: io.unix.sockets
: pending-init-error ( port -- )
From b21d83b53130a87f6adc9498cf06c086081ce260 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 12:47:39 -0500
Subject: [PATCH 003/288] remove failing unit test for now
---
extra/openssl/openssl-tests.factor | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor
index c689f729d1..c85c0ee218 100755
--- a/extra/openssl/openssl-tests.factor
+++ b/extra/openssl/openssl-tests.factor
@@ -11,11 +11,12 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
]
[ "Hello world from the openssl binding" >md5 ] unit-test
-[
- B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
- 82 115 0 }
-]
-[ "Hello world from the openssl binding" >sha1 ] unit-test
+! Not found on netbsd, windows -- why?
+! [
+ ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
+ ! 82 115 0 }
+! ]
+! [ "Hello world from the openssl binding" >sha1 ] unit-test
! =========================================================
! Initialize context
From 13b31be060071a645bdef5ed61e258d6173e93a6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 13:43:42 -0500
Subject: [PATCH 004/288] fix copy-tree
---
core/io/files/files.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 458a9145a6..f397af606b 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -4,6 +4,7 @@ USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary init accessors ;
+USE: tools.walker
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@@ -267,6 +268,7 @@ M: object copy-file
DEFER: copy-tree-into
: copy-tree ( from to -- )
+ normalize-pathname
over link-info type>>
{
{ +symbolic-link+ [ copy-link ] }
From b13ac1e17f323f826669f6758a90453940e4cbb5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 13:51:24 -0500
Subject: [PATCH 005/288] remove using
---
core/io/files/files.factor | 1 -
1 file changed, 1 deletion(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index f397af606b..099acb157e 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -4,7 +4,6 @@ USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary init accessors ;
-USE: tools.walker
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
From a8e223f47143bf193d5df8f7b3bfe2308c7cb574 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 13:51:34 -0500
Subject: [PATCH 006/288] fix unix domain socket test
---
extra/io/sockets/sockets.factor | 3 ++-
extra/io/unix/sockets/sockets.factor | 4 ++--
2 files changed, 4 insertions(+), 3 deletions(-)
diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor
index 1dc7f4883d..e1cc36cd2e 100755
--- a/extra/io/sockets/sockets.factor
+++ b/extra/io/sockets/sockets.factor
@@ -6,7 +6,8 @@ IN: io.sockets
TUPLE: local path ;
-C: <local> local
+: <local> ( path -- addrspec )
+ normalize-pathname local construct-boa ;
TUPLE: inet4 host port ;
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index c7931c6f0c..69ce6a3069 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend ;
+combinators io.backend io.files ;
IN: io.unix.sockets
: pending-init-error ( port -- )
@@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ;
M: local sockaddr-type drop "sockaddr-un" c-type ;
M: local make-sockaddr
- local-path normalize-pathname
+ local-path cwd prepend-path
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
From 0a63a8fb40dd290b36958bad7cda4b2751b961c6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 14:38:11 -0500
Subject: [PATCH 007/288] normalize-pathname in local sockets
---
extra/io/unix/sockets/sockets.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index bd7dfd9ce1..dea7dc17b5 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ;
M: local sockaddr-type drop "sockaddr-un" c-type ;
M: local make-sockaddr
- local-path
+ local-path normalize-pathname
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
From f49c72bb05fd5a2af16622f20b6771a857b10fac Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 15:31:51 -0500
Subject: [PATCH 008/288] remove curry2 from mersenne.private...
---
extra/random/mersenne-twister/mersenne-twister.factor | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index ce1749ce62..8ddbdac6f4 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -9,9 +9,6 @@ IN: random.mersenne-twister
<PRIVATE
-: curry2 ( w quot1 quot2 -- quot1 quot2 )
- >r over r> [ curry ] 2bi@ ; inline
-
TUPLE: mersenne-twister seq i ;
: mt-n 624 ; inline
@@ -27,7 +24,7 @@ TUPLE: mersenne-twister seq i ;
r> bitxor bitxor r> r> set-nth ; inline
: calculate-y ( y1 y2 mt -- y )
- [ nth mt-hi ] [ nth mt-lo ] curry2 bi* bitor ; inline
+ tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline
: (mt-generate) ( n mt-seq -- y to from-elt )
[ >r dup 1+ mt-wrap r> calculate-y ]
From c2fdd797bcbff592ac1a65cba2044d7f8aef719f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 31 Mar 2008 16:20:09 -0500
Subject: [PATCH 009/288] Try to fix inotify again
---
extra/io/unix/linux/linux.factor | 25 +++++++++++++------------
1 file changed, 13 insertions(+), 12 deletions(-)
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 7580e7bf6b..3a8fad3d4d 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -3,8 +3,8 @@
USING: kernel io.backend io.monitors io.monitors.private
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
io.unix.select io.unix.launcher unix.linux.inotify assocs
-namespaces threads continuations init math
-alien.c-types alien vocabs.loader ;
+namespaces threads continuations init math alien.c-types alien
+vocabs.loader accessors ;
IN: io.unix.linux
TUPLE: linux-io ;
@@ -18,18 +18,16 @@ TUPLE: linux-monitor ;
TUPLE: inotify watches ;
-: watches ( -- assoc ) inotify get-global inotify-watches ;
+: watches ( -- assoc ) inotify get-global watches>> ;
: wd>monitor ( wd -- monitor ) watches at ;
: <inotify> ( -- port/f )
H{ } clone
- inotify_init dup 0 < [ 2drop f ] [
- inotify <buffered-port>
- { set-inotify-watches set-delegate } inotify construct
- ] if ;
+ inotify_init [ io-error ] [ inotify <buffered-port> ] bi
+ { set-inotify-watches set-delegate } inotify construct ;
-: inotify-fd inotify get-global port-handle ;
+: inotify-fd inotify get-global handle>> ;
: (add-watch) ( path mask -- wd )
inotify-fd -rot inotify_add_watch dup io-error ;
@@ -80,10 +78,10 @@ M: linux-monitor dispose ( monitor -- )
parse-action swap alien>char-string ;
: events-exhausted? ( i buffer -- ? )
- buffer-fill >= ;
+ fill>> >= ;
: inotify-event@ ( i buffer -- alien )
- buffer-ptr <displaced-alien> ;
+ ptr>> <displaced-alien> ;
: next-event ( i buffer -- i buffer )
2dup inotify-event@
@@ -111,14 +109,17 @@ TUPLE: inotify-task ;
f inotify-task <input-task> ;
: init-inotify ( mx -- )
- <inotify> dup inotify set-global
+ <inotify>
+ dup inotify set-global
<inotify-task> swap register-io-task ;
M: inotify-task do-io-task ( task -- )
io-task-port read-notifications f ;
M: linux-io init-io ( -- )
- <select-mx> dup mx set-global init-inotify ;
+ <select-mx>
+ [ mx set-global ]
+ [ [ init-inotify ] ignore-errors ] bi ;
T{ linux-io } set-io-backend
From 8742c3f2dcb95f5e6efcdf9ac94e52819096b1e0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 31 Mar 2008 16:20:22 -0500
Subject: [PATCH 010/288] Oops
---
extra/io/unix/linux/linux.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 3a8fad3d4d..2ae4065fb6 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -119,7 +119,7 @@ M: inotify-task do-io-task ( task -- )
M: linux-io init-io ( -- )
<select-mx>
[ mx set-global ]
- [ [ init-inotify ] ignore-errors ] bi ;
+ [ [ init-inotify ] curry ignore-errors ] bi ;
T{ linux-io } set-io-backend
From ecf59b716844aa429e51be4dfcbc73c93bb44980 Mon Sep 17 00:00:00 2001
From: "U-CUTLER\\dharmatech" <dharmatech@cutler.(none)>
Date: Mon, 31 Mar 2008 15:27:32 -0600
Subject: [PATCH 011/288] Move ldap to unmaintained
---
{extra => unmaintained}/ldap/authors.txt | 0
{extra => unmaintained}/ldap/conf/addentry.ldif | 0
{extra => unmaintained}/ldap/conf/createdit.ldif | 0
{extra => unmaintained}/ldap/conf/slapd.conf | 0
{extra => unmaintained}/ldap/ldap-tests.factor | 0
{extra => unmaintained}/ldap/ldap.factor | 0
{extra => unmaintained}/ldap/libldap/authors.txt | 0
{extra => unmaintained}/ldap/libldap/libldap.factor | 0
{extra => unmaintained}/ldap/libldap/tags.txt | 0
{extra => unmaintained}/ldap/summary.txt | 0
{extra => unmaintained}/ldap/tags.txt | 0
11 files changed, 0 insertions(+), 0 deletions(-)
rename {extra => unmaintained}/ldap/authors.txt (100%)
rename {extra => unmaintained}/ldap/conf/addentry.ldif (100%)
rename {extra => unmaintained}/ldap/conf/createdit.ldif (100%)
rename {extra => unmaintained}/ldap/conf/slapd.conf (100%)
rename {extra => unmaintained}/ldap/ldap-tests.factor (100%)
rename {extra => unmaintained}/ldap/ldap.factor (100%)
rename {extra => unmaintained}/ldap/libldap/authors.txt (100%)
rename {extra => unmaintained}/ldap/libldap/libldap.factor (100%)
rename {extra => unmaintained}/ldap/libldap/tags.txt (100%)
rename {extra => unmaintained}/ldap/summary.txt (100%)
rename {extra => unmaintained}/ldap/tags.txt (100%)
diff --git a/extra/ldap/authors.txt b/unmaintained/ldap/authors.txt
similarity index 100%
rename from extra/ldap/authors.txt
rename to unmaintained/ldap/authors.txt
diff --git a/extra/ldap/conf/addentry.ldif b/unmaintained/ldap/conf/addentry.ldif
similarity index 100%
rename from extra/ldap/conf/addentry.ldif
rename to unmaintained/ldap/conf/addentry.ldif
diff --git a/extra/ldap/conf/createdit.ldif b/unmaintained/ldap/conf/createdit.ldif
similarity index 100%
rename from extra/ldap/conf/createdit.ldif
rename to unmaintained/ldap/conf/createdit.ldif
diff --git a/extra/ldap/conf/slapd.conf b/unmaintained/ldap/conf/slapd.conf
similarity index 100%
rename from extra/ldap/conf/slapd.conf
rename to unmaintained/ldap/conf/slapd.conf
diff --git a/extra/ldap/ldap-tests.factor b/unmaintained/ldap/ldap-tests.factor
similarity index 100%
rename from extra/ldap/ldap-tests.factor
rename to unmaintained/ldap/ldap-tests.factor
diff --git a/extra/ldap/ldap.factor b/unmaintained/ldap/ldap.factor
similarity index 100%
rename from extra/ldap/ldap.factor
rename to unmaintained/ldap/ldap.factor
diff --git a/extra/ldap/libldap/authors.txt b/unmaintained/ldap/libldap/authors.txt
similarity index 100%
rename from extra/ldap/libldap/authors.txt
rename to unmaintained/ldap/libldap/authors.txt
diff --git a/extra/ldap/libldap/libldap.factor b/unmaintained/ldap/libldap/libldap.factor
similarity index 100%
rename from extra/ldap/libldap/libldap.factor
rename to unmaintained/ldap/libldap/libldap.factor
diff --git a/extra/ldap/libldap/tags.txt b/unmaintained/ldap/libldap/tags.txt
similarity index 100%
rename from extra/ldap/libldap/tags.txt
rename to unmaintained/ldap/libldap/tags.txt
diff --git a/extra/ldap/summary.txt b/unmaintained/ldap/summary.txt
similarity index 100%
rename from extra/ldap/summary.txt
rename to unmaintained/ldap/summary.txt
diff --git a/extra/ldap/tags.txt b/unmaintained/ldap/tags.txt
similarity index 100%
rename from extra/ldap/tags.txt
rename to unmaintained/ldap/tags.txt
From 01d0ab20c67c8b6e240f0ceaa6092cfca55ef919 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 15:28:21 -0600
Subject: [PATCH 012/288] sequences: new words: prefix and suffix
---
core/sequences/sequences.factor | 19 ++++++++++++++++---
1 file changed, 16 insertions(+), 3 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 1f2a6c5501..26c1013c28 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -478,18 +478,31 @@ M: sequence <=>
: push-new ( elt seq -- ) [ delete ] 2keep push ;
+: add* ( seq elt -- newseq )
+ over >r over length 1+ r> [
+ [ 0 swap set-nth-unsafe ] keep
+ [ 1 swap copy ] keep
+ ] new-like ;
+
+: prefix ( seq elt -- newseq )
+ over >r over length 1+ r> [
+ [ 0 swap set-nth-unsafe ] keep
+ [ 1 swap copy ] keep
+ ] new-like ;
+
: add ( seq elt -- newseq )
over >r over length 1+ r> [
[ >r over length r> set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
-: add* ( seq elt -- newseq )
+: suffix ( seq elt -- newseq )
over >r over length 1+ r> [
- [ 0 swap set-nth-unsafe ] keep
- [ 1 swap copy ] keep
+ [ >r over length r> set-nth-unsafe ] keep
+ [ 0 swap copy ] keep
] new-like ;
+
: seq-diff ( seq1 seq2 -- newseq )
swap [ member? not ] curry subset ;
From 4181728ecaf15c2d6fcc8ea5b237a9354685b72a Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 15:29:22 -0600
Subject: [PATCH 013/288] ui.gadgets.slate: add some gesture handling for
processing demos
---
extra/ui/gadgets/slate/slate.factor | 104 +++++++++++++++++++++++++++-
1 file changed, 102 insertions(+), 2 deletions(-)
diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor
index 5ea1ec20fa..ab2abeec5b 100644
--- a/extra/ui/gadgets/slate/slate.factor
+++ b/extra/ui/gadgets/slate/slate.factor
@@ -3,7 +3,11 @@ USING: kernel namespaces opengl ui.render ui.gadgets ;
IN: ui.gadgets.slate
-TUPLE: slate action dim graft ungraft ;
+TUPLE: slate action dim graft ungraft
+ button-down
+ button-up
+ key-down
+ key-up ;
: <slate> ( action -- slate )
slate construct-gadget
@@ -19,4 +23,100 @@ M: slate draw-gadget* ( slate -- )
M: slate graft* ( slate -- ) slate-graft call ;
-M: slate ungraft* ( slate -- ) slate-ungraft call ;
\ No newline at end of file
+M: slate ungraft* ( slate -- ) slate-ungraft call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-pressed-value
+
+: key-pressed? ( -- ? ) key-pressed-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: mouse-pressed-value
+
+: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-value
+
+: key ( -- key ) key-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: button-value
+
+: button ( -- val ) button-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators ui.gestures accessors ;
+
+! M: slate handle-gesture* ( gadget gesture delegate -- ? )
+! drop nip
+! {
+! {
+! [ dup key-down? ]
+! [
+
+! key-down-sym key-value set
+! key-pressed-value on
+! t
+! ]
+! }
+! { [ dup key-up? ] [ drop key-pressed-value off t ] }
+! {
+! [ dup button-down? ]
+! [
+! button-down-# mouse-button-value set
+! mouse-pressed-value on
+! t
+! ]
+! }
+! { [ dup button-up? ] [ drop mouse-pressed-value off t ] }
+! { [ t ] [ drop t ] }
+! }
+! cond ;
+
+M: slate handle-gesture* ( gadget gesture delegate -- ? )
+ rot drop swap ! delegate gesture
+ {
+ {
+ [ dup key-down? ]
+ [
+ key-down-sym key-value set
+ key-pressed-value on
+ key-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup key-up? ]
+ [
+ key-pressed-value off
+ drop
+ key-up>> dup [ call ] [ drop ] if
+ t
+ ] }
+ {
+ [ dup button-down? ]
+ [
+ button-down-# button-value set
+ mouse-pressed-value on
+ button-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup button-up? ]
+ [
+ mouse-pressed-value off
+ drop
+ button-up>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ { [ t ] [ 2drop t ] }
+ }
+ cond ;
\ No newline at end of file
From 72bfd57f308a6b2efe7c8b9697282eab00588856 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 1 Apr 2008 11:28:14 +1300
Subject: [PATCH 014/288] Make ebnf forgiving of whitespace at end of
expression
---
extra/peg/ebnf/ebnf.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 4f00edbd3c..26e5d68df8 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -320,7 +320,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: check-parse-result ( result -- result )
dup [
- dup parse-result-remaining empty? [
+ dup parse-result-remaining [ blank? ] trim empty? [
[
"Unable to fully parse EBNF. Left to parse was: " %
parse-result-remaining %
From aa40350aa76805e1aed683966647aaeea2d7ed28 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 18:18:05 -0600
Subject: [PATCH 015/288] replace add* and add with prefix and suffix
---
core/alien/c-types/c-types.factor | 12 ++++++------
core/alien/compiler/compiler.factor | 2 +-
core/alien/structs/structs-docs.factor | 10 +++++-----
core/alien/structs/structs.factor | 2 +-
core/classes/algebra/algebra.factor | 8 ++++----
core/classes/classes.factor | 2 +-
core/classes/mixin/mixin.factor | 2 +-
core/classes/tuple/tuple.factor | 2 +-
core/combinators/combinators.factor | 4 ++--
core/cpu/x86/assembler/assembler.factor | 2 +-
core/cpu/x86/intrinsics/intrinsics.factor | 4 ++--
core/cpu/x86/sse2/sse2.factor | 4 ++--
core/generic/generic.factor | 2 +-
core/generic/standard/standard.factor | 6 +++---
core/inference/backend/backend.factor | 6 +++---
core/inference/class/class.factor | 2 +-
core/inference/dataflow/dataflow.factor | 2 +-
core/inference/transforms/transforms.factor | 2 +-
core/io/encodings/encodings.factor | 2 +-
core/optimizer/known-words/known-words.factor | 2 +-
core/optimizer/specializers/specializers.factor | 2 +-
core/parser/parser.factor | 2 +-
core/slots/slots.factor | 2 +-
core/splitting/splitting.factor | 2 +-
core/vocabs/loader/loader.factor | 2 +-
core/vocabs/vocabs.factor | 2 +-
extra/benchmark/fasta/fasta.factor | 2 +-
extra/cfdg/cfdg.factor | 2 +-
extra/color-picker/color-picker.factor | 2 +-
extra/delegate/delegate.factor | 2 +-
extra/editors/editors.factor | 2 +-
extra/faq/faq.factor | 2 +-
extra/fry/fry.factor | 2 +-
extra/help/markup/markup.factor | 2 +-
extra/koszul/koszul.factor | 4 ++--
extra/lazy-lists/lazy-lists.factor | 2 +-
extra/locals/locals.factor | 8 ++++----
extra/logging/logging.factor | 2 +-
extra/lsys/tortoise/graphics/graphics.factor | 2 +-
extra/math/combinatorics/combinatorics.factor | 2 +-
extra/multi-methods/multi-methods.factor | 4 ++--
extra/opengl/gl/extensions/extensions.factor | 2 +-
extra/oracle/oracle.factor | 4 ++--
extra/parser-combinators/parser-combinators.factor | 6 +++---
extra/peg/peg.factor | 4 ++--
extra/project-euler/043/043.factor | 4 ++--
extra/project-euler/common/common.factor | 4 ++--
extra/qualified/qualified.factor | 2 +-
extra/regexp/regexp.factor | 2 +-
extra/regexp2/regexp2.factor | 2 +-
extra/sequences/lib/lib.factor | 2 +-
extra/springies/springies.factor | 4 ++--
extra/state-machine/state-machine.factor | 2 +-
extra/tetris/board/board.factor | 2 +-
extra/tools/deploy/backend/backend.factor | 4 ++--
extra/tools/vocabs/vocabs.factor | 4 ++--
extra/tools/walker/walker.factor | 6 +++---
extra/ui/commands/commands-docs.factor | 2 +-
extra/ui/gadgets/grid-lines/grid-lines.factor | 2 +-
extra/ui/gadgets/panes/panes.factor | 2 +-
extra/unix/process/process.factor | 2 +-
extra/xmode/rules/rules.factor | 2 +-
62 files changed, 97 insertions(+), 97 deletions(-)
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index d874243d71..ae99f9e6bf 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -45,7 +45,7 @@ GENERIC: c-type ( name -- type ) foldable
: parse-array-type ( name -- array )
"[" split unclip
- >r [ "]" ?tail drop string>number ] map r> add* ;
+ >r [ "]" ?tail drop string>number ] map r> prefix ;
M: string c-type ( name -- type )
CHAR: ] over member? [
@@ -162,7 +162,7 @@ DEFER: >c-ushort-array
>r >c-ushort-array r> byte-array>memory ;
: (define-nth) ( word type quot -- )
- >r heap-size [ rot * ] swap add* r> append define-inline ;
+ >r heap-size [ rot * ] swap prefix r> append define-inline ;
: nth-word ( name vocab -- word )
>r "-nth" append r> create ;
@@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- )
f swap box-parameter ;
: define-deref ( name vocab -- )
- >r dup CHAR: * add* r> create
- swap c-getter 0 add* define-inline ;
+ >r dup CHAR: * prefix r> create
+ swap c-getter 0 prefix define-inline ;
: define-out ( name vocab -- )
over [ <c-object> tuck 0 ] over c-setter append swap
- >r >r constructor-word r> r> add* define-inline ;
+ >r >r constructor-word r> r> prefix define-inline ;
: c-bool> ( int -- ? )
zero? not ;
@@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- )
#! staging violations
dup array? [
unclip >r [ dup word? [ word-def call ] when ] map
- r> add*
+ r> prefix
] when ;
: malloc-file-contents ( path -- alien len )
diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 3e0062c85a..1a9d5b5392 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -18,7 +18,7 @@ IN: alien.compiler
: alien-node-parameters* ( node -- seq )
dup parameters>>
- swap return>> large-struct? [ "void*" add* ] when ;
+ swap return>> large-struct? [ "void*" prefix ] when ;
: alien-node-return* ( node -- ctype )
return>> dup large-struct? [ drop "void" ] when ;
diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor
index 6c7775de2b..e7e576293f 100755
--- a/core/alien/structs/structs-docs.factor
+++ b/core/alien/structs/structs-docs.factor
@@ -8,7 +8,7 @@ kernel words slots assocs namespaces ;
dup ?word-name swap 2array
over slot-spec-name
rot slot-spec-type 2array 2array
- [ { $instance } swap add ] assoc-map ;
+ [ { $instance } swap suffix ] assoc-map ;
: $spec-reader-values ( slot-spec class -- )
($spec-reader-values) $values ;
@@ -16,9 +16,9 @@ kernel words slots assocs namespaces ;
: $spec-reader-description ( slot-spec class -- )
[
"Outputs the value stored in the " ,
- { $snippet } rot slot-spec-name add ,
+ { $snippet } rot slot-spec-name suffix ,
" slot of " ,
- { $instance } swap add ,
+ { $instance } swap suffix ,
" instance." ,
] { } make $description ;
@@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ;
: $spec-writer-description ( slot-spec class -- )
[
"Stores a new value to the " ,
- { $snippet } rot slot-spec-name add ,
+ { $snippet } rot slot-spec-name suffix ,
" slot of " ,
- { $instance } swap add ,
+ { $instance } swap suffix ,
" instance." ,
] { } make $description ;
diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor
index e5de8ab83e..491f4351a3 100755
--- a/core/alien/structs/structs.factor
+++ b/core/alien/structs/structs.factor
@@ -16,7 +16,7 @@ IN: alien.structs
] reduce ;
: define-struct-slot-word ( spec word quot -- )
- rot slot-spec-offset add* define-inline ;
+ rot slot-spec-offset prefix define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 2945bd2546..5d7c114cbc 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
- >r members>> r> add <anonymous-intersection> ;
+ >r members>> r> suffix <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
- members>> swap add <anonymous-intersection> ;
+ members>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class )
{
@@ -158,10 +158,10 @@ C: <anonymous-complement> anonymous-complement
} cond ;
: left-anonymous-union-or ( first second -- class )
- >r members>> r> add <anonymous-union> ;
+ >r members>> r> suffix <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
- members>> swap add <anonymous-union> ;
+ members>> swap suffix <anonymous-union> ;
: (class-or) ( first second -- class )
{
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 435c7413a3..d6d1a72121 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -72,7 +72,7 @@ M: word reset-class drop ;
! update-map
: class-uses ( class -- seq )
- dup members swap superclass [ add ] when* ;
+ dup members swap superclass [ suffix ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index eb6b3bd6e2..b771aa8920 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ;
swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- )
- [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
+ [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index a452d0eeec..fcce6a7b45 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -34,7 +34,7 @@ PRIVATE>
: tuple>array ( tuple -- array )
dup tuple-layout
[ layout-size swap [ array-nth ] curry map ] keep
- layout-class add* ;
+ layout-class prefix ;
: >tuple ( seq -- tuple )
dup first tuple-layout <tuple> [
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index e19847dbd4..484c7ab730 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -43,7 +43,7 @@ ERROR: no-case ;
: with-datastack ( stack quot -- newstack )
datastack >r
>r >array set-datastack r> call
- datastack r> swap add set-datastack 2nip ; inline
+ datastack r> swap suffix set-datastack 2nip ; inline
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
@@ -66,7 +66,7 @@ M: hashtable hashcode*
reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- quot )
- [ >r [ dupd = ] curry r> \ drop add* ] assoc-map
+ [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
alist>quot ;
: (distribute-buckets) ( buckets pair keys -- )
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index 796388ffe1..a3ab256ea1 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/core/cpu/x86/assembler/assembler.factor
@@ -230,7 +230,7 @@ UNION: operand register indirect ;
: opcode-or ( opcode mask -- opcode' )
swap dup array?
- [ 1 cut* first rot bitor add ] [ bitor ] if ;
+ [ 1 cut* first rot bitor suffix ] [ bitor ] if ;
: 1-operand ( op reg rex.w opcode -- )
#! The 'reg' is not really a register, but a value for the
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index f5409a24f5..261ada025b 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -156,7 +156,7 @@ IN: cpu.x86.intrinsics
! Fixnums
: fixnum-op ( op hash -- pair )
- >r [ "x" operand "y" operand ] swap add r> 2array ;
+ >r [ "x" operand "y" operand ] swap suffix r> 2array ;
: fixnum-value-op ( op -- pair )
H{
@@ -251,7 +251,7 @@ IN: cpu.x86.intrinsics
\ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair )
- >r [ "x" operand "y" operand CMP ] swap add r> 2array ;
+ >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor
index 98e42fa7fe..9c477b4132 100755
--- a/core/cpu/x86/sse2/sse2.factor
+++ b/core/cpu/x86/sse2/sse2.factor
@@ -8,7 +8,7 @@ math.floats.private layouts quotations ;
IN: cpu.x86.sse2
: define-float-op ( word op -- )
- [ "x" operand "y" operand ] swap add H{
+ [ "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +output+ { "x" } }
} define-intrinsic ;
@@ -23,7 +23,7 @@ IN: cpu.x86.sse2
] each
: define-float-jump ( word op -- )
- [ "x" operand "y" operand UCOMISD ] swap add
+ [ "x" operand "y" operand UCOMISD ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 131b7e57c9..7dba7eb709 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -157,7 +157,7 @@ M: assoc update-methods ( assoc -- )
M: generic subwords
dup "methods" word-prop values
- swap "default-method" word-prop add ;
+ swap "default-method" word-prop suffix ;
M: generic forget-word
dup subwords [ forget ] each (forget-word) ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 4447c5a264..13b5278735 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -34,8 +34,8 @@ ERROR: no-method object generic ;
: empty-method ( word -- quot )
[
picker % [ delegate dup ] %
- unpicker over add ,
- error-method \ drop add* , \ if ,
+ unpicker over suffix ,
+ error-method \ drop prefix , \ if ,
] [ ] make ;
: class-predicates ( assoc -- assoc )
@@ -137,7 +137,7 @@ ERROR: no-method object generic ;
] if ;
: standard-methods ( word -- alist )
- dup methods swap default-method add*
+ dup methods swap default-method prefix
[ 1quotation ] assoc-map ;
M: standard-combination make-default-method
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 2a2e6995eb..5ca9b1b2e7 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -92,7 +92,7 @@ M: wrapper apply-object
r> recursive-state set ;
: infer-quot-recursive ( quot word label -- )
- recursive-state get -rot 2array add* infer-quot ;
+ recursive-state get -rot 2array prefix infer-quot ;
: time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ;
@@ -109,7 +109,7 @@ TUPLE: recursive-quotation-error quot ;
dup value-literal callable? [
dup value-literal
over value-recursion
- rot f 2array add* infer-quot
+ rot f 2array prefix infer-quot
] [
drop bad-call
] if
@@ -430,7 +430,7 @@ M: #call-label collect-recursion*
[ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- )
- collect-recursion [ node-in-d ] map meta-d get add
+ collect-recursion [ node-in-d ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index ed36ca4890..4aac98ce41 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -289,7 +289,7 @@ M: #label infer-classes-around ( #label -- )
dup annotate-node
dup infer-classes-before
dup infer-children
- dup collect-recursion over add
+ dup collect-recursion over suffix
pick annotate-entry
node-child (infer-classes) ;
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index 0b6cf04028..7fa2fbbcd3 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/core/inference/dataflow/dataflow.factor
@@ -205,7 +205,7 @@ UNION: #branch #if #dispatch ;
2dup 2slip rot [
2drop t
] [
- >r dup node-children swap node-successor add r>
+ >r dup node-children swap node-successor suffix r>
[ node-exists? ] curry contains?
] if
] [
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 200208c6a5..4cfe0432a5 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -56,7 +56,7 @@ M: pair (bitfield-quot) ( spec -- quot )
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
- [ (bitfield-quot) ] map [ 0 ] add* concat ;
+ [ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 2ef26096e0..398fb6a068 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -59,7 +59,7 @@ M: tuple <decoder> f decoder construct-boa ;
over decoder-cr [
over cr-
"\n" ?head [
- over stream-read1 [ add ] when*
+ over stream-read1 [ suffix ] when*
] when
] when nip ;
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index aef48452de..108c715ef0 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -60,7 +60,7 @@ sequences.private combinators ;
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
- [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
+ [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot f splice-quot ;
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index 560a174289..cbdb1b9ec4 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -32,7 +32,7 @@ IN: optimizer.specializers
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
- swap "method-class" word-prop add* ;
+ swap "method-class" word-prop prefix ;
: specialize-method ( quot method -- quot' )
method-declaration [ declare ] curry prepend ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 36e5decd05..58c68a3614 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -294,7 +294,7 @@ M: no-word-error summary
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] }
- [ >r tuple ";" parse-tokens r> add* ]
+ [ >r tuple ";" parse-tokens r> prefix ]
} case ;
ERROR: staging-violation word ;
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index dfd5c1b32a..945678a0d8 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -14,7 +14,7 @@ C: <slot-spec> slot-spec
>r create-method r> define ;
: define-slot-word ( class slot word quot -- )
- rot >fixnum add* define-typecheck ;
+ rot >fixnum prefix define-typecheck ;
: reader-quot ( decl -- quot )
[
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
index 9be1d5fc64..260a08c044 100755
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -76,5 +76,5 @@ INSTANCE: groups sequence
1 head-slice* [
"\r" ?tail drop "\r" split
] map
- ] keep peek "\r" split add concat
+ ] keep peek "\r" split suffix concat
] if ;
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 57947eefb0..1489750154 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -20,7 +20,7 @@ V{
: vocab-dir+ ( vocab str/f -- path )
>r vocab-name "." split r>
- [ >r dup peek r> append add ] when*
+ [ >r dup peek r> append suffix ] when*
"/" join ;
: vocab-dir? ( root name -- ? )
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 886417b715..a6a5a014a7 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -82,7 +82,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or
- [ 2drop t ] [ swap CHAR: . add head? ] if ;
+ [ 2drop t ] [ swap CHAR: . suffix head? ] if ;
: child-vocabs ( vocab -- seq )
vocab-name vocabs [ child-vocab? ] with subset ;
diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor
index 30c3beb1ef..215b677e16 100755
--- a/extra/benchmark/fasta/fasta.factor
+++ b/extra/benchmark/fasta/fasta.factor
@@ -49,7 +49,7 @@ HINTS: random fixnum ;
: make-cumulative ( freq -- chars floats )
dup keys >byte-array
- swap values >float-array unclip [ + ] accumulate swap add ;
+ swap values >float-array unclip [ + ] accumulate swap suffix ;
:: select-random ( seed chars floats -- seed elt )
floats seed random -rot
diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor
index 8a1d93aceb..63fd55a550 100644
--- a/extra/cfdg/cfdg.factor
+++ b/extra/cfdg/cfdg.factor
@@ -32,7 +32,7 @@ VAR: color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ;
+: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ;
: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ;
diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
index 647c83d667..0480235dfe 100755
--- a/extra/color-picker/color-picker.factor
+++ b/extra/color-picker/color-picker.factor
@@ -21,7 +21,7 @@ M: color-preview model-changed
swap model-value over set-gadget-interior relayout-1 ;
: <color-model> ( model -- model )
- [ [ 256 /f ] map 1 add <solid> ] <filter> ;
+ [ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
3 [ drop 0 0 0 255 <range> ] map
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 7f24d6258f..eadd1a03e8 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -27,7 +27,7 @@ M: tuple-class group-words
swap [ slot-spec-writer ] map append ;
: define-consult-method ( word class quot -- )
- pick add >r swap create-method r> define ;
+ pick suffix >r swap create-method r> define ;
: define-consult ( class group quot -- )
>r group-words swap r>
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index 85d58e7572..c442dfaa94 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -43,7 +43,7 @@ SYMBOL: edit-hook
: fix ( word -- )
"Fixing " write dup pprint " and all usages..." print nl
- dup usage swap add* [
+ dup usage swap prefix [
"Editing " write dup .
"RETURN moves on to the next usage, C+d stops." print
flush
diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor
index c6d9cd04d2..1022a02d7e 100644
--- a/extra/faq/faq.factor
+++ b/extra/faq/faq.factor
@@ -69,7 +69,7 @@ C: <faq> faq
: html>faq ( div -- faq )
unclip swap { "h3" "ol" } [ tags-named ] with map
- first2 >r f add* r> [ html>question-list ] 2map <faq> ;
+ first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
: header, ( faq -- )
dup faq-header ,
diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor
index 490ce992ab..d983bd2715 100755
--- a/extra/fry/fry.factor
+++ b/extra/fry/fry.factor
@@ -28,7 +28,7 @@ DEFER: (fry)
! to avoid confusion, remove if fry goes core
{ namespaces:, [ [ curry ] ((fry)) ] }
- [ swap >r add r> (fry) ]
+ [ swap >r suffix r> (fry) ]
} case
] if ;
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
index 5dc7255eed..e933894674 100755
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -235,7 +235,7 @@ M: string ($instance)
: values-row ( seq -- seq )
unclip \ $snippet swap ?word-name 2array
- swap dup first word? [ \ $instance add* ] when 2array ;
+ swap dup first word? [ \ $instance prefix ] when 2array ;
: $values ( element -- )
"Inputs and outputs" $heading
diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor
index f286690d37..add37173b7 100755
--- a/extra/koszul/koszul.factor
+++ b/extra/koszul/koszul.factor
@@ -184,7 +184,7 @@ DEFER: (d)
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
- basis graded graded-ker/im-d flip first2 1 head* 0 add* v- ;
+ basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
@@ -203,7 +203,7 @@ DEFER: (d)
[ basis graded ] bi@ tensor bigraded-ker/im-d
[ [ [ first ] map ] map ] keep
[ [ second ] map 2 head* { 0 0 } prepend ] map
- 1 tail dup first length 0 <array> add
+ 1 tail dup first length 0 <array> suffix
[ v- ] 2map ;
! Laplacian
diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor
index 52cca64b2f..f642d8881c 100644
--- a/extra/lazy-lists/lazy-lists.factor
+++ b/extra/lazy-lists/lazy-lists.factor
@@ -365,7 +365,7 @@ M: lazy-concat nil? ( lazy-concat -- bool )
drop nil
] [
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
- swap [ swap [ add ] lmap-with ] lmap-with lconcat
+ swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
] reduce
] if ;
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 5da0225be9..fe4bd65c14 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -108,7 +108,7 @@ UNION: special local quote local-word local-reader local-writer ;
: point-free-end ( quot args -- newquot )
over peek special?
[ drop-locals >r >r peek r> localize r> append ]
- [ drop-locals nip swap peek add ]
+ [ drop-locals nip swap peek suffix ]
if ;
: (point-free) ( quot args -- newquot )
@@ -130,9 +130,9 @@ GENERIC: free-vars ( form -- vars )
: add-if-free ( vars object -- vars )
{
- { [ dup local-writer? ] [ "local-reader" word-prop add ] }
- { [ dup lexical? ] [ add ] }
- { [ dup quote? ] [ quote-local add ] }
+ { [ dup local-writer? ] [ "local-reader" word-prop suffix ] }
+ { [ dup lexical? ] [ suffix ] }
+ { [ dup quote? ] [ quote-local suffix ] }
{ [ t ] [ free-vars append ] }
} cond ;
diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor
index 42545500a5..664337c3d3 100755
--- a/extra/logging/logging.factor
+++ b/extra/logging/logging.factor
@@ -17,7 +17,7 @@ SYMBOL: CRITICAL
{ DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
: send-to-log-server ( array string -- )
- add* "log-server" get send ;
+ prefix "log-server" get send ;
SYMBOL: log-service
diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor
index d8429e7aaf..87536476ee 100644
--- a/extra/lsys/tortoise/graphics/graphics.factor
+++ b/extra/lsys/tortoise/graphics/graphics.factor
@@ -77,7 +77,7 @@ VAR: color-table
{ 0.25 0.25 0.25 } ! dark grey
{ 0.75 0.75 0.75 } ! medium grey
{ 1 1 1 } ! white
-} [ 1 add ] map >color-table ;
+} [ 1 suffix ] map >color-table ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor
index 99a098ca09..487d9828ea 100644
--- a/extra/math/combinatorics/combinatorics.factor
+++ b/extra/math/combinatorics/combinatorics.factor
@@ -18,7 +18,7 @@ IN: math.combinatorics
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ;
: (>permutation) ( seq n -- seq )
- [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ;
+ [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index ac62fb08f9..5ea19bc957 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -191,14 +191,14 @@ M: hook-combination generic-prologue
[ delete-at ] with-methods ;
: method>spec ( method -- spec )
- dup method-classes swap method-generic add* ;
+ dup method-classes swap method-generic prefix ;
: parse-method ( -- quot classes generic )
parse-definition dup 2 tail over second rot first ;
: METHOD:
location
- >r parse-method [ define-method ] 2keep add* r>
+ >r parse-method [ define-method ] 2keep prefix r>
remember-definition ; parsing
! For compatibility
diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor
index 01725ee9a9..fd9be4eb12 100644
--- a/extra/opengl/gl/extensions/extensions.factor
+++ b/extra/opengl/gl/extensions/extensions.factor
@@ -38,7 +38,7 @@ reset-gl-function-number-counter
gl-function-calling-convention
scan
scan dup
- scan drop "}" parse-tokens swap add*
+ scan drop "}" parse-tokens swap prefix
gl-function-number
[ gl-function-pointer ] 2curry swap
";" parse-tokens [ "()" subseq? not ] subset
diff --git a/extra/oracle/oracle.factor b/extra/oracle/oracle.factor
index d725de5994..a30ce64854 100644
--- a/extra/oracle/oracle.factor
+++ b/extra/oracle/oracle.factor
@@ -236,13 +236,13 @@ C: <connection> connection
: fetch-each ( object -- object )
fetch-statement [
- buf get alien>char-string res get swap add res set
+ buf get alien>char-string res get swap suffix res set
fetch-each
] [ ] if ;
: run-query ( object -- object )
execute-statement [
- buf get alien>char-string res get swap add res set
+ buf get alien>char-string res get swap suffix res set
fetch-each
] [ ] if ;
diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor
index d6aacf9645..d8fccfb8f9 100755
--- a/extra/parser-combinators/parser-combinators.factor
+++ b/extra/parser-combinators/parser-combinators.factor
@@ -132,7 +132,7 @@ TUPLE: and-parser parsers ;
: <&> ( parser1 parser2 -- parser )
over and-parser? [
- >r and-parser-parsers r> add
+ >r and-parser-parsers r> suffix
] [
2array
] if and-parser construct-boa ;
@@ -239,11 +239,11 @@ M: some-parser parse ( input parser -- result )
: <:&> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
- <&> [ first2 add ] <@ ;
+ <&> [ first2 suffix ] <@ ;
: <&:> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
- <&> [ first2 swap add* ] <@ ;
+ <&> [ first2 swap prefix ] <@ ;
: <:&:> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 68aab7d820..514a29781e 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -104,7 +104,7 @@ C: <head> peg-head
:: (setup-lr) ( r l s -- )
s head>> l head>> eq? [
l head>> s (>>head)
- l head>> [ s rule>> add ] change-involved-set drop
+ l head>> [ s rule>> suffix ] change-involved-set drop
r l s next>> (setup-lr)
] unless ;
@@ -136,7 +136,7 @@ C: <head> peg-head
h [ p heads get at ]
|
h [
- m r h involved-set>> h rule>> add member? not and [
+ m r h involved-set>> h rule>> suffix member? not and [
fail p <memo-entry>
] [
r h eval-set>> member? [
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index ffe3a4bca1..cf09277f31 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -76,10 +76,10 @@ PRIVATE>
dup first 2 tail* swap second 2 head = ;
: clean ( seq -- seq )
- [ unclip 1 head add* concat ] map [ all-unique? ] subset ;
+ [ unclip 1 head prefix concat ] map [ all-unique? ] subset ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 seq-diff first add* ;
+ dup natural-sort 10 seq-diff first prefix ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index 087b216b3a..5829f66c01 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -72,7 +72,7 @@ PRIVATE>
: max-path ( triangle -- n )
dup length 1 > [
- 2 cut* first2 max-children [ + ] 2map add max-path
+ 2 cut* first2 max-children [ + ] 2map suffix max-path
] [
first first
] if ;
@@ -95,7 +95,7 @@ PRIVATE>
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
: propagate-all ( triangle -- newtriangle )
- reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ;
+ reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap suffix ;
: sum-divisors ( n -- sum )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor
index b4eb4558fa..69e4c09b6e 100644
--- a/extra/qualified/qualified.factor
+++ b/extra/qualified/qualified.factor
@@ -4,7 +4,7 @@ IN: qualified
: define-qualified ( vocab-name -- )
dup require
- dup vocab-words swap CHAR: : add
+ dup vocab-words swap CHAR: : suffix
[ -rot >r append r> ] curry assoc-map
use get push ;
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index fa36a7c6f8..b0cd61bd8f 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -21,7 +21,7 @@ SYMBOL: ignore-case?
if 2curry ;
: or-predicates ( quots -- quot )
- [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
+ [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
: <@literal [ nip ] curry <@ ;
diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor
index 1f2bbde171..8c26d880f1 100644
--- a/extra/regexp2/regexp2.factor
+++ b/extra/regexp2/regexp2.factor
@@ -21,7 +21,7 @@ SYMBOL: ignore-case?
if 2curry ;
: or-predicates ( quots -- quot )
- [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
+ [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
: literal-action [ nip ] curry action ;
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 0b93552e76..d246b16b8d 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -94,7 +94,7 @@ MACRO: firstn ( n -- )
: monotonic-split ( seq quot -- newseq )
[
- >r dup unclip add r>
+ >r dup unclip suffix r>
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor
index 3a1af786e2..cd6e1a7cfb 100644
--- a/extra/springies/springies.factor
+++ b/extra/springies/springies.factor
@@ -235,7 +235,7 @@ C: <spring> spring
6 nrot 6 nrot 2array
5 nrot 5 nrot 2array
0 0 2array <node>
- nodes> swap add >nodes ;
+ nodes> swap suffix >nodes ;
: spng ( id id-a id-b k damp rest-length -- )
6 nrot drop
@@ -243,4 +243,4 @@ C: <spring> spring
5 nrot node-id
5 nrot node-id
<spring>
- springs> swap add >springs ;
+ springs> swap suffix >springs ;
diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor
index cd3cfc6324..489b7aaeb4 100755
--- a/extra/state-machine/state-machine.factor
+++ b/extra/state-machine/state-machine.factor
@@ -6,7 +6,7 @@ IN: state-machine
! STATES: set-name state1 state2 ... ;
";" parse-tokens
[ length ] keep
- unclip add
+ unclip suffix
[ create-in swap 1quotation define ] 2each ; parsing
TUPLE: state place data ;
diff --git a/extra/tetris/board/board.factor b/extra/tetris/board/board.factor
index 13850f6bd7..93bbebf34f 100644
--- a/extra/tetris/board/board.factor
+++ b/extra/tetris/board/board.factor
@@ -37,7 +37,7 @@ TUPLE: board width height rows ;
: add-row ( board -- )
dup board-rows over board-width f <array>
- add* swap set-board-rows ;
+ prefix swap set-board-rows ;
: top-up-rows ( board -- )
dup board-height over board-rows length = [
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index b019326ed5..395c4ff924 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -46,7 +46,7 @@ IN: tools.deploy.backend
: staging-image-name ( profile -- name )
"staging."
- swap strip-word-names? [ "strip" add ] when
+ swap strip-word-names? [ "strip" suffix ] when
"-" join ".image" 3append temp-file ;
DEFER: ?make-staging-image
@@ -75,7 +75,7 @@ DEFER: ?make-staging-image
] { } make ;
: run-factor ( vm flags -- )
- swap add* dup . run-with-output ; inline
+ swap prefix dup . run-with-output ; inline
: make-staging-image ( profile -- )
vm swap staging-command-line run-factor ;
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index d7610c21c8..2f941ad2ce 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -230,7 +230,7 @@ MEMO: all-vocabs-seq ( -- seq )
try-everything load-failures. ;
: unrooted-child-vocabs ( prefix -- seq )
- dup empty? [ CHAR: . add ] unless
+ dup empty? [ CHAR: . suffix ] unless
vocabs
[ find-vocab-root not ] subset
[
@@ -242,7 +242,7 @@ MEMO: all-vocabs-seq ( -- seq )
vocab-roots get [
dup pick (all-child-vocabs) [ >vocab-link ] map
] { } map>assoc
- swap unrooted-child-vocabs f swap 2array add ;
+ swap unrooted-child-vocabs f swap 2array suffix ;
: all-child-vocabs-seq ( prefix -- assoc )
vocab-roots get swap [
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index 2aed793a59..d548c0a4f5 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -49,10 +49,10 @@ DEFER: start-walker-thread
\ break t "break?" set-word-prop
: walk ( quot -- quot' )
- \ break add* [ break rethrow ] recover ;
+ \ break prefix [ break rethrow ] recover ;
: add-breakpoint ( quot -- quot' )
- dup [ break ] head? [ \ break add* ] unless ;
+ dup [ break ] head? [ \ break prefix ] unless ;
: (step-into-quot) ( quot -- ) add-breakpoint call ;
@@ -114,7 +114,7 @@ SYMBOL: +stopped+
] change-frame ;
: step-out-msg ( continuation -- continuation' )
- [ nip \ break add ] change-frame ;
+ [ nip \ break suffix ] change-frame ;
{
{ call [ (step-into-quot) ] }
diff --git a/extra/ui/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor
index 789d9b9e6a..ed524148e3 100644
--- a/extra/ui/commands/commands-docs.factor
+++ b/extra/ui/commands/commands-docs.factor
@@ -14,7 +14,7 @@ IN: ui.commands
: command-map. ( command-map -- )
[ command-map-row ] map
{ "Shortcut" "Command" "Word" "Notes" }
- [ \ $strong swap ] { } map>assoc add*
+ [ \ $strong swap ] { } map>assoc prefix
$table ;
: $command-map ( element -- )
diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor
index fce88c0ebb..533116824b 100755
--- a/extra/ui/gadgets/grid-lines/grid-lines.factor
+++ b/extra/ui/gadgets/grid-lines/grid-lines.factor
@@ -18,7 +18,7 @@ SYMBOL: grid-dim
grid-dim get spin set-axis ;
: draw-grid-lines ( gaps orientation -- )
- grid get rot grid-positions grid get rect-dim add [
+ grid get rot grid-positions grid get rect-dim suffix [
grid-line-from/to gl-line
] with each ;
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 52c5ca8a02..91b7f0f225 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -352,7 +352,7 @@ M: f sloppy-pick-up*
: sloppy-pick-up ( loc gadget -- path )
2dup sloppy-pick-up* dup
- [ [ wet-and-sloppy sloppy-pick-up ] keep add* ]
+ [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
[ 3drop { } ]
if ;
diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor
index fc8103b656..ba02f15c7a 100755
--- a/extra/unix/process/process.factor
+++ b/extra/unix/process/process.factor
@@ -9,7 +9,7 @@ IN: unix.process
! io.launcher instead.
: >argv ( seq -- alien )
- [ malloc-char-string ] map f add >c-void*-array ;
+ [ malloc-char-string ] map f suffix >c-void*-array ;
: exec ( pathname argv -- int )
[ malloc-char-string ] [ >argv ] bi* execv ;
diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor
index 28237a7b2c..8c74d61656 100755
--- a/extra/xmode/rules/rules.factor
+++ b/extra/xmode/rules/rules.factor
@@ -113,7 +113,7 @@ M: regexp text-hash-char drop f ;
: rule-chars* ( rule -- string )
dup rule-chars
swap rule-start matcher-text
- text-hash-char [ add ] when* ;
+ text-hash-char [ suffix ] when* ;
: add-rule ( rule ruleset -- )
>r dup rule-chars* >upper swap
From 9e96befa6981f39a27d120de93bab283d7468668 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 19:24:29 -0600
Subject: [PATCH 016/288] Remove add and add*
---
core/sequences/sequences.factor | 13 -------------
1 file changed, 13 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 26c1013c28..ca46066861 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -478,31 +478,18 @@ M: sequence <=>
: push-new ( elt seq -- ) [ delete ] 2keep push ;
-: add* ( seq elt -- newseq )
- over >r over length 1+ r> [
- [ 0 swap set-nth-unsafe ] keep
- [ 1 swap copy ] keep
- ] new-like ;
-
: prefix ( seq elt -- newseq )
over >r over length 1+ r> [
[ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep
] new-like ;
-: add ( seq elt -- newseq )
- over >r over length 1+ r> [
- [ >r over length r> set-nth-unsafe ] keep
- [ 0 swap copy ] keep
- ] new-like ;
-
: suffix ( seq elt -- newseq )
over >r over length 1+ r> [
[ >r over length r> set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
-
: seq-diff ( seq1 seq2 -- newseq )
swap [ member? not ] curry subset ;
From e75222d039076608fee57a25b5a7fefefdd1a5c5 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 19:24:48 -0600
Subject: [PATCH 017/288] More add and add* cleanups
---
core/math/intervals/intervals-tests.factor | 2 +-
core/prettyprint/prettyprint-tests.factor | 2 +-
core/quotations/quotations-tests.factor | 4 ++--
core/sequences/sequences-docs.factor | 16 ++++++++--------
extra/sequences/deep/deep-tests.factor | 2 +-
5 files changed, 13 insertions(+), 13 deletions(-)
diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor
index f6317e7475..5204d7d45a 100755
--- a/core/math/intervals/intervals-tests.factor
+++ b/core/math/intervals/intervals-tests.factor
@@ -188,7 +188,7 @@ IN: math.intervals.tests
{ max interval-max }
}
"math.ratios.private" vocab [
- { / interval/ } add
+ { / interval/ } suffix
] when
random ;
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index 35b30ac46f..27b63ec26f 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -192,7 +192,7 @@ unit-test
"IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )"
" parse-error-file"
- " [ <reversed> \"hello world foo\" add ] [ ] make ;"
+ " [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
} ;
[ t ] [
diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor
index a4c9a619b5..d311dfad71 100755
--- a/core/quotations/quotations-tests.factor
+++ b/core/quotations/quotations-tests.factor
@@ -10,8 +10,8 @@ IN: quotations.tests
] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 ] [ 3 4 ] append ] unit-test
-[ [ 1 2 3 ] ] [ [ 1 2 ] 3 add ] unit-test
-[ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test
+[ [ 1 2 3 ] ] [ [ 1 2 ] 3 suffix ] unit-test
+[ [ 3 1 2 ] ] [ [ 1 2 ] 3 prefix ] unit-test
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 9e8dcd6559..f5e5bfcdb3 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -61,8 +61,8 @@ ARTICLE: "sequences-access" "Accessing sequence elements"
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
-{ $subsection add }
-{ $subsection add* }
+{ $subsection prefix }
+{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
{ $subsection seq-diff } ;
@@ -641,22 +641,22 @@ HELP: push-new
}
{ $side-effects "seq" } ;
-{ push push-new add add* } related-words
+{ push push-new prefix suffix } related-words
-HELP: add
+HELP: suffix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
- { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" }
+ { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 suffix ." "{ 1 2 3 4 }" }
} ;
-HELP: add*
+HELP: prefix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
-{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" }
+{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
} ;
HELP: seq-diff
@@ -940,7 +940,7 @@ HELP: unclip
{ $values { "seq" sequence } { "rest" sequence } { "first" object } }
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." }
{ $examples
- { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip add ." "{ 2 3 1 }" }
+ { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip suffix ." "{ 2 3 1 }" }
} ;
HELP: unclip-slice
diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor
index 541570f3f9..9629d569cb 100755
--- a/extra/sequences/deep/deep-tests.factor
+++ b/extra/sequences/deep/deep-tests.factor
@@ -11,7 +11,7 @@ IN: sequences.deep.tests
[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test
: change-something ( seq -- newseq )
- dup array? [ "hi" add ] [ "hello" append ] if ;
+ dup array? [ "hi" suffix ] [ "hello" append ] if ;
[ { { "heyhello" "hihello" } "hihello" } ]
[ "hey" 1array 1array [ change-something ] deep-map ] unit-test
From 122fd50d4a7fee989bdcf69dc699d7bcf4246600 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 1 Apr 2008 14:49:20 +1300
Subject: [PATCH 018/288] Throw error when ebnf uses a non-existant
non-terminal
---
extra/peg/ebnf/ebnf.factor | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 26e5d68df8..a6567ce8f3 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -310,9 +310,14 @@ M: ebnf-var (transform) ( ast -- parser )
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> token sp ;
+: parser-not-found ( name -- * )
+ [
+ "Parser " % % " not found." %
+ ] "" make throw ;
+
M: ebnf-non-terminal (transform) ( ast -- parser )
symbol>> [
- , parser get , \ at , \ sp ,
+ , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ sp , \ nip ,
] [ ] make box ;
: transform-ebnf ( string -- object )
From cc5ddd8d78fcdb9b18b438002fe415738a12880b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 20:05:06 -0600
Subject: [PATCH 019/288] Resolve more add/add* items
---
core/bootstrap/image/image.factor | 2 +-
core/classes/tuple/tuple.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 5d49203554..fc963683b6 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -305,7 +305,7 @@ M: float-array ' float-array emit-dummy-array ;
! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array 1 tail-slice ]
- [ class transfer-word tuple-layout ] bi add* [ ' ] map
+ [ class transfer-word tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index de1e3bddb8..3cacef25a1 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -130,7 +130,7 @@ PRIVATE>
] with each ;
: all-slot-names ( class -- slots )
- superclasses [ slot-names ] map concat \ class add* ;
+ superclasses [ slot-names ] map concat \ class prefix ;
: compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ;
From c71a3e05c6a666ceba1353243b89c2d301c8cbd5 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 20:29:12 -0600
Subject: [PATCH 020/288] Fix add references
---
core/cpu/ppc/intrinsics/intrinsics.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 7aa78ce52e..07698eaa92 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics
} define-intrinsics
: fixnum-register-op ( op -- pair )
- [ "out" operand "y" operand "x" operand ] swap add H{
+ [ "out" operand "y" operand "x" operand ] swap suffix H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} 2array ;
: fixnum-value-op ( op -- pair )
- [ "out" operand "x" operand "y" operand ] swap add H{
+ [ "out" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
@@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: fixnum-register-jump ( op -- pair )
- [ "x" operand 0 "y" operand CMP ] swap add
+ [ "x" operand 0 "y" operand CMP ] swap suffix
{ { f "x" } { f "y" } } 2array ;
: fixnum-value-jump ( op -- pair )
- [ 0 "x" operand "y" operand CMPI ] swap add
+ [ 0 "x" operand "y" operand CMPI ] swap suffix
{ { f "x" } { [ small-tagged? ] "y" } } 2array ;
: define-fixnum-jump ( word op -- )
@@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: define-float-op ( word op -- )
- [ "z" operand "x" operand "y" operand ] swap add H{
+ [ "z" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +scratch+ { { float "z" } } }
{ +output+ { "z" } }
@@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics
] each
: define-float-jump ( word op -- )
- [ "x" operand 0 "y" operand FCMPU ] swap add
+ [ "x" operand 0 "y" operand FCMPU ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
From 6a2ab7393811e75e1b697a9180a3287f66bdf859 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 20:32:31 -0600
Subject: [PATCH 021/288] Fix more add/add* occurances
---
extra/cocoa/subclassing/subclassing.factor | 2 +-
extra/windows/com/syntax/syntax.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/cocoa/subclassing/subclassing.factor b/extra/cocoa/subclassing/subclassing.factor
index 42ddce1206..48f45f21c0 100755
--- a/extra/cocoa/subclassing/subclassing.factor
+++ b/extra/cocoa/subclassing/subclassing.factor
@@ -76,7 +76,7 @@ IN: cocoa.subclassing
r> <method-list> class_addMethods ;
: encode-types ( return types -- encoding )
- swap add* [
+ swap prefix [
alien>objc-types get at "0" append
] map concat ;
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 238ff18c39..acd3848f10 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -40,7 +40,7 @@ unless
: (parse-com-function) ( tokens -- definition )
[ second ]
[ first ]
- [ 3 tail 2 group [ first ] map "void*" add* ]
+ [ 3 tail 2 group [ first ] map "void*" prefix ]
tri
<com-function-definition> ;
From 38cb4f13b682f577bd30ef27c7e6daf6fee43c6b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 1 Apr 2008 01:40:12 -0500
Subject: [PATCH 022/288] Add 3cleave
---
core/combinators/combinators.factor | 8 +++++++-
core/inference/transforms/transforms.factor | 2 ++
2 files changed, 9 insertions(+), 1 deletion(-)
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index e19847dbd4..276e4cb184 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -12,11 +12,17 @@ hashtables sorting ;
[ [ keep ] curry ] map concat [ drop ] append ;
: 2cleave ( x seq -- )
- [ [ call ] 3keep drop ] each 2drop ;
+ [ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append ;
+: 3cleave ( x seq -- )
+ [ 3keep ] each 3drop ;
+
+: 3cleave>quot ( seq -- quot )
+ [ [ 3keep ] curry ] map concat [ 3drop ] append ;
+
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 200208c6a5..4d636c24f2 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -43,6 +43,8 @@ IN: inference.transforms
\ 2cleave [ 2cleave>quot ] 1 define-transform
+\ 3cleave [ 3cleave>quot ] 1 define-transform
+
\ spread [ spread>quot ] 1 define-transform
! Bitfields
From 2223633b432cd5f103fceefcf026d2b382e71f64 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 1 Apr 2008 01:40:30 -0500
Subject: [PATCH 023/288] Tweak
---
core/generic/standard/standard.factor | 4 +---
1 file changed, 1 insertion(+), 3 deletions(-)
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 4447c5a264..3898150c3b 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -39,9 +39,7 @@ ERROR: no-method object generic ;
] [ ] make ;
: class-predicates ( assoc -- assoc )
- [
- >r >r picker r> "predicate" word-prop append r>
- ] assoc-map ;
+ [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
: (simplify-alist) ( class i assoc -- default assoc )
2dup length 1- = [
From 7cb9be06e5c303d0c390a44e8e034b180bc93fcd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 16:46:22 -0500
Subject: [PATCH 024/288] redo singletons
---
extra/singleton/singleton-docs.factor | 12 ------------
extra/singleton/singleton-tests.factor | 5 ++++-
extra/singleton/singleton.factor | 15 +++++++++++----
3 files changed, 15 insertions(+), 17 deletions(-)
diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor
index 92ddcc494a..7acf97a436 100644
--- a/extra/singleton/singleton-docs.factor
+++ b/extra/singleton/singleton-docs.factor
@@ -12,15 +12,3 @@ HELP: SINGLETON:
} { $see-also
POSTPONE: PREDICATE:
} ;
-
-HELP: SINGLETONS:
-{ $syntax "SINGLETONS: classes... ;"
-} { $values
- { "classes" "new singletons to define" }
-} { $description
- "Defines a new singleton for each class in the list."
-} { $examples
- { $example "USE: singleton" "SINGLETONS: foo bar baz ;" "" }
-} { $see-also
- POSTPONE: SINGLETON:
-} ;
diff --git a/extra/singleton/singleton-tests.factor b/extra/singleton/singleton-tests.factor
index 1698181ed3..da2a74f8d1 100644
--- a/extra/singleton/singleton-tests.factor
+++ b/extra/singleton/singleton-tests.factor
@@ -1,4 +1,4 @@
-USING: kernel singleton tools.test ;
+USING: kernel singleton tools.test prettyprint io.streams.string ;
IN: singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
@@ -7,3 +7,6 @@ IN: singleton.tests
GENERIC: zammo ( obj -- )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
+[ ] [ SINGLETON: omg ] unit-test
+[ t ] [ omg singleton? ] unit-test
+[ "USING: singleton ;\nIN: singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor
index 9ec9f2f4a3..99319fdfdb 100755
--- a/extra/singleton/singleton.factor
+++ b/extra/singleton/singleton.factor
@@ -1,16 +1,23 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.predicate kernel namespaces parser quotations
-sequences words ;
+sequences words prettyprint prettyprint.backend prettyprint.sections
+compiler.units classes ;
+USE: tools.walker
IN: singleton
+PREDICATE: singleton < predicate-class
+ [ "predicate-definition" word-prop ]
+ [ [ eq? ] curry ] bi sequence= ;
+
: define-singleton ( token -- )
create-class-in
- \ word
+ dup save-location
+ \ singleton
over [ eq? ] curry define-predicate-class ;
: SINGLETON:
scan define-singleton ; parsing
-: SINGLETONS:
- ";" parse-tokens [ define-singleton ] each ; parsing
+M: singleton see-class* ( class -- )
+ <colon \ SINGLETON: pprint-word pprint-word ;
From 9e32613f5ca6933c1d1016f8ae0e555c7d1b8b61 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 16:51:48 -0500
Subject: [PATCH 025/288] rename singletons
---
extra/{ => classes}/singleton/authors.txt | 0
extra/{ => classes}/singleton/singleton-docs.factor | 2 +-
extra/{ => classes}/singleton/singleton-tests.factor | 4 ++--
extra/{ => classes}/singleton/singleton.factor | 3 +--
4 files changed, 4 insertions(+), 5 deletions(-)
rename extra/{ => classes}/singleton/authors.txt (100%)
rename extra/{ => classes}/singleton/singleton-docs.factor (96%)
rename extra/{ => classes}/singleton/singleton-tests.factor (70%)
rename extra/{ => classes}/singleton/singleton.factor (95%)
diff --git a/extra/singleton/authors.txt b/extra/classes/singleton/authors.txt
similarity index 100%
rename from extra/singleton/authors.txt
rename to extra/classes/singleton/authors.txt
diff --git a/extra/singleton/singleton-docs.factor b/extra/classes/singleton/singleton-docs.factor
similarity index 96%
rename from extra/singleton/singleton-docs.factor
rename to extra/classes/singleton/singleton-docs.factor
index 7acf97a436..95b5b6af18 100644
--- a/extra/singleton/singleton-docs.factor
+++ b/extra/classes/singleton/singleton-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel words ;
-IN: singleton
+IN: classes.singleton
HELP: SINGLETON:
{ $syntax "SINGLETON: class"
diff --git a/extra/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor
similarity index 70%
rename from extra/singleton/singleton-tests.factor
rename to extra/classes/singleton/singleton-tests.factor
index da2a74f8d1..453a2a0ea5 100644
--- a/extra/singleton/singleton-tests.factor
+++ b/extra/classes/singleton/singleton-tests.factor
@@ -1,5 +1,5 @@
USING: kernel singleton tools.test prettyprint io.streams.string ;
-IN: singleton.tests
+IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
@@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- )
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton? ] unit-test
-[ "USING: singleton ;\nIN: singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
+[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
diff --git a/extra/singleton/singleton.factor b/extra/classes/singleton/singleton.factor
similarity index 95%
rename from extra/singleton/singleton.factor
rename to extra/classes/singleton/singleton.factor
index 99319fdfdb..61a519679c 100755
--- a/extra/singleton/singleton.factor
+++ b/extra/classes/singleton/singleton.factor
@@ -3,8 +3,7 @@
USING: classes.predicate kernel namespaces parser quotations
sequences words prettyprint prettyprint.backend prettyprint.sections
compiler.units classes ;
-USE: tools.walker
-IN: singleton
+IN: classes.singleton
PREDICATE: singleton < predicate-class
[ "predicate-definition" word-prop ]
From b4adebb6910278f1ca140552510f5278abd7f25e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 16:53:32 -0500
Subject: [PATCH 026/288] update usages of singleton
---
extra/db/types/types.factor | 2 +-
extra/http/server/auth/providers/db/db.factor | 84 ++++++++---------
.../http/server/sessions/storage/db/db.factor | 92 +++++++++----------
3 files changed, 89 insertions(+), 89 deletions(-)
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 9babfbcdb0..98bc451a6f 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors classes.tuple combinators calendar.format symbols
-singleton ;
+classes.singleton ;
IN: db.types
HOOK: modifier-table db ( -- hash )
diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor
index 1e84e544b8..deab40e8d4 100755
--- a/extra/http/server/auth/providers/db/db.factor
+++ b/extra/http/server/auth/providers/db/db.factor
@@ -1,42 +1,42 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: db db.tuples db.types accessors
-http.server.auth.providers kernel continuations
-singleton ;
-IN: http.server.auth.providers.db
-
-user "USERS"
-{
- { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
- { "realname" "REALNAME" { VARCHAR 256 } }
- { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
- { "email" "EMAIL" { VARCHAR 256 } }
- { "ticket" "TICKET" { VARCHAR 256 } }
- { "profile" "PROFILE" FACTOR-BLOB }
-} define-persistent
-
-: init-users-table user ensure-table ;
-
-SINGLETON: users-in-db
-
-: find-user ( username -- user )
- <user>
- swap >>username
- select-tuple ;
-
-M: users-in-db get-user
- drop
- find-user ;
-
-M: users-in-db new-user
- drop
- [
- dup username>> find-user [
- drop f
- ] [
- dup insert-tuple
- ] if
- ] with-transaction ;
-
-M: users-in-db update-user
- drop update-tuple ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.tuples db.types accessors
+http.server.auth.providers kernel continuations
+classes.singleton ;
+IN: http.server.auth.providers.db
+
+user "USERS"
+{
+ { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
+ { "realname" "REALNAME" { VARCHAR 256 } }
+ { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
+ { "email" "EMAIL" { VARCHAR 256 } }
+ { "ticket" "TICKET" { VARCHAR 256 } }
+ { "profile" "PROFILE" FACTOR-BLOB }
+} define-persistent
+
+: init-users-table user ensure-table ;
+
+SINGLETON: users-in-db
+
+: find-user ( username -- user )
+ <user>
+ swap >>username
+ select-tuple ;
+
+M: users-in-db get-user
+ drop
+ find-user ;
+
+M: users-in-db new-user
+ drop
+ [
+ dup username>> find-user [
+ drop f
+ ] [
+ dup insert-tuple
+ ] if
+ ] with-transaction ;
+
+M: users-in-db update-user
+ drop update-tuple ;
diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor
index 471b7fa6df..e573b22ba1 100755
--- a/extra/http/server/sessions/storage/db/db.factor
+++ b/extra/http/server/sessions/storage/db/db.factor
@@ -1,46 +1,46 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors http.server.sessions.storage
-alarms kernel http.server db.tuples db.types singleton
-math.parser ;
-IN: http.server.sessions.storage.db
-
-SINGLETON: sessions-in-db
-
-TUPLE: session id namespace ;
-
-session "SESSIONS"
-{
- { "id" "ID" INTEGER +native-id+ }
- { "namespace" "NAMESPACE" FACTOR-BLOB }
-} define-persistent
-
-: init-sessions-table session ensure-table ;
-
-: <session> ( id -- session )
- session construct-empty
- swap dup [ string>number ] when >>id ;
-
-M: sessions-in-db get-session ( id storage -- namespace/f )
- drop
- dup [
- <session>
- select-tuple dup [ namespace>> ] when
- ] when ;
-
-M: sessions-in-db update-session ( namespace id storage -- )
- drop
- <session>
- swap >>namespace
- update-tuple ;
-
-M: sessions-in-db delete-session ( id storage -- )
- drop
- <session>
- delete-tuple ;
-
-M: sessions-in-db new-session ( namespace storage -- id )
- drop
- f <session>
- swap >>namespace
- [ insert-tuple ] [ id>> number>string ] bi ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors http.server.sessions.storage
+alarms kernel http.server db.tuples db.types math.parser
+classes.singleton ;
+IN: http.server.sessions.storage.db
+
+SINGLETON: sessions-in-db
+
+TUPLE: session id namespace ;
+
+session "SESSIONS"
+{
+ { "id" "ID" INTEGER +native-id+ }
+ { "namespace" "NAMESPACE" FACTOR-BLOB }
+} define-persistent
+
+: init-sessions-table session ensure-table ;
+
+: <session> ( id -- session )
+ session construct-empty
+ swap dup [ string>number ] when >>id ;
+
+M: sessions-in-db get-session ( id storage -- namespace/f )
+ drop
+ dup [
+ <session>
+ select-tuple dup [ namespace>> ] when
+ ] when ;
+
+M: sessions-in-db update-session ( namespace id storage -- )
+ drop
+ <session>
+ swap >>namespace
+ update-tuple ;
+
+M: sessions-in-db delete-session ( id storage -- )
+ drop
+ <session>
+ delete-tuple ;
+
+M: sessions-in-db new-session ( namespace storage -- id )
+ drop
+ f <session>
+ swap >>namespace
+ [ insert-tuple ] [ id>> number>string ] bi ;
From 23768dd482037e93cc4764d3bbbfc9eb31e496a7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 17:06:36 -0500
Subject: [PATCH 027/288] remove singleton? from sequences.lib fix bootstrap
error
---
extra/math/polynomials/polynomials.factor | 2 +-
extra/math/text/english/english.factor | 2 +-
extra/random/unix/unix.factor | 2 +-
extra/sequences/lib/lib-tests.factor | 3 ---
extra/sequences/lib/lib.factor | 3 ---
5 files changed, 3 insertions(+), 9 deletions(-)
diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor
index d6ac71e629..0b0d3520ef 100644
--- a/extra/math/polynomials/polynomials.factor
+++ b/extra/math/polynomials/polynomials.factor
@@ -22,7 +22,7 @@ PRIVATE>
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
- dup singleton? [ [ zero? ] right-trim ] unless ;
+ dup length 1 = [ [ zero? ] right-trim ] unless ;
: 2ptrim ( p p -- p p ) [ ptrim ] bi@ ;
: p+ ( p p -- p ) pextend v+ ;
diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor
index b77ac725ab..cba8c28310 100755
--- a/extra/math/text/english/english.factor
+++ b/extra/math/text/english/english.factor
@@ -79,7 +79,7 @@ SYMBOL: and-needed?
] if ;
: recombine ( seq -- str )
- dup singleton? [
+ dup length 1 = [
first 3digits>text
] [
dup set-conjunction "" swap
diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor
index f3f55007f0..3be2697bdf 100644
--- a/extra/random/unix/unix.factor
+++ b/extra/random/unix/unix.factor
@@ -1,5 +1,5 @@
USING: alien.c-types io io.files io.nonblocking kernel
-namespaces random io.encodings.binary singleton init
+namespaces random io.encodings.binary init
accessors system ;
IN: random.unix
diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor
index 6e6a924382..99565e966c 100755
--- a/extra/sequences/lib/lib-tests.factor
+++ b/extra/sequences/lib/lib-tests.factor
@@ -46,9 +46,6 @@ IN: sequences.lib.tests
[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
-[ f ] [ { } singleton? ] unit-test
-[ t ] [ { "asdf" } singleton? ] unit-test
-[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test
[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
[ V{ } [ delete-random drop ] keep length ] must-fail
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index d246b16b8d..945ba1a3b7 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -98,9 +98,6 @@ MACRO: firstn ( n -- )
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
-: singleton? ( seq -- ? )
- length 1 = ;
-
: delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ;
From d1c9082cd426c3e96980fc94d2c37323fd73e4fb Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 16:22:14 -0600
Subject: [PATCH 028/288] combinators.cleave: Major insurgency assault
---
extra/combinators/cleave/cleave.factor | 19 ++++++++++++++++++-
1 file changed, 18 insertions(+), 1 deletion(-)
diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor
index d99fe7e1d2..8018adaaa4 100644
--- a/extra/combinators/cleave/cleave.factor
+++ b/extra/combinators/cleave/cleave.factor
@@ -1,5 +1,5 @@
-USING: kernel sequences macros combinators ;
+USING: kernel arrays sequences macros combinators ;
IN: combinators.cleave
@@ -21,6 +21,18 @@ MACRO: <2arr> ( seq -- )
[ >quots ] [ length ] bi
'[ , 2cleave , narray ] ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {1} ( x -- {x} ) 1array ; inline
+: {2} ( x y -- {x,y} ) 2array ; inline
+: {3} ( x y z -- {x,y,z} ) 3array ; inline
+
+: {n} narray ;
+
+: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline
+
+: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Spread into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -28,3 +40,8 @@ MACRO: <2arr> ( seq -- )
MACRO: <arr*> ( seq -- )
[ >quots ] [ length ] bi
'[ , spread , narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline
+: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline
From a80e95ac2d65de8b96edfdbb638a06551cfbdf2b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 18:02:39 -0500
Subject: [PATCH 029/288] fix using
---
extra/classes/singleton/singleton-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor
index 453a2a0ea5..08f4a77aad 100644
--- a/extra/classes/singleton/singleton-tests.factor
+++ b/extra/classes/singleton/singleton-tests.factor
@@ -1,4 +1,4 @@
-USING: kernel singleton tools.test prettyprint io.streams.string ;
+USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
From 5b65e02851207ae91bde1245562c79ade2eb10ed Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 17:48:49 -0600
Subject: [PATCH 030/288] Project for a new American stack effect
---
extra/newfx/newfx.factor | 50 ++++++++++++++++++++++++++++++++++++++++
1 file changed, 50 insertions(+)
create mode 100644 extra/newfx/newfx.factor
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
new file mode 100644
index 0000000000..a5db87ca37
--- /dev/null
+++ b/extra/newfx/newfx.factor
@@ -0,0 +1,50 @@
+
+USING: kernel sequences assocs qualified ;
+
+QUALIFIED: sequences
+
+IN: newfx
+
+! Now, we can see a new world coming into view.
+! A world in which there is the very real prospect of a new world order.
+!
+! - George Herbert Walker Bush
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nth-at ( seq i -- val ) swap nth ;
+: nth-of ( i seq -- val ) nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nth-is ( seq i val -- seq ) swap pick set-nth ;
+
+: is-nth ( seq val i -- seq ) pick set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: at-key ( tbl key -- val ) swap at ;
+: key-of ( key tbl -- val ) at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key-is ( tbl key val -- tbl ) swap pick set-at ;
+: is-key ( tbl val key -- tbl ) pick set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push ( seq obj -- seq ) over sequences:push ;
+: push-on ( obj seq -- seq ) tuck sequences:push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: member? ( seq obj -- ? ) swap sequences:member? ;
+: member-of? ( obj seq -- ? ) sequences:member? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete-at-key ( tbl key -- tbl ) over delete-at ;
+: delete-key-of ( key tbl -- tbl ) tuck delete-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
From 6b454eed36490c35cd928e8b5b932f4e3ba2dc6d Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 12:59:12 +1300
Subject: [PATCH 031/288] Various peg/ebnf fixes - Box parsers were broken when
involved in left recursion detection - ebnf no longer implicitly ignores
white space between terminates/non-terminals - ebnf now handles \t and \n in
grammars so productions to detect white space work - reset-delegates is now
reset-pegs
---
extra/peg/ebnf/ebnf-tests.factor | 53 ++++++++++++++++++++++++++++++--
extra/peg/ebnf/ebnf.factor | 13 +++++---
extra/peg/peg.factor | 24 +++++++++------
3 files changed, 74 insertions(+), 16 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 4f802c5207..84c492c55a 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -180,6 +180,55 @@ IN: peg.ebnf.tests
{ 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
] unit-test
+{ f } [
+ "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call
+] unit-test
+
+{ V{ "a" " " "b" } } [
+ "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "\t" "b" } } [
+ "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "\n" "b" } } [
+ "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" f "b" } } [
+ "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" " " "b" } } [
+ "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+
+{ V{ "a" "\t" "b" } } [
+ "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "\n" "b" } } [
+ "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [
+ "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [
+ "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [
+ "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+ "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call
+] unit-test
+
{ V{ V{ 49 } "+" V{ 49 } } } [
#! Test direct left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
@@ -200,7 +249,7 @@ IN: peg.ebnf.tests
EBNF: primary
Primary = PrimaryNoNewArray
-PrimaryNoNewArray = ClassInstanceCreationExpression
+PrimaryNoNewArray = ClassInstanceCreationExpression
| MethodInvocation
| FieldAccess
| ArrayAccess
@@ -211,7 +260,7 @@ MethodInvocation = Primary "." MethodName "(" ")"
| MethodName "(" ")"
FieldAccess = Primary "." Identifier
| "super" "." Identifier
-ArrayAccess = Primary "[" Expression "]"
+ArrayAccess = Primary "[" Expression "]"
| ExpressionName "[" Expression "]"
ClassOrInterfaceType = ClassName | InterfaceTypeName
ClassName = "C" | "D"
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index a6567ce8f3..a4e4fe387d 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -3,7 +3,7 @@
USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
- splitting accessors effects sequences.deep ;
+ splitting accessors effects sequences.deep peg.search ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@@ -308,7 +308,7 @@ M: ebnf-var (transform) ( ast -- parser )
dup vars get push [ dupd set ] curry action ;
M: ebnf-terminal (transform) ( ast -- parser )
- symbol>> token sp ;
+ symbol>> token ;
: parser-not-found ( name -- * )
[
@@ -317,7 +317,7 @@ M: ebnf-terminal (transform) ( ast -- parser )
M: ebnf-non-terminal (transform) ( ast -- parser )
symbol>> [
- , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ sp , \ nip ,
+ , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip ,
] [ ] make box ;
: transform-ebnf ( string -- object )
@@ -340,10 +340,13 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
parse-result-ast transform dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry [ with-scope ] curry ;
-: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
+: replace-escapes ( string -- string )
+ "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ;
+
+: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing
: EBNF:
CREATE-WORD dup
- ";EBNF" parse-multiline-string
+ ";EBNF" parse-multiline-string replace-escapes
ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 9e35c5b9be..ad821635d7 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -30,6 +30,14 @@ SYMBOL: fail
SYMBOL: lrstack
SYMBOL: heads
+: delegates ( -- cache )
+ \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
+
+: reset-pegs ( -- )
+ H{ } clone \ delegates set-global ;
+
+reset-pegs
+
TUPLE: memo-entry ans pos ;
C: <memo-entry> memo-entry
@@ -253,14 +261,6 @@ SYMBOL: id
1 id set-global 0
] if* ;
-: delegates ( -- cache )
- \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
-
-: reset-delegates ( -- )
- H{ } clone \ delegates set-global ;
-
-reset-delegates
-
: init-parser ( parser -- parser )
#! Set the delegate for the parser. Equivalent parsers
#! get a delegate with the same id.
@@ -590,7 +590,13 @@ PRIVATE>
#! not a cached one. This is because the same box,
#! compiled twice can have a different compiled word
#! due to running at compile time.
- box-parser construct-boa next-id f <parser> over set-delegate ;
+ #! Why the [ ] action at the end? Box parsers don't get
+ #! memoized during parsing due to all box parsers being
+ #! unique. This breaks left recursion detection during the
+ #! parse. The action adds an indirection with a parser type
+ #! that gets memoized and fixes this. Need to rethink how
+ #! to fix boxes so this isn't needed...
+ box-parser construct-boa next-id f <parser> over set-delegate [ ] action ;
: PEG:
(:) [
From ae623ff9249632872cc85c69ecf3ade2797a47d0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 19:00:20 -0500
Subject: [PATCH 032/288] normalize-pathname prepends unicode prefix,
(normalize-pathname) does not
---
core/io/backend/backend.factor | 2 +-
core/io/files/files-tests.factor | 6 -----
core/io/files/files.factor | 13 ++++++---
extra/editors/editors.factor | 2 +-
extra/io/unix/files/files-tests.factor | 6 +++++
extra/io/windows/launcher/launcher.factor | 2 +-
extra/io/windows/nt/files/files-tests.factor | 9 ++++---
extra/io/windows/nt/files/files.factor | 28 +++++---------------
8 files changed, 32 insertions(+), 36 deletions(-)
diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
index 6bcd448385..935b007dd5 100755
--- a/core/io/backend/backend.factor
+++ b/core/io/backend/backend.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs ;
+io.encodings.utf8 init assocs splitting ;
IN: io.backend
SYMBOL: io-backend
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index 9920d8d25c..b4a7d44433 100755
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -220,8 +220,6 @@ io.encodings.utf8 ;
[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
-[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
-[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
@@ -239,9 +237,6 @@ io.encodings.utf8 ;
[ "lib" ] [ "" "lib" append-path ] unit-test
[ "lib" ] [ "" "./lib" append-path ] unit-test
-[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
-[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
-
[ "foo/bar/." parent-directory ] must-fail
[ "foo/bar/./" parent-directory ] must-fail
[ "foo/bar/baz/.." parent-directory ] must-fail
@@ -263,5 +258,4 @@ io.encodings.utf8 ;
[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
[ t ] [ "resource:core" absolute-path? ] unit-test
-[ t ] [ "/foo" absolute-path? ] unit-test
[ f ] [ "" absolute-path? ] unit-test
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 099acb157e..d2142cc6f3 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -102,6 +102,7 @@ PRIVATE>
: windows-absolute-path? ( path -- path ? )
{
+ { [ dup "\\\\?\\" head? ] [ t ] }
{ [ dup length 2 < ] [ f ] }
{ [ dup second CHAR: : = ] [ t ] }
{ [ t ] [ f ] }
@@ -111,8 +112,8 @@ PRIVATE>
{
{ [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] }
- { [ dup first path-separator? ] [ t ] }
{ [ windows? ] [ windows-absolute-path? ] }
+ { [ dup first path-separator? ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
@@ -126,6 +127,9 @@ PRIVATE>
2 tail left-trim-separators
>r parent-directory r> append-path
] }
+ { [ over absolute-path? over first path-separator? and ] [
+ >r 2 head r> append
+ ] }
{ [ t ] [
>r right-trim-separators "/" r>
left-trim-separators 3append
@@ -296,14 +300,17 @@ DEFER: copy-tree-into
: temp-file ( name -- path )
temp-directory prepend-path ;
-M: object normalize-pathname ( path -- path' )
+: (normalize-pathname) ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
- normalize-pathname
+ (normalize-pathname)
] [
current-directory get prepend-path
] if ;
+M: object normalize-pathname ( path -- path' )
+ (normalize-pathname) ;
+
! Pathname presentations
TUPLE: pathname string ;
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index c442dfaa94..00e20de5b5 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -26,7 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
- >r normalize-pathname "\\\\?\\" ?head drop r>
+ >r (normalize-pathname) "\\\\?\\" ?head drop r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor
index bb2039adfb..a0310a1cac 100755
--- a/extra/io/unix/files/files-tests.factor
+++ b/extra/io/unix/files/files-tests.factor
@@ -21,3 +21,9 @@ IN: io.unix.files.tests
[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
+
+{ [ "/lib" ] [ "/usr/" "/lib" append-path ] }
+{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] }
+{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] }
+{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] }
+{ [ t ] [ "/foo" absolute-path? ] }
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 31247e43c3..f3226bfbf0 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles
0 >>dwCreateFlags
- current-directory get normalize-pathname >>lpCurrentDirectory ;
+ current-directory get (normalize-pathname) >>lpCurrentDirectory ;
: call-CreateProcess ( CreateProcess-args -- )
{
diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor
index 73d6a0bf7f..431aced65d 100644
--- a/extra/io/windows/nt/files/files-tests.factor
+++ b/extra/io/windows/nt/files/files-tests.factor
@@ -1,9 +1,9 @@
USING: io.files kernel tools.test io.backend
-io.windows.nt.files splitting ;
+io.windows.nt.files splitting sequences ;
IN: io.windows.nt.files.tests
-[ t ] [ "\\foo" absolute-path? ] unit-test
-[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test
+[ f ] [ "\\foo" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
[ t ] [ "c:\\foo" absolute-path? ] unit-test
[ t ] [ "c:" absolute-path? ] unit-test
@@ -45,3 +45,6 @@ IN: io.windows.nt.files.tests
"C:\\builds\\factor\\12345\\"
"..\\.." append-path normalize-pathname
] unit-test
+
+[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
+[ t ] [ "" resource-path 2 tail exists? ] unit-test
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 81112a89c0..bc676b8d0a 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -36,28 +36,14 @@ ERROR: not-absolute-path ;
} && [ 2 head ] [ not-absolute-path ] if ;
: prepend-prefix ( string -- string' )
- unicode-prefix prepend ;
+ dup unicode-prefix head? [
+ unicode-prefix prepend
+ ] unless ;
-ERROR: nonstring-pathname ;
-ERROR: empty-pathname ;
-
-M: windows-nt-io normalize-pathname ( string -- string )
- "resource:" ?head [
- left-trim-separators resource-path
- normalize-pathname
- ] [
- dup empty? [ empty-pathname ] when
- current-directory get prepend-path
- dup unicode-prefix head? [
- dup first path-separator? [
- left-trim-separators
- current-directory get 2 head
- prepend-path
- ] when
- unicode-prefix prepend
- ] unless
- { { CHAR: / CHAR: \\ } } substitute ! necessary
- ] if ;
+M: windows-nt-io normalize-pathname ( string -- string' )
+ (normalize-pathname)
+ { { CHAR: / CHAR: \\ } } substitute
+ prepend-prefix ;
M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
From 5ecb754cc863eca4f52e2d8a19edb20c78a8b85f Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 18:18:18 -0600
Subject: [PATCH 033/288] newfx: mutators
---
extra/newfx/newfx.factor | 22 ++++++++++++++++++++--
1 file changed, 20 insertions(+), 2 deletions(-)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index a5db87ca37..53cda66dfc 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -17,9 +17,16 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-is ( seq i val -- seq ) swap pick set-nth ;
+: nth-is ( seq i val -- seq ) swap pick set-nth ;
+: is-nth ( seq val i -- seq ) pick set-nth ;
-: is-nth ( seq val i -- seq ) pick set-nth ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mutate-nth ( seq i val -- ) swap rot set-nth ;
+: mutate-at-nth ( seq val i -- ) rot set-nth ;
+
+: mutate-nth-of ( i val seq -- ) swapd set-nth ;
+: mutate-at-nth-of ( val i seq -- ) set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -33,6 +40,14 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: mutate-key ( tbl key val -- ) swap rot set-at ;
+: mutate-at-key ( tbl val key -- ) rot set-at ;
+
+: mutate-key-of ( key val tbl -- ) swapd set-at ;
+: mutate-at-key-of ( val key tbl -- ) set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: push ( seq obj -- seq ) over sequences:push ;
: push-on ( obj seq -- seq ) tuck sequences:push ;
@@ -48,3 +63,6 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! A note about the 'mutate' qualifier. Other words also technically mutate
+! their primary object. However, the 'mutate' qualifier is supposed to
+! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
From 1b58ba404ec22cef9d8713369c6aa4fa47387864 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 13:50:29 +1300
Subject: [PATCH 034/288] Fix peg.pl0 test failures
---
extra/peg/pl0/pl0-tests.factor | 47 +++++++++++++++++++++++++++++++++-
extra/peg/pl0/pl0.factor | 26 ++++++++++---------
2 files changed, 60 insertions(+), 13 deletions(-)
diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor
index b3d2135da7..1ed528d05d 100644
--- a/extra/peg/pl0/pl0-tests.factor
+++ b/extra/peg/pl0/pl0-tests.factor
@@ -1,9 +1,54 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.pl0 multiline sequences ;
+USING: kernel tools.test peg peg.pl0 multiline sequences words assocs ;
IN: peg.pl0.tests
+{ f } [
+ "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
+{ f } [
+ "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
+{ f } [
+ "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
+{ f } [
+ "foo := 5;" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "BEGIN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "IF 1=1 THEN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "WHILE 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "WHILE ODD 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "PROCEDURE square; BEGIN squ=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
+{ f } [
+ <"
+PROCEDURE square;
+BEGIN
+ squ := x * x
+END;
+"> \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
{ t } [
<"
VAR x, squ;
diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor
index f7eb3cad23..8025728285 100644
--- a/extra/peg/pl0/pl0.factor
+++ b/extra/peg/pl0/pl0.factor
@@ -7,18 +7,20 @@ IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
EBNF: pl0
-block = ( "CONST" ident "=" number ( "," ident "=" number )* ";" )?
- ( "VAR" ident ( "," ident )* ";" )?
- ( "PROCEDURE" ident ";" ( block ";" )? )* statement
-statement = ( ident ":=" expression | "CALL" ident |
- "BEGIN" statement (";" statement )* "END" |
- "IF" condition "THEN" statement |
- "WHILE" condition "DO" statement )?
-condition = "ODD" expression |
- expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression
-expression = ("+" | "-")? term (("+" | "-") term )*
-term = factor (("*" | "/") factor )*
-factor = ident | number | "(" expression ")"
+- = (" " | "\t" | "\n")+ => [[ drop ignore ]]
+_ = (" " | "\t" | "\n")* => [[ drop ignore ]]
+block = ( _ "CONST" - ident _ "=" _ number ( _ "," _ ident _ "=" _ number )* _ ";" )?
+ ( _ "VAR" - ident ( _ "," _ ident )* _ ";" )?
+ ( _ "PROCEDURE" - ident _ ";" ( _ block _ ";" )? )* _ statement
+statement = ( ident _ ":=" _ expression | "CALL" - ident |
+ "BEGIN" - statement ( _ ";" _ statement )* _ "END" |
+ "IF" - condition _ "THEN" - statement |
+ "WHILE" - condition _ "DO" - statement )?
+condition = "ODD" - expression |
+ expression _ ("=" | "#" | "<=" | "<" | ">=" | ">") _ expression
+expression = ("+" | "-")? term ( _ ("+" | "-") _ term )*
+term = factor ( _ ("*" | "/") _ factor )*
+factor = ident | number | "(" _ expression _ ")"
ident = (([a-zA-Z])+) [[ >string ]]
digit = ([0-9]) [[ digit> ]]
number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
From 2bad7228a7df0496b240c2b4b5f7483b06b0d10e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 19:51:49 -0500
Subject: [PATCH 035/288] rename normalize-pathname to normalize-path fix
windows launcher issue
---
core/io/backend/backend-tests.factor | 8 ++--
core/io/backend/backend.factor | 4 +-
core/io/files/files-docs.factor | 2 +-
core/io/files/files.factor | 45 ++++++++++----------
extra/cairo/png/png.factor | 2 +-
extra/editors/editors.factor | 2 +-
extra/io/sockets/sockets.factor | 2 +-
extra/io/unix/files/files.factor | 20 ++++-----
extra/io/unix/launcher/launcher.factor | 2 +-
extra/io/windows/ce/files/files.factor | 2 +-
extra/io/windows/files/files.factor | 8 ++--
extra/io/windows/launcher/launcher.factor | 2 +-
extra/io/windows/nt/files/files-tests.factor | 8 ++--
extra/io/windows/nt/files/files.factor | 4 +-
extra/io/windows/nt/launcher/launcher.factor | 2 +-
extra/io/windows/windows.factor | 12 +++---
16 files changed, 63 insertions(+), 62 deletions(-)
mode change 100644 => 100755 core/io/backend/backend-tests.factor
mode change 100644 => 100755 extra/io/windows/nt/files/files-tests.factor
diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor
old mode 100644
new mode 100755
index 04f34068eb..c3d7e8e89b
--- a/core/io/backend/backend-tests.factor
+++ b/core/io/backend/backend-tests.factor
@@ -1,4 +1,4 @@
-IN: io.backend.tests
-USING: tools.test io.backend kernel ;
-
-[ ] [ "a" normalize-pathname drop ] unit-test
+IN: io.backend.tests
+USING: tools.test io.backend kernel ;
+
+[ ] [ "a" normalize-path drop ] unit-test
diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
index 935b007dd5..44b1eea349 100755
--- a/core/io/backend/backend.factor
+++ b/core/io/backend/backend.factor
@@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- )
HOOK: normalize-directory io-backend ( str -- newstr )
-HOOK: normalize-pathname io-backend ( str -- newstr )
+HOOK: normalize-path io-backend ( str -- newstr )
-M: object normalize-directory normalize-pathname ;
+M: object normalize-directory normalize-path ;
: set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index 1953569223..342967acfc 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -252,7 +252,7 @@ HELP: normalize-directory
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
-HELP: normalize-pathname
+HELP: normalize-path
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index d2142cc6f3..720894d489 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream )
HOOK: (file-appender) io-backend ( path -- stream )
: <file-reader> ( path encoding -- stream )
- swap normalize-pathname (file-reader) swap <decoder> ;
+ swap normalize-path (file-reader) swap <decoder> ;
: <file-writer> ( path encoding -- stream )
- swap normalize-pathname (file-writer) swap <encoder> ;
+ swap normalize-path (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream )
- swap normalize-pathname (file-appender) swap <encoder> ;
+ swap normalize-path (file-appender) swap <encoder> ;
: file-lines ( path encoding -- seq )
<file-reader> lines ;
@@ -171,7 +171,7 @@ SYMBOL: +unknown+
! File metadata
: exists? ( path -- ? )
- normalize-pathname (exists?) ;
+ normalize-path (exists?) ;
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
@@ -187,18 +187,33 @@ M: object cwd ( -- path ) "." ;
[ cwd current-directory set-global ] "io.files" add-init-hook
+: resource-path ( path -- newpath )
+ "resource-path" get [ image parent-directory ] unless*
+ prepend-path ;
+
+: (normalize-path) ( path -- path' )
+ "resource:" ?head [
+ left-trim-separators resource-path
+ (normalize-path)
+ ] [
+ current-directory get prepend-path
+ ] if ;
+
+M: object normalize-path ( path -- path' )
+ (normalize-path) ;
+
: with-directory ( path quot -- )
- >r normalize-pathname r>
+ >r (normalize-path) r>
current-directory swap with-variable ; inline
: set-current-directory ( path -- )
- normalize-pathname current-directory set ;
+ normalize-path current-directory set ;
! Creating directories
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
- normalize-pathname right-trim-separators {
+ normalize-path right-trim-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
@@ -271,7 +286,7 @@ M: object copy-file
DEFER: copy-tree-into
: copy-tree ( from to -- )
- normalize-pathname
+ normalize-path
over link-info type>>
{
{ +symbolic-link+ [ copy-link ] }
@@ -290,9 +305,6 @@ DEFER: copy-tree-into
[ copy-tree-into ] curry each ;
! Special paths
-: resource-path ( path -- newpath )
- "resource-path" get [ image parent-directory ] unless*
- prepend-path ;
: temp-directory ( -- path )
"temp" resource-path dup make-directories ;
@@ -300,17 +312,6 @@ DEFER: copy-tree-into
: temp-file ( name -- path )
temp-directory prepend-path ;
-: (normalize-pathname) ( path -- path' )
- "resource:" ?head [
- left-trim-separators resource-path
- (normalize-pathname)
- ] [
- current-directory get prepend-path
- ] if ;
-
-M: object normalize-pathname ( path -- path' )
- (normalize-pathname) ;
-
! Pathname presentations
TUPLE: pathname string ;
diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor
index 774a1afe8e..f9908e4581 100755
--- a/extra/cairo/png/png.factor
+++ b/extra/cairo/png/png.factor
@@ -24,7 +24,7 @@ ERROR: cairo-error string ;
} cond ;
: <png> ( path -- png )
- normalize-pathname
+ normalize-path
cairo_image_surface_create_from_png
dup cairo_surface_status cairo-png-error
dup [ cairo_image_surface_get_width check-zero ]
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index 00e20de5b5..e871d5f808 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -26,7 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
- >r (normalize-pathname) "\\\\?\\" ?head drop r>
+ >r (normalize-path) "\\\\?\\" ?head drop r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor
index e1cc36cd2e..17799227b8 100755
--- a/extra/io/sockets/sockets.factor
+++ b/extra/io/sockets/sockets.factor
@@ -7,7 +7,7 @@ IN: io.sockets
TUPLE: local path ;
: <local> ( path -- addrspec )
- normalize-pathname local construct-boa ;
+ normalize-path local construct-boa ;
TUPLE: inet4 host port ;
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index c4e506d37f..7d0e7c4330 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -43,22 +43,22 @@ M: unix-io (file-appender) ( path -- stream )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
M: unix-io touch-file ( path -- )
- normalize-pathname
+ normalize-path
touch-mode file-mode open
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
close ;
M: unix-io move-file ( from to -- )
- [ normalize-pathname ] bi@ rename io-error ;
+ [ normalize-path ] bi@ rename io-error ;
M: unix-io delete-file ( path -- )
- normalize-pathname unlink io-error ;
+ normalize-path unlink io-error ;
M: unix-io make-directory ( path -- )
- normalize-pathname OCT: 777 mkdir io-error ;
+ normalize-path OCT: 777 mkdir io-error ;
M: unix-io delete-directory ( path -- )
- normalize-pathname rmdir io-error ;
+ normalize-path rmdir io-error ;
: (copy-file) ( from to -- )
dup parent-directory make-directories
@@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal ;
M: unix-io copy-file ( from to -- )
- [ normalize-pathname ] bi@
+ [ normalize-path ] bi@
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
2bi ;
@@ -96,15 +96,15 @@ M: unix-io copy-file ( from to -- )
\ file-info construct-boa ;
M: unix-io file-info ( path -- info )
- normalize-pathname stat* stat>file-info ;
+ normalize-path stat* stat>file-info ;
M: unix-io link-info ( path -- info )
- normalize-pathname lstat* stat>file-info ;
+ normalize-path lstat* stat>file-info ;
M: unix-io make-link ( path1 path2 -- )
- normalize-pathname symlink io-error ;
+ normalize-path symlink io-error ;
M: unix-io read-link ( path -- path' )
- normalize-pathname
+ normalize-path
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ;
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index f738bd42c2..4986024e78 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -37,7 +37,7 @@ USE: unix
2nip reset-fd ;
: redirect-file ( obj mode fd -- )
- >r >r normalize-pathname r> file-mode
+ >r >r normalize-path r> file-mode
open dup io-error r> redirect-fd ;
: redirect-closed ( obj mode fd -- )
diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor
index c4f5b2ef9e..1e5cedae57 100755
--- a/extra/io/windows/ce/files/files.factor
+++ b/extra/io/windows/ce/files/files.factor
@@ -4,7 +4,7 @@ prettyprint sequences strings threads threads.private
windows windows.kernel32 io.windows.ce.backend ;
IN: windows.ce.files
-! M: windows-ce-io normalize-pathname ( string -- string )
+! M: windows-ce-io normalize-path ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 295b3ab006..a23a78b3da 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -89,14 +89,14 @@ SYMBOLS: +read-only+ +hidden+ +system+
] if ;
M: windows-nt-io file-info ( path -- info )
- normalize-pathname get-file-information-stat ;
+ normalize-path get-file-information-stat ;
M: windows-nt-io link-info ( path -- info )
file-info ;
: file-times ( path -- timestamp timestamp timestamp )
[
- normalize-pathname open-existing dup close-always
+ normalize-path open-existing dup close-always
"FILETIME" <c-object>
"FILETIME" <c-object>
"FILETIME" <c-object>
@@ -112,7 +112,7 @@ M: windows-nt-io link-info ( path -- info )
#! timestamp order: creation access write
[
>r >r >r
- normalize-pathname open-existing dup close-always
+ normalize-path open-existing dup close-always
r> r> r> (set-file-times)
] with-destructors ;
@@ -127,7 +127,7 @@ M: windows-nt-io link-info ( path -- info )
M: windows-nt-io touch-file ( path -- )
[
- normalize-pathname
+ normalize-path
maybe-create-file over close-always
[ drop ] [ f now dup (set-file-times) ] if
] with-destructors ;
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index f3226bfbf0..579745710e 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles
0 >>dwCreateFlags
- current-directory get (normalize-pathname) >>lpCurrentDirectory ;
+ current-directory get (normalize-path) >>lpCurrentDirectory ;
: call-CreateProcess ( CreateProcess-args -- )
{
diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor
old mode 100644
new mode 100755
index 431aced65d..1e6268fbc0
--- a/extra/io/windows/nt/files/files-tests.factor
+++ b/extra/io/windows/nt/files/files-tests.factor
@@ -29,21 +29,21 @@ IN: io.windows.nt.files.tests
[ ] [ "" resource-path cd ] unit-test
-[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test
+[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
"C:\\builds\\factor\\12345\\"
- "..\\log.txt" append-path normalize-pathname
+ "..\\log.txt" append-path normalize-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
- "..\\.." append-path normalize-pathname
+ "..\\.." append-path normalize-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
- "..\\.." append-path normalize-pathname
+ "..\\.." append-path normalize-path
] unit-test
[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index bc676b8d0a..91ad0139b2 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -40,8 +40,8 @@ ERROR: not-absolute-path ;
unicode-prefix prepend
] unless ;
-M: windows-nt-io normalize-pathname ( string -- string' )
- (normalize-pathname)
+M: windows-nt-io normalize-path ( string -- string' )
+ (normalize-path)
{ { CHAR: / CHAR: \\ } } substitute
prepend-prefix ;
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index c342b2ee9a..895890e898 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -32,7 +32,7 @@ IN: io.windows.nt.launcher
drop 2nip null-pipe ;
:: redirect-file ( default path access-mode create-mode -- handle )
- path normalize-pathname
+ path normalize-path
access-mode
share-mode
security-attributes-inherit
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 27917cedfa..45c1adaf50 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -25,7 +25,7 @@ HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
M: windows-io normalize-directory ( string -- string )
- normalize-pathname "\\" ?tail drop "\\*" append ;
+ normalize-path "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
{
@@ -135,21 +135,21 @@ M: windows-io (file-appender) ( path -- stream )
open-append <win32-file> <writer> ;
M: windows-io move-file ( from to -- )
- [ normalize-pathname ] bi@ MoveFile win32-error=0/f ;
+ [ normalize-path ] bi@ MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- )
- normalize-pathname DeleteFile win32-error=0/f ;
+ normalize-path DeleteFile win32-error=0/f ;
M: windows-io copy-file ( from to -- )
dup parent-directory make-directories
- [ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ;
+ [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
M: windows-io make-directory ( path -- )
- normalize-pathname
+ normalize-path
f CreateDirectory win32-error=0/f ;
M: windows-io delete-directory ( path -- )
- normalize-pathname
+ normalize-path
RemoveDirectory win32-error=0/f ;
HOOK: WSASocket-flags io-backend ( -- DWORD )
From 8047115746ada0a5577e8e045140a8424441005b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 18:52:40 -0600
Subject: [PATCH 036/288] remove extra/new-effects
---
extra/new-effects/new-effects.factor | 17 -----------------
1 file changed, 17 deletions(-)
delete mode 100644 extra/new-effects/new-effects.factor
diff --git a/extra/new-effects/new-effects.factor b/extra/new-effects/new-effects.factor
deleted file mode 100644
index f073ccadd3..0000000000
--- a/extra/new-effects/new-effects.factor
+++ /dev/null
@@ -1,17 +0,0 @@
-USING: assocs kernel sequences ;
-IN: new-effects
-
-: new-nth ( seq n -- elt )
- swap nth ; inline
-
-: new-set-nth ( seq obj n -- seq )
- pick set-nth ; inline
-
-: new-at ( assoc key -- elt )
- swap at ; inline
-
-: new-at* ( assoc key -- elt ? )
- swap at* ; inline
-
-: new-set-at ( assoc value key -- assoc )
- pick set-at ; inline
From a94e5245a3b35d6062990729e16b8bf13d2a4cdd Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Tue, 1 Apr 2008 20:07:18 -0500
Subject: [PATCH 037/288] fix teh tests FOR GREAT JUSTICE
---
extra/io/unix/files/files-tests.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor
index a0310a1cac..040b191d27 100755
--- a/extra/io/unix/files/files-tests.factor
+++ b/extra/io/unix/files/files-tests.factor
@@ -22,8 +22,8 @@ IN: io.unix.files.tests
[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
-{ [ "/lib" ] [ "/usr/" "/lib" append-path ] }
-{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] }
-{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] }
-{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] }
-{ [ t ] [ "/foo" absolute-path? ] }
+[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
+[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
+[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
+[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
+[ t ] [ "/foo" absolute-path? ] unit-test
From 6ac0d4692fee4a81fef062a9738f1030abee6ae6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 20:20:13 -0500
Subject: [PATCH 038/288] remove wrap word, add circular to mersenne twister
---
extra/random/mersenne-twister/mersenne-twister.factor | 10 ++++------
1 file changed, 4 insertions(+), 6 deletions(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index 8ddbdac6f4..77054ea377 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -4,7 +4,7 @@
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
-accessors math.ranges random ;
+accessors math.ranges random circular ;
IN: random.mersenne-twister
<PRIVATE
@@ -16,8 +16,6 @@ TUPLE: mersenne-twister seq i ;
: mt-a HEX: 9908b0df ; inline
: mt-hi HEX: 80000000 bitand ; inline
: mt-lo HEX: 7fffffff bitand ; inline
-: wrap ( x n -- y ) 2dup >= [ - ] [ drop ] if ; inline
-: mt-wrap ( x -- y ) mt-n wrap ; inline
: set-generated ( y from-elt to seq -- )
>r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
@@ -27,8 +25,8 @@ TUPLE: mersenne-twister seq i ;
tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline
: (mt-generate) ( n mt-seq -- y to from-elt )
- [ >r dup 1+ mt-wrap r> calculate-y ]
- [ >r mt-m + mt-wrap r> nth ]
+ [ >r dup 1+ r> calculate-y ]
+ [ >r mt-m + r> nth ]
[ drop ] 2tri ;
: mt-generate ( mt -- )
@@ -36,7 +34,7 @@ TUPLE: mersenne-twister seq i ;
[ 0 >>i drop ] bi ;
: init-mt-first ( seed -- seq )
- >r mt-n 0 <array> r>
+ >r mt-n 0 <array> <circular> r>
HEX: ffffffff bitand 0 pick set-nth ;
: init-mt-formula ( seq i -- f(seq[i]) )
From bbcc84862f5e2ee038011886b330c3c655e754d4 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 15:47:21 +1300
Subject: [PATCH 039/288] Tweak ast from sequences in ebnf
---
extra/peg/ebnf/ebnf.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index a4e4fe387d..7c5854cd7d 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -252,7 +252,7 @@ M: ebnf-rule (transform) ( ast -- parser )
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
- elements>> [ (transform) ] map seq ;
+ elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ;
M: ebnf-choice (transform) ( ast -- parser )
options>> [ (transform) ] map choice ;
From 34a1505d95891fd516e4f5b176d937fe4641dd8a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 15:47:30 +1300
Subject: [PATCH 040/288] PL0 whitespace handling improvement
---
extra/peg/pl0/pl0-tests.factor | 36 +++++++++----------
extra/peg/pl0/pl0.factor | 64 +++++++++++++++++++++++++---------
2 files changed, 65 insertions(+), 35 deletions(-)
diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor
index 1ed528d05d..039f66637d 100644
--- a/extra/peg/pl0/pl0-tests.factor
+++ b/extra/peg/pl0/pl0-tests.factor
@@ -4,40 +4,40 @@
USING: kernel tools.test peg peg.pl0 multiline sequences words assocs ;
IN: peg.pl0.tests
-{ f } [
- "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+{ t } [
+ "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+{ t } [
+ "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+{ t } [
+ "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "foo := 5;" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "BEGIN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "BEGIN foo := 5 END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "IF 1=1 THEN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "IF 1=1 THEN foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "WHILE 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "WHILE 1=1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "WHILE ODD 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "WHILE ODD 1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "PROCEDURE square; BEGIN squ=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+{ t } [
+ "PROCEDURE square; BEGIN squ:=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
] unit-test
{ f } [
diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor
index 8025728285..1b97814ca7 100644
--- a/extra/peg/pl0/pl0.factor
+++ b/extra/peg/pl0/pl0.factor
@@ -7,22 +7,52 @@ IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
EBNF: pl0
-- = (" " | "\t" | "\n")+ => [[ drop ignore ]]
_ = (" " | "\t" | "\n")* => [[ drop ignore ]]
-block = ( _ "CONST" - ident _ "=" _ number ( _ "," _ ident _ "=" _ number )* _ ";" )?
- ( _ "VAR" - ident ( _ "," _ ident )* _ ";" )?
- ( _ "PROCEDURE" - ident _ ";" ( _ block _ ";" )? )* _ statement
-statement = ( ident _ ":=" _ expression | "CALL" - ident |
- "BEGIN" - statement ( _ ";" _ statement )* _ "END" |
- "IF" - condition _ "THEN" - statement |
- "WHILE" - condition _ "DO" - statement )?
-condition = "ODD" - expression |
- expression _ ("=" | "#" | "<=" | "<" | ">=" | ">") _ expression
-expression = ("+" | "-")? term ( _ ("+" | "-") _ term )*
-term = factor ( _ ("*" | "/") _ factor )*
-factor = ident | number | "(" _ expression _ ")"
-ident = (([a-zA-Z])+) [[ >string ]]
-digit = ([0-9]) [[ digit> ]]
-number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
-program = block "."
+
+BEGIN = "BEGIN" _
+CALL = "CALL" _
+CONST = "CONST" _
+DO = "DO" _
+END = "END" _
+IF = "IF" _
+THEN = "THEN" _
+ODD = "ODD" _
+PROCEDURE = "PROCEDURE" _
+VAR = "VAR" _
+WHILE = "WHILE" _
+EQ = "=" _
+LTEQ = "<=" _
+LT = "<" _
+GT = ">" _
+GTEQ = ">=" _
+NEQ = "#" _
+COMMA = "," _
+SEMICOLON = ";" _
+ASSIGN = ":=" _
+
+ADD = "+" _
+SUBTRACT = "-" _
+MULTIPLY = "*" _
+DIVIDE = "/" _
+
+LPAREN = "(" _
+RPAREN = ")" _
+
+block = ( CONST ident EQ number ( COMMA ident EQ number )* SEMICOLON )?
+ ( VAR ident ( COMMA ident )* SEMICOLON )?
+ ( PROCEDURE ident SEMICOLON ( block SEMICOLON )? )* statement
+statement = ( ident ASSIGN expression
+ | CALL ident
+ | BEGIN statement ( SEMICOLON statement )* END
+ | IF condition THEN statement
+ | WHILE condition DO statement )?
+condition = ODD expression
+ | expression (EQ | NEQ | LTEQ | LT | GTEQ | GT) expression
+expression = (ADD | SUBTRACT)? term ( (ADD | SUBTRACT) term )* _
+term = factor ( (MULTIPLY | DIVIDE) factor )*
+factor = ident | number | LPAREN expression RPAREN
+ident = (([a-zA-Z])+) _ => [[ >string ]]
+digit = ([0-9]) => [[ digit> ]]
+number = ((digit)+) _ => [[ 10 digits>integer ]]
+program = _ block "."
;EBNF
From eac450bdcf28773813552170bd1091e13148202b Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 15:55:18 +1300
Subject: [PATCH 041/288] Add ebnf rule word
---
extra/peg/ebnf/ebnf.factor | 3 +++
extra/peg/pl0/pl0-tests.factor | 29 ++++++++++-------------------
2 files changed, 13 insertions(+), 19 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 7c5854cd7d..b0dfaad5b3 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -350,3 +350,6 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
";EBNF" parse-multiline-string replace-escapes
ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing
+: rule ( name word -- parser )
+ #! Given an EBNF word produced from EBNF: return the EBNF rule
+ "ebnf-parser" word-prop at ;
\ No newline at end of file
diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor
index 039f66637d..88993c354b 100644
--- a/extra/peg/pl0/pl0-tests.factor
+++ b/extra/peg/pl0/pl0-tests.factor
@@ -1,52 +1,43 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.pl0 multiline sequences words assocs ;
+USING: kernel tools.test peg peg.ebnf peg.pl0 multiline sequences ;
IN: peg.pl0.tests
{ t } [
- "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
+ "CONST foo = 1;" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
+ "VAR foo;" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
+ "VAR foo,bar , baz;" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "BEGIN foo := 5 END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "BEGIN foo := 5 END" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "IF 1=1 THEN foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "WHILE 1=1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "WHILE ODD 1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "PROCEDURE square; BEGIN squ:=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
-] unit-test
-
-{ f } [
- <"
-PROCEDURE square;
-BEGIN
- squ := x * x
-END;
-"> \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+ "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
From b085ce2f5ff236eeae7640fcd75c34a189648cab Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.gateway.2wire.net>
Date: Tue, 1 Apr 2008 22:24:00 -0500
Subject: [PATCH 042/288] fix unit test
---
extra/classes/singleton/singleton-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor
index 08f4a77aad..586724ee3b 100644
--- a/extra/classes/singleton/singleton-tests.factor
+++ b/extra/classes/singleton/singleton-tests.factor
@@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- )
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton? ] unit-test
-[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
+[ "USING: classes.singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
From a2971bd3bef5ed9fb3e1b6cf66141156aafd2c43 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 00:03:04 -0500
Subject: [PATCH 043/288] Improve walker: step into on an array recursively
sets breakpoint on each quotation nested in the array. Useful for cond, case,
cleave, ...
---
extra/tools/walker/walker.factor | 44 ++++++++++++++++++++------------
1 file changed, 28 insertions(+), 16 deletions(-)
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index d548c0a4f5..6bd8ace877 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -3,7 +3,7 @@
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models ;
+sequences.private assocs models arrays accessors ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -51,9 +51,16 @@ DEFER: start-walker-thread
: walk ( quot -- quot' )
\ break prefix [ break rethrow ] recover ;
-: add-breakpoint ( quot -- quot' )
+GENERIC: add-breakpoint ( quot -- quot' )
+
+M: callable add-breakpoint
dup [ break ] head? [ \ break prefix ] unless ;
+M: array add-breakpoint
+ [ add-breakpoint ] map ;
+
+M: object add-breakpoint ;
+
: (step-into-quot) ( quot -- ) add-breakpoint call ;
: (step-into-if) ? (step-into-quot) ;
@@ -74,7 +81,7 @@ DEFER: start-walker-thread
\ (step-into-execute) t "step-into?" set-word-prop
: (step-into-continuation)
- continuation callstack over set-continuation-call break ;
+ continuation callstack >>call break ;
! Messages sent to walker thread
SYMBOL: step
@@ -94,15 +101,18 @@ SYMBOL: +stopped+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
- >r clone r>
- over continuation-call clone
- [
- dup innermost-frame-scan 1+
- swap innermost-frame-quot
- rot call
- ] keep
- [ set-innermost-frame-quot ] keep
- over set-continuation-call ; inline
+ >r clone r> [
+ >r clone r>
+ [
+ >r
+ [ innermost-frame-scan 1+ ]
+ [ innermost-frame-quot ] bi
+ r> call
+ ]
+ [ drop set-innermost-frame-quot ]
+ [ drop ]
+ 2tri
+ ] curry change-call ; inline
: step-msg ( continuation -- continuation' )
[
@@ -143,6 +153,7 @@ SYMBOL: +stopped+
swap % unclip {
{ [ dup \ break eq? ] [ , ] }
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
+ { [ dup array? ] [ add-breakpoint , \ break , ] }
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
{ [ t ] [ , \ break , ] }
} cond %
@@ -177,16 +188,17 @@ SYMBOL: +stopped+
{ step-back [ f ] }
{ f [ +stopped+ set-status f ] }
[
- dup walker-continuation tget set-model
- step-into-msg
+ [ walker-continuation tget set-model ]
+ [ step-into-msg ] bi
]
} case
] handle-synchronous
] [ ] while ;
: step-back-msg ( continuation -- continuation' )
- walker-history tget dup pop*
- empty? [ drop walker-history tget pop ] unless ;
+ walker-history tget
+ [ pop* ]
+ [ dup empty? [ drop ] [ nip pop ] if ] bi ;
: walker-suspended ( continuation -- continuation' )
+suspended+ set-status
From fa8b578370a8d23968225160c13634f9e95da8e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 00:28:07 -0500
Subject: [PATCH 044/288] Rewriting method dispatch to support inheritance
---
core/bootstrap/layouts/layouts.factor | 4 +-
core/bootstrap/primitives.factor | 23 ++-
core/classes/classes.factor | 6 +-
core/combinators/combinators.factor | 8 +-
core/compiler/tests/intrinsics.factor | 8 -
core/compiler/tests/templates.factor | 4 -
core/cpu/x86/intrinsics/intrinsics.factor | 52 -------
core/generic/generic.factor | 8 +-
core/generic/standard/engines/engines.factor | 49 ++++++
.../engines/predicate/predicate.factor | 28 ++++
core/generic/standard/engines/tag/tag.factor | 48 ++++++
.../standard/engines/tuple/tuple.factor | 109 ++++++++++++++
core/generic/standard/new/new-tests.factor | 141 ++++++++++++++++++
core/generic/standard/new/new.factor | 139 +++++++++++++++++
core/generic/standard/standard.factor | 24 +--
core/inference/backend/backend.factor | 15 +-
core/inference/class/class-tests.factor | 2 +-
core/inference/known-words/known-words.factor | 3 -
core/kernel/kernel-docs.factor | 6 -
core/kernel/kernel.factor | 10 +-
core/layouts/layouts-docs.factor | 4 +-
core/optimizer/known-words/known-words.factor | 23 ---
22 files changed, 573 insertions(+), 141 deletions(-)
create mode 100644 core/generic/standard/engines/engines.factor
create mode 100644 core/generic/standard/engines/predicate/predicate.factor
create mode 100644 core/generic/standard/engines/tag/tag.factor
create mode 100644 core/generic/standard/engines/tuple/tuple.factor
create mode 100644 core/generic/standard/new/new-tests.factor
create mode 100644 core/generic/standard/new/new.factor
diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor
index 846cce153b..ceb011d52b 100755
--- a/core/bootstrap/layouts/layouts.factor
+++ b/core/bootstrap/layouts/layouts.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
-float-arrays quotations assocs layouts classes.tuple.private ;
+float-arrays quotations assocs layouts classes.tuple.private
+kernel.private ;
BIN: 111 tag-mask set
8 num-tags set
@@ -15,6 +16,7 @@ H{
{ bignum BIN: 001 }
{ tuple BIN: 010 }
{ object BIN: 011 }
+ { hi-tag BIN: 011 }
{ ratio BIN: 100 }
{ float BIN: 101 }
{ complex BIN: 110 }
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index bc876c2dec..48a1117574 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -101,17 +101,24 @@ num-types get f <array> builtins set
} [ create-vocab drop ] each
! Builtin classes
-: builtin-predicate-quot ( class -- quot )
+: lo-tag-eq-quot ( n -- quot )
+ [ \ tag , , \ eq? , ] [ ] make ;
+
+: hi-tag-eq-quot ( n -- quot )
[
- "type" word-prop
- [ tag-mask get < \ tag \ type ? , ] [ , ] bi
- \ eq? ,
+ [ dup tag ] % \ hi-tag tag-number , \ eq? ,
+ [ [ hi-tag ] % , \ eq? , ] [ ] make ,
+ [ drop f ] ,
+ \ if ,
] [ ] make ;
+: builtin-predicate-quot ( class -- quot )
+ "type" word-prop
+ dup tag-mask get <
+ [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
+
: define-builtin-predicate ( class -- )
- [ dup builtin-predicate-quot define-predicate ]
- [ predicate-word make-inline ]
- bi ;
+ dup builtin-predicate-quot define-predicate ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
@@ -363,7 +370,7 @@ define-class
f builtins get [ ] subset union-class define-class
! Class of objects with object tag
-"hi-tag" "classes.private" create
+"hi-tag" "kernel.private" create
f builtins get num-tags get tail union-class define-class
! Null class with no instances.
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index d6d1a72121..d91b1bb217 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -124,6 +124,8 @@ GENERIC: update-methods ( assoc -- )
] bi
] 2tri ;
-GENERIC: class ( object -- class ) inline
+GENERIC: class ( object -- class )
-M: object class type type>class ;
+M: hi-tag class hi-tag type>class ;
+
+M: object class tag type>class ;
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index f9ed219d7b..139c6d8fdf 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -9,24 +9,24 @@ hashtables sorting ;
[ call ] with each ;
: cleave>quot ( seq -- quot )
- [ [ keep ] curry ] map concat [ drop ] append ;
+ [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
: 2cleave ( x seq -- )
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
- [ [ 2keep ] curry ] map concat [ 2drop ] append ;
+ [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
: 3cleave ( x seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
- [ [ 3keep ] curry ] map concat [ 3drop ] append ;
+ [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
- append ;
+ append [ ] like ;
: spread ( objs... seq -- )
spread>quot call ;
diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor
index 7a8fe5d735..fadc57dc8d 100755
--- a/core/compiler/tests/intrinsics.factor
+++ b/core/compiler/tests/intrinsics.factor
@@ -174,11 +174,6 @@ sequences.private ;
[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
-[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
-[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
-[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
-[ t ] [ f type f [ type ] compile-call eq? ] unit-test
-
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
@@ -223,9 +218,6 @@ sequences.private ;
[ t ] [ f [ f eq? ] compile-call ] unit-test
-! regression
-[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
-
! regression
[ 3 ] [
100001 f <array> 3 100000 pick set-nth
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index 081a8fd47c..a82208e9b9 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -26,10 +26,6 @@ IN: compiler.tests
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test
-[ { 1 2 3 } { 1 4 3 } 8 8 ]
-[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
-unit-test
-
! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index 261ada025b..80a786c9fa 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "in" } }
} define-intrinsic
-\ type [
- "end" define-label
- ! Make a copy
- "x" operand "obj" operand MOV
- ! Get the tag
- "x" operand tag-mask get AND
- ! Tag the tag
- "x" operand %tag-fixnum
- ! Compare with object tag number (3).
- "x" operand object tag-number tag-fixnum CMP
- "end" get JNE
- ! If we have equality, load type from header
- "x" operand "obj" operand -3 [+] MOV
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
- "end" define-label
- "tuple" define-label
- "object" define-label
- ! Make a copy
- "x" operand "obj" operand MOV
- ! Get the tag
- "x" operand tag-mask get AND
- ! Tag the tag
- "x" operand %tag-fixnum
- ! Compare with tuple tag number (2).
- "x" operand tuple tag-number tag-fixnum CMP
- "tuple" get JE
- ! Compare with object tag number (3).
- "x" operand object tag-number tag-fixnum CMP
- "object" get JE
- "end" get JMP
- "object" get resolve-label
- ! Load header type
- "x" operand "obj" operand header-offset [+] MOV
- "end" get JMP
- "tuple" get resolve-label
- ! Load class hash
- "x" operand "obj" operand tuple-class-offset [+] MOV
- "x" operand dup class-hash-offset [+] MOV
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
! Slots
: %slot-literal-known-tag
"obj" operand
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 7dba7eb709..dc98883654 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -37,10 +37,12 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
+: sort-methods ( assoc -- assoc' )
+ [ keys sort-classes ]
+ [ [ dupd at ] curry ] bi { } map>assoc ;
+
: methods ( word -- assoc )
- "methods" word-prop
- [ keys sort-classes ] keep
- [ dupd at ] curry { } map>assoc ;
+ "methods" word-prop sort-methods ;
TUPLE: check-method class generic ;
diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor
new file mode 100644
index 0000000000..bf8d4fb67a
--- /dev/null
+++ b/core/generic/standard/engines/engines.factor
@@ -0,0 +1,49 @@
+USING: assocs kernel namespaces quotations generic math
+sequences combinators words classes.algebra ;
+IN: generic.standard.engines
+
+SYMBOL: default
+SYMBOL: assumed
+
+GENERIC: engine>quot ( engine -- quot )
+
+M: quotation engine>quot ;
+
+M: method-body engine>quot 1quotation ;
+
+: engines>quots ( assoc -- assoc' )
+ [ engine>quot ] assoc-map ;
+
+: engines>quots* ( assoc -- assoc' )
+ [ over assumed [ engine>quot ] with-variable ] assoc-map ;
+
+: if-small? ( assoc true false -- )
+ >r >r dup assoc-size 4 <= r> r> if ; inline
+
+: linear-dispatch-quot ( alist -- quot )
+ default get [ drop ] prepend swap
+ [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
+ alist>quot ;
+
+: split-methods ( assoc class -- first second )
+ [ [ nip class< not ] curry assoc-subset ]
+ [ [ nip class< ] curry assoc-subset ] 2bi ;
+
+: convert-methods ( assoc class word -- assoc' )
+ over >r >r split-methods dup assoc-empty? [
+ r> r> 3drop
+ ] [
+ r> execute r> pick set-at
+ ] if ; inline
+
+SYMBOL: (dispatch#)
+
+: (picker) ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+ } case ;
+
+: picker ( -- quot ) \ (dispatch#) get (picker) ;
diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor
new file mode 100644
index 0000000000..2d43a313f0
--- /dev/null
+++ b/core/generic/standard/engines/predicate/predicate.factor
@@ -0,0 +1,28 @@
+USING: generic.standard.engines generic namespaces kernel
+sequences classes.algebra accessors words combinators
+assocs ;
+IN: generic.standard.engines.predicate
+
+TUPLE: predicate-dispatch-engine methods ;
+
+C: <predicate-dispatch-engine> predicate-dispatch-engine
+
+: class-predicates ( assoc -- assoc )
+ [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
+
+: keep-going? ( assoc -- ? )
+ assumed get swap second first class< ;
+
+: prune-redundant-predicates ( assoc -- default assoc' )
+ {
+ { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+ { [ dup length 1 = ] [ first second { } ] }
+ { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
+ { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
+ } cond ;
+
+M: predicate-dispatch-engine engine>quot
+ methods>> clone
+ default get object bootstrap-word pick set-at engines>quots
+ sort-methods prune-redundant-predicates
+ class-predicates alist>quot ;
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
new file mode 100644
index 0000000000..fd40af0e50
--- /dev/null
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -0,0 +1,48 @@
+USING: classes.private generic.standard.engines namespaces
+arrays mirrors assocs sequences.private quotations
+kernel.private layouts math slots.private math.private
+kernel accessors ;
+IN: generic.standard.engines.tag
+
+TUPLE: lo-tag-dispatch-engine methods ;
+
+C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
+
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+ hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
+
+: direct-dispatch-quot ( alist n -- quot )
+ default get <array>
+ [ <enum> swap update ] keep
+ [ dispatch ] curry >quotation ;
+
+M: lo-tag-dispatch-engine engine>quot
+ methods>> engines>quots* [ >r tag-number r> ] assoc-map
+ [
+ picker % [ tag ] % [
+ linear-dispatch-quot
+ ] [
+ num-tags get direct-dispatch-quot
+ ] if-small? %
+ ] [ ] make ;
+
+: num-hi-tags num-types get num-tags get - ;
+
+: hi-tag-number type-number num-tags get - ;
+
+: hi-tag-quot ( -- quot )
+ [ 0 slot ] num-tags get [ fixnum- ] curry compose ;
+
+M: hi-tag-dispatch-engine engine>quot
+ methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+ [
+ picker % hi-tag-quot % [
+ linear-dispatch-quot
+ ] [
+ num-hi-tags direct-dispatch-quot
+ ] if-small? %
+ ] [ ] make ;
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
new file mode 100644
index 0000000000..ce0f50337d
--- /dev/null
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -0,0 +1,109 @@
+IN: generic.standard.engines.tuple
+USING: kernel classes.tuple.private hashtables assocs sorting
+accessors combinators sequences slots.private math.parser words
+effects namespaces generic generic.standard.engines
+classes.algebra math math.private quotations ;
+
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: trivial-tuple-dispatch-engine methods ;
+
+C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+ >r swap dup tuple-layout layout-echelon r>
+ [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+ V{ } clone [
+ [
+ push-echelon
+ ] curry assoc-each
+ ] keep sort-keys ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+ echelon-sort
+ [ dupd <echelon-dispatch-engine> ] assoc-map
+ \ tuple-dispatch-engine construct-boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+ tuple \ <tuple-dispatch-engine> convert-methods ;
+
+M: trivial-tuple-dispatch-engine engine>quot
+ methods>> engines>quots* linear-dispatch-quot ;
+
+: hash-methods ( methods -- buckets )
+ >alist V{ } clone [ class-hashes ] distribute-buckets
+ [ <trivial-tuple-dispatch-engine> ] map ;
+
+: class-hash-dispatch-quot ( methods -- quot )
+ #! 1 slot == word hashcode
+ [
+ [ dup 1 slot ] %
+ hash-methods [ engine>quot ] map hash-dispatch-quot %
+ ] [ ] make ;
+
+: tuple-dispatch-engine-word-name ( engine -- string )
+ [
+ generic get word-name %
+ "/tuple-dispatch-engine/" %
+ n>> #
+ ] "" make ;
+
+PREDICATE: tuple-dispatch-engine-word < word
+ "tuple-dispatch-engine" word-prop ;
+
+M: tuple-dispatch-engine-word stack-effect
+ "tuple-dispatch-generic" word-prop stack-effect ;
+
+: <tuple-dispatch-engine-word> ( engine -- word )
+ tuple-dispatch-engine-word-name f <word>
+ [ t "tuple-dispatch-engine" set-word-prop ]
+ [ generic get "tuple-dispatch-generic" set-word-prop ]
+ [ ]
+ tri ;
+
+: define-tuple-dispatch-engine-word ( engine quot -- word )
+ >r <tuple-dispatch-engine-word> dup r> define ;
+
+: tuple-dispatch-engine-body ( engine -- quot )
+ #! 1 slot == tuple-layout
+ #! 2 slot == 0 array-nth
+ #! 4 slot == layout-superclasses
+ [
+ picker %
+ [ 1 slot 4 slot ] %
+ [ n>> 2 + , [ slot ] % ]
+ [
+ methods>> [
+ <trivial-tuple-dispatch-engine> engine>quot
+ ] [
+ class-hash-dispatch-quot
+ ] if-small? %
+ ] bi
+ ] [ ] make ;
+
+M: echelon-dispatch-engine engine>quot
+ dup tuple-dispatch-engine-body
+ define-tuple-dispatch-engine-word
+ 1quotation ;
+
+: >=-case-quot ( alist -- quot )
+ default get [ drop ] prepend swap
+ [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
+ alist>quot ;
+
+M: tuple-dispatch-engine engine>quot
+ #! 1 slot == tuple-layout
+ #! 5 slot == layout-echelon
+ [
+ picker %
+ [ 1 slot 5 slot ] %
+ echelons>>
+ [ [ engine>quot dup default set ] assoc-map ] with-scope
+ >=-case-quot %
+ ] [ ] make ;
diff --git a/core/generic/standard/new/new-tests.factor b/core/generic/standard/new/new-tests.factor
new file mode 100644
index 0000000000..d372926f43
--- /dev/null
+++ b/core/generic/standard/new/new-tests.factor
@@ -0,0 +1,141 @@
+IN: generic.standard.new.tests
+USING: tools.test math math.functions math.constants
+generic.standard.new strings sequences arrays kernel accessors
+words float-arrays byte-arrays bit-arrays parser ;
+
+<< : GENERIC: CREATE-GENERIC define-simple-generic ; parsing >>
+
+GENERIC: lo-tag-test
+
+M: integer lo-tag-test 3 + ;
+
+M: float lo-tag-test 4 - ;
+
+M: rational lo-tag-test 2 - ;
+
+M: complex lo-tag-test sq ;
+
+[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
+[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
+[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
+[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
+
+GENERIC: hi-tag-test
+
+M: string hi-tag-test ", in bed" append ;
+
+M: number hi-tag-test 3 + ;
+
+M: array hi-tag-test [ hi-tag-test ] map ;
+
+M: sequence hi-tag-test reverse ;
+
+[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
+
+[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
+
+[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
+
+TUPLE: shape ;
+
+TUPLE: abstract-rectangle < shape width height ;
+
+TUPLE: rectangle < abstract-rectangle ;
+
+C: <rectangle> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> area 4 pi * = ] unit-test
+
+GENERIC: perimiter
+
+: rectangle-perimiter + 2 * ;
+
+M: rectangle perimiter
+ [ width>> ] [ height>> ] bi
+ rectangle-perimiter ;
+
+: hypotenuse [ sq ] bi@ + sqrt ;
+
+M: parallelogram perimiter
+ [ width>> ]
+ [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
+ rectangle-perimiter ;
+
+M: circle perimiter 2 * pi * ;
+
+[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
+[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+
+GENERIC: big-mix-test
+
+M: object big-mix-test drop "object" ;
+
+M: tuple big-mix-test drop "tuple" ;
+
+M: integer big-mix-test drop "integer" ;
+
+M: float big-mix-test drop "float" ;
+
+M: complex big-mix-test drop "complex" ;
+
+M: string big-mix-test drop "string" ;
+
+M: array big-mix-test drop "array" ;
+
+M: sequence big-mix-test drop "sequence" ;
+
+M: rectangle big-mix-test drop "rectangle" ;
+
+M: parallelogram big-mix-test drop "parallelogram" ;
+
+M: circle big-mix-test drop "circle" ;
+
+[ "integer" ] [ 3 big-mix-test ] unit-test
+[ "float" ] [ 5.0 big-mix-test ] unit-test
+[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
+[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
+[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
+[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
+[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
+[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
+[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
+[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
+[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
+[ "string" ] [ "hello" big-mix-test ] unit-test
+[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
+[ "tuple" ] [ H{ } big-mix-test ] unit-test
+[ "object" ] [ \ + big-mix-test ] unit-test
+
+GENERIC: small-lo-tag
+
+M: fixnum small-lo-tag drop "fixnum" ;
+
+M: string small-lo-tag drop "string" ;
+
+M: array small-lo-tag drop "array" ;
+
+M: float-array small-lo-tag drop "float-array" ;
+
+M: byte-array small-lo-tag drop "byte-array" ;
+
+[ "fixnum" ] [ 3 small-lo-tag ] unit-test
+
+[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor
new file mode 100644
index 0000000000..b2371cc4e5
--- /dev/null
+++ b/core/generic/standard/new/new.factor
@@ -0,0 +1,139 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs kernel kernel.private slots.private math
+namespaces sequences vectors words quotations definitions
+hashtables layouts combinators sequences.private generic
+classes classes.algebra classes.private generic.standard.engines
+generic.standard.engines.tag generic.standard.engines.predicate
+generic.standard.engines.tuple accessors ;
+IN: generic.standard.new
+
+: unpickers
+ {
+ [ nip ]
+ [ >r nip r> swap ]
+ [ >r >r nip r> r> -rot ]
+ } ; inline
+
+: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
+
+ERROR: no-method object generic ;
+
+: error-method ( word -- quot )
+ picker swap [ no-method ] curry append ;
+
+: empty-method ( word -- quot )
+ [
+ picker % [ delegate dup ] %
+ unpicker over suffix ,
+ error-method \ drop prefix , \ if ,
+ ] [ ] make ;
+
+: default-method ( word -- pair )
+ "default-method" word-prop
+ object bootstrap-word swap 2array ;
+
+: push-method ( method specializer atomic assoc -- )
+ [
+ [ H{ } clone <predicate-dispatch-engine> ] unless*
+ [ methods>> set-at ] keep
+ ] change-at ;
+
+: flatten-method ( class method assoc -- )
+ >r >r dup flatten-class keys swap r> r> [
+ >r spin r> push-method
+ ] 3curry each ;
+
+: flatten-methods ( assoc -- assoc' )
+ H{ } clone [
+ [
+ flatten-method
+ ] curry assoc-each
+ ] keep ;
+
+: <big-dispatch-engine> ( assoc -- engine )
+ flatten-methods
+ convert-tuple-methods
+ convert-hi-tag-methods
+ <lo-tag-dispatch-engine> ;
+
+: find-default ( methods -- quot )
+ #! Side-effects methods.
+ object swap delete-at* [
+ drop generic get "default-method" word-prop
+ ] unless 1quotation ;
+
+GENERIC: mangle-method ( method generic -- quot )
+
+: single-combination ( words -- quot )
+ [
+ object bootstrap-word assumed set
+ [ generic set ]
+ [
+ "methods" word-prop
+ [ generic get mangle-method ] assoc-map
+ [ find-default default set ]
+ [
+ generic get "inline" word-prop [
+ <predicate-dispatch-engine>
+ ] [
+ <big-dispatch-engine>
+ ] if
+ ] bi
+ engine>quot
+ ] bi
+ ] with-scope ;
+
+TUPLE: standard-combination # ;
+
+C: <standard-combination> standard-combination
+
+PREDICATE: standard-generic < generic
+ "combination" word-prop standard-combination? ;
+
+PREDICATE: simple-generic < standard-generic
+ "combination" word-prop #>> zero? ;
+
+: define-simple-generic ( word -- )
+ T{ standard-combination f 0 } define-generic ;
+
+: with-standard ( combination quot -- quot' )
+ >r #>> (dispatch#) r> with-variable ;
+
+M: standard-combination make-default-method
+ [ empty-method ] with-standard ;
+
+M: standard-combination perform-combination
+ [ single-combination ] with-standard ;
+
+TUPLE: hook-combination var ;
+
+C: <hook-combination> hook-combination
+
+PREDICATE: hook-generic < generic
+ "combination" word-prop hook-combination? ;
+
+: with-hook ( combination quot -- quot' )
+ 0 (dispatch#) [
+ dip var>> [ get ] curry prepend
+ ] with-variable ; inline
+
+M: hook-combination make-default-method
+ [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+ [ single-combination ] with-hook ;
+
+GENERIC: dispatch# ( word -- n )
+
+M: word dispatch# "combination" word-prop dispatch# ;
+
+M: standard-combination dispatch# #>> ;
+
+M: hook-combination dispatch# drop 0 ;
+
+M: simple-generic definer drop \ GENERIC: f ;
+
+M: standard-generic definer drop \ GENERIC# f ;
+
+M: hook-generic definer drop \ HOOK: f ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 4ed883dad5..65b66e9538 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -41,23 +41,13 @@ ERROR: no-method object generic ;
: class-predicates ( assoc -- assoc )
[ >r "predicate" word-prop picker prepend r> ] assoc-map ;
-: (simplify-alist) ( class i assoc -- default assoc )
- 2dup length 1- = [
- nth second { } rot drop
- ] [
- 3dup >r 1+ r> nth first class< [
- >r 1+ r> (simplify-alist)
- ] [
- [ nth second ] 2keep swap 1+ tail rot drop
- ] if
- ] if ;
-
-: simplify-alist ( class assoc -- default assoc )
- dup empty? [
- 2drop [ "Unreachable" throw ] { }
- ] [
- 0 swap (simplify-alist)
- ] if ;
+: simplify-alist ( class assoc -- default assoc' )
+ {
+ { [ dup empty? ] [ 2drop [ "Unreachable" throw ] { } ] }
+ { [ dup length 1 = ] [ nip first second { } ] }
+ { [ 2dup second first class< ] [ 1 tail-slice simplify-alist ] }
+ { [ t ] [ nip [ first second ] [ 1 tail-slice ] bi ] }
+ } cond ;
: default-method ( word -- pair )
"default-method" word-prop
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 5ca9b1b2e7..61412ccf9f 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -3,14 +3,23 @@
USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
-continuations debugger assocs combinators compiler.errors ;
+continuations debugger assocs combinators compiler.errors
+generic.standard.engines.tuple ;
IN: inference.backend
: recursive-label ( word -- label/f )
recursive-state get at ;
-: inline? ( word -- ? )
- dup "method-generic" word-prop swap or "inline" word-prop ;
+GENERIC: inline? ( word -- ? )
+
+M: method-body inline?
+ "method-generic" word-prop inline? ;
+
+M: tuple-dispatch-engine-word inline?
+ "tuple-dispatch-generic" word-prop inline? ;
+
+M: word inline?
+ "inline" word-prop ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 67b8616c61..7d18aaa489 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -120,7 +120,7 @@ M: object xyz ;
[
[ no-cond ] 1
[ 1array dup quotation? [ >quotation ] unless ] times
- ] \ type inlined?
+ ] \ quotation? inlined?
] unit-test
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 79e41c8ae4..3cc78831a3 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -383,9 +383,6 @@ set-primitive-effect
\ millis { } { integer } <effect> set-primitive-effect
\ millis make-flushable
-\ type { object } { fixnum } <effect> set-primitive-effect
-\ type make-foldable
-
\ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index b1120de8e6..2df5e69998 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -413,12 +413,6 @@ HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
-HELP: type ( object -- n )
-{ $values { "object" object } { "n" "a type number" } }
-{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
-
-{ type tag type>class } related-words
-
HELP: ? ( ? true false -- true/false )
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index ab42a1b903..eed5b22e5f 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel.private ;
+USING: kernel.private slots.private ;
IN: kernel
! Stack stuff
@@ -99,14 +99,14 @@ DEFER: if
! Appliers
: bi@ ( x y quot -- )
- tuck 2slip call ; inline
+ dup bi* ; inline
: tri@ ( x y z quot -- )
- tuck >r bi@ r> call ; inline
+ dup dup tri* ; inline
! Double appliers
: 2bi@ ( w x y z quot -- )
- dup -roll 3slip call ; inline
+ dup 2bi* ; inline
: while ( pred body tail -- )
>r >r dup slip r> r> roll
@@ -194,6 +194,8 @@ GENERIC: construct-boa ( ... class -- tuple )
<PRIVATE
+: hi-tag ( obj -- n ) 0 slot ;
+
: declare ( spec -- ) drop ;
: do-primitive ( number -- ) "Improper primitive call" throw ;
diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor
index d4188dd3b6..089465177b 100755
--- a/core/layouts/layouts-docs.factor
+++ b/core/layouts/layouts-docs.factor
@@ -14,7 +14,7 @@ HELP: tag-mask
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
HELP: num-types
-{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ;
+{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
HELP: tag-number
{ $values { "class" class } { "n" "an integer or " { $link f } } }
@@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits
ARTICLE: "layouts-types" "Type numbers"
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsection type }
+{ $subsection hi-tag }
"Built-in type numbers can be converted to classes, and vice versa:"
{ $subsection type>class }
{ $subsection type-number }
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 108c715ef0..a4782078ee 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -87,29 +87,6 @@ sequences.private combinators ;
{ { @ @ } [ 2drop t ] }
} define-identities
-! type applied to an object of a known type can be folded
-: known-type? ( node -- ? )
- node-class-first class-types length 1 number= ;
-
-: fold-known-type ( node -- node )
- dup node-class-first class-types inline-literals ;
-
-\ type [
- { [ dup known-type? ] [ fold-known-type ] }
-] define-optimizers
-
-! if the result of type is n, then the object has type n
-{ tag type } [
- [
- num-types get swap [
- [
- [ type>class object or 0 `input class, ] keep
- 0 `output literal,
- ] set-constraints
- ] curry each
- ] "constraints" set-word-prop
-] each
-
! Specializers
{ 1+ 1- sq neg recip sgn } [
{ number } "specializer" set-word-prop
From f96a43c42daaa07a4c63940f77552733e3309950 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 00:45:30 -0500
Subject: [PATCH 045/288] Getting ready to drop in new dispatch code
---
core/classes/algebra/algebra-tests.factor | 2 +-
core/generic/standard/engines/tag/tag.factor | 2 +-
core/generic/standard/new/new.factor | 6 ++++++
core/generic/standard/standard.factor | 2 +-
4 files changed, 9 insertions(+), 3 deletions(-)
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index cdf817e31d..dc65b09579 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -96,7 +96,7 @@ UNION: z1 b1 c1 ;
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
-[ f ] [ growable hi-tag classes-intersect? ] unit-test
+[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
[ t ] [
growable tuple sequence class-and class<
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index fd40af0e50..1bcd007d0d 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -13,7 +13,7 @@ TUPLE: hi-tag-dispatch-engine methods ;
C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
: convert-hi-tag-methods ( assoc -- assoc' )
- hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
+ \ hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
: direct-dispatch-quot ( alist n -- quot )
default get <array>
diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor
index b2371cc4e5..00c33e38fd 100644
--- a/core/generic/standard/new/new.factor
+++ b/core/generic/standard/new/new.factor
@@ -100,6 +100,9 @@ PREDICATE: simple-generic < standard-generic
: with-standard ( combination quot -- quot' )
>r #>> (dispatch#) r> with-variable ;
+M: standard-generic mangle-method
+ drop ;
+
M: standard-combination make-default-method
[ empty-method ] with-standard ;
@@ -118,6 +121,9 @@ PREDICATE: hook-generic < generic
dip var>> [ get ] curry prepend
] with-variable ; inline
+M: hook-generic mangle-method
+ drop [ drop ] prepend ;
+
M: hook-combination make-default-method
[ error-method ] with-hook ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 65b66e9538..b77c0ed9e5 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -77,7 +77,7 @@ ERROR: no-method object generic ;
[ small-generic ] picker class-hash-dispatch-quot ;
: vtable-class ( n -- class )
- bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
+ bootstrap-type>class [ \ hi-tag bootstrap-word ] unless* ;
: group-methods ( assoc -- vtable )
#! Input is a predicate -> method association.
From 7a596ce004972a0e8ddea4cc959ce3185f7feaa6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 02:44:10 -0500
Subject: [PATCH 046/288] Debugging inheritancE
---
core/assocs/assocs.factor | 26 ++-
core/classes/algebra/algebra-tests.factor | 2 +-
core/classes/classes.factor | 40 ++--
core/classes/predicate/predicate.factor | 11 +-
core/classes/tuple/tuple-tests.factor | 4 +-
core/classes/tuple/tuple.factor | 34 ++-
core/classes/union/union.factor | 28 +--
core/cpu/ppc/intrinsics/intrinsics.factor | 49 ----
core/generic/generic-docs.factor | 9 -
core/generic/standard/engines/tag/tag.factor | 5 +-
core/generic/standard/new/new.factor | 145 ------------
...new-tests.factor => standard-tests.factor} | 8 +-
core/generic/standard/standard.factor | 219 +++++++-----------
core/mirrors/mirrors.factor | 21 --
.../specializers/specializers.factor | 3 +-
15 files changed, 177 insertions(+), 427 deletions(-)
delete mode 100644 core/generic/standard/new/new.factor
rename core/generic/standard/{new/new-tests.factor => standard-tests.factor} (94%)
mode change 100755 => 100644 core/generic/standard/standard.factor
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index b911faf672..6b6bd3d51a 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -1,6 +1,7 @@
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays math sequences.private vectors ;
+USING: kernel sequences arrays math sequences.private vectors
+accessors ;
IN: assocs
MIXIN: assoc
@@ -189,3 +190,24 @@ M: f clear-assoc drop ;
M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
INSTANCE: sequence assoc
+
+TUPLE: enum seq ;
+
+C: <enum> enum
+
+M: enum at*
+ seq>> 2dup bounds-check?
+ [ nth t ] [ 2drop f f ] if ;
+
+M: enum set-at seq>> set-nth ;
+
+M: enum delete-at enum-seq delete-nth ;
+
+M: enum >alist ( enum -- alist )
+ seq>> [ length ] keep 2array flip ;
+
+M: enum assoc-size seq>> length ;
+
+M: enum clear-assoc seq>> delete-all ;
+
+INSTANCE: enum assoc
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index dc65b09579..32664dc823 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
-random inference effects ;
+random inference effects kernel.private ;
: class= [ class< ] 2keep swap class< and ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index d91b1bb217..914e070e03 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -83,7 +83,7 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
-: define-class-props ( superclass members metaclass -- assoc )
+: make-class-props ( superclass members metaclass -- assoc )
[
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
@@ -92,12 +92,16 @@ M: word reset-class drop ;
] H{ } make-assoc ;
: (define-class) ( word props -- )
- over reset-class
- over deferred? [ over define-symbol ] when
- >r dup word-props r> union over set-word-props
- dup predicate-word 2dup 1quotation "predicate" set-word-prop
- over "predicating" set-word-prop
- t "class" set-word-prop ;
+ >r
+ dup reset-class
+ dup deferred? [ dup define-symbol ] when
+ dup word-props
+ r> union over set-word-props
+ dup predicate-word
+ [ 1quotation "predicate" set-word-prop ]
+ [ swap "predicating" set-word-prop ]
+ [ drop t "class" set-word-prop ]
+ 2tri ;
PRIVATE>
@@ -105,24 +109,22 @@ GENERIC: update-class ( class -- )
M: class update-class drop ;
-: update-classes ( assoc -- )
- [ drop update-class ] assoc-each ;
-
GENERIC: update-methods ( assoc -- )
+: update-classes ( class -- )
+ class-usages
+ [ [ drop update-class ] assoc-each ]
+ [ update-methods ]
+ bi ;
+
: define-class ( word superclass members metaclass -- )
#! If it was already a class, update methods after.
reset-caches
- define-class-props
+ make-class-props
[ drop update-map- ]
- [ (define-class) ] [
- drop
- [ update-map+ ] [
- class-usages
- [ update-classes ]
- [ update-methods ] bi
- ] bi
- ] 2tri ;
+ [ (define-class) ]
+ [ drop update-map+ ]
+ 2tri ;
GENERIC: class ( object -- class )
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index b2a5a03bb4..0f98f1f5c4 100755
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -14,9 +14,14 @@ PREDICATE: predicate-class < class
] [ ] make ;
: define-predicate-class ( class superclass definition -- )
- >r dupd f predicate-class define-class
- r> dupd "predicate-definition" set-word-prop
- dup predicate-quot define-predicate ;
+ [ drop f predicate-class define-class ]
+ [ nip "predicate-definition" set-word-prop ]
+ [
+ 2drop
+ [ dup predicate-quot define-predicate ]
+ [ update-classes ]
+ bi
+ ] 3tri ;
M: predicate-class reset-class
{
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index db0e25f091..228de8aabf 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -62,13 +62,13 @@ C: <point> point
[ 200 ] [ "p" get y>> ] unit-test
[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
-"p" get 300 ">>z" "accessors" lookup execute drop
+[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
[ 4 ] [ "p" get tuple-size ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
-"IN: classes.tuple.tests TUPLE: point z y ;" eval
+[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
[ 3 ] [ "p" get tuple-size ] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 3cacef25a1..bbc221b85d 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -161,25 +161,23 @@ PRIVATE>
: update-tuples-after ( class -- )
outdated-tuples get [ all-slot-names ] cache drop ;
-: subclasses ( class -- classes )
- class-usages keys [ tuple-class? ] subset ;
-
-: each-subclass ( class quot -- )
- >r subclasses r> each ; inline
-
-: define-tuple-shape ( class -- )
- [ define-tuple-slots ]
+M: tuple-class update-class
[ define-tuple-layout ]
+ [ define-tuple-slots ]
[ define-tuple-predicate ]
tri ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
[ nip "slot-names" set-word-prop ]
- [
- 2drop
- [ define-tuple-shape ] each-subclass
- ] 3tri ;
+ [ 2drop update-classes ]
+ 3tri ;
+
+: subclasses ( class -- classes )
+ class-usages keys [ tuple-class? ] subset ;
+
+: each-subclass ( class quot -- )
+ >r subclasses r> each ; inline
: redefine-tuple-class ( class superclass slots -- )
[
@@ -214,6 +212,9 @@ M: tuple-class define-tuple-class
[ define-tuple-class ] [ 2drop ] 3bi
dup [ construct-boa throw ] curry define ;
+M: tuple-class reset-class
+ { "metaclass" "superclass" "slots" "layout" } reset-props ;
+
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@@ -227,12 +228,6 @@ M: tuple hashcode*
] 2curry reduce
] recursive-hashcode ;
-M: tuple-class reset-class
- { "metaclass" "superclass" "slots" "layout" } reset-props ;
-
-M: object get-slots ( obj slots -- ... )
- [ execute ] with each ;
-
M: object construct-empty ( class -- tuple )
tuple-layout <tuple> ;
@@ -240,6 +235,9 @@ M: object construct-boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
! Deprecated
+M: object get-slots ( obj slots -- ... )
+ [ execute ] with each ;
+
M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index e9b98770dc..9079974a60 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -1,33 +1,21 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-generic.standard namespaces arrays math quotations ;
+namespaces arrays math quotations ;
IN: classes.union
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.
-: small-union-predicate-quot ( members -- quot )
+: union-predicate-quot ( members -- quot )
dup empty? [
drop [ drop f ]
] [
- unclip first "predicate" word-prop swap
- [ >r "predicate" word-prop [ dup ] prepend r> ]
- assoc-map alist>quot
- ] if ;
-
-: big-union-predicate-quot ( members -- quot )
- [ small-union-predicate-quot ] [ dup ]
- class-hash-dispatch-quot ;
-
-: union-predicate-quot ( members -- quot )
- [ [ drop t ] ] { } map>assoc
- dup length 4 <= [
- small-union-predicate-quot
- ] [
- flatten-methods
- big-union-predicate-quot
+ unclip "predicate" word-prop swap [
+ "predicate" word-prop [ dup ] prepend
+ [ drop t ]
+ ] { } map>assoc alist>quot
] if ;
: define-union-predicate ( class -- )
@@ -36,7 +24,9 @@ PREDICATE: union-class < class
M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
- f swap union-class define-class ;
+ [ f swap union-class define-class ]
+ [ drop update-classes ]
+ 2bi ;
M: union-class reset-class
{ "metaclass" "members" } reset-props ;
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 07698eaa92..d092473960 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } }
} define-intrinsic
-\ type [
- "end" define-label
- ! Get the tag
- "y" operand "obj" operand tag-mask get ANDI
- ! Tag the tag
- "y" operand "x" operand %tag-fixnum
- ! Compare with object tag number (3).
- 0 "y" operand object tag-number CMPI
- ! Jump if the object doesn't store type info in its header
- "end" get BNE
- ! It does store type info in its header
- "x" operand "obj" operand header-offset LWZ
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } { f "y" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
- "end" define-label
- "tuple" define-label
- "object" define-label
- ! Get the tag
- "y" operand "obj" operand tag-mask get ANDI
- ! Compare with tuple tag number (2).
- 0 "y" operand tuple tag-number CMPI
- "tuple" get BEQ
- ! Compare with object tag number (3).
- 0 "y" operand object tag-number CMPI
- "object" get BEQ
- ! Tag the tag
- "y" operand "x" operand %tag-fixnum
- "end" get B
- "object" get resolve-label
- ! Load header type
- "x" operand "obj" operand header-offset LWZ
- "end" get B
- "tuple" get resolve-label
- ! Load class hash
- "x" operand "obj" operand tuple-class-offset LWZ
- "x" operand dup class-hash-offset LWZ
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } { f "y" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
: userenv ( reg -- )
#! Load the userenv pointer in a register.
"userenv" f rot %load-dlsym ;
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 56de801e7a..100475455a 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -63,15 +63,6 @@ ARTICLE: "method-combination" "Custom method combination"
"Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the definition protocol words " { $link definer } " and " { $link synopsis* } " on the class of words having this method combination, to properly support developer tools."
$nl
"The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
-$nl
-"Method combination utilities:"
-{ $subsection single-combination }
-{ $subsection class-predicates }
-{ $subsection simplify-alist }
-{ $subsection math-upgrade }
-{ $subsection object-method }
-{ $subsection error-method }
-"More quotation construction utilities can be found in " { $link "quotations" } " and " { $link "combinators-quot" } "."
{ $see-also "generic-introspection" } ;
ARTICLE: "generic" "Generic words and methods"
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 1bcd007d0d..3dd8b83579 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -1,7 +1,6 @@
USING: classes.private generic.standard.engines namespaces
-arrays mirrors assocs sequences.private quotations
-kernel.private layouts math slots.private math.private
-kernel accessors ;
+arrays assocs sequences.private quotations kernel.private
+layouts math slots.private math.private kernel accessors ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor
deleted file mode 100644
index 00c33e38fd..0000000000
--- a/core/generic/standard/new/new.factor
+++ /dev/null
@@ -1,145 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel kernel.private slots.private math
-namespaces sequences vectors words quotations definitions
-hashtables layouts combinators sequences.private generic
-classes classes.algebra classes.private generic.standard.engines
-generic.standard.engines.tag generic.standard.engines.predicate
-generic.standard.engines.tuple accessors ;
-IN: generic.standard.new
-
-: unpickers
- {
- [ nip ]
- [ >r nip r> swap ]
- [ >r >r nip r> r> -rot ]
- } ; inline
-
-: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
-
-ERROR: no-method object generic ;
-
-: error-method ( word -- quot )
- picker swap [ no-method ] curry append ;
-
-: empty-method ( word -- quot )
- [
- picker % [ delegate dup ] %
- unpicker over suffix ,
- error-method \ drop prefix , \ if ,
- ] [ ] make ;
-
-: default-method ( word -- pair )
- "default-method" word-prop
- object bootstrap-word swap 2array ;
-
-: push-method ( method specializer atomic assoc -- )
- [
- [ H{ } clone <predicate-dispatch-engine> ] unless*
- [ methods>> set-at ] keep
- ] change-at ;
-
-: flatten-method ( class method assoc -- )
- >r >r dup flatten-class keys swap r> r> [
- >r spin r> push-method
- ] 3curry each ;
-
-: flatten-methods ( assoc -- assoc' )
- H{ } clone [
- [
- flatten-method
- ] curry assoc-each
- ] keep ;
-
-: <big-dispatch-engine> ( assoc -- engine )
- flatten-methods
- convert-tuple-methods
- convert-hi-tag-methods
- <lo-tag-dispatch-engine> ;
-
-: find-default ( methods -- quot )
- #! Side-effects methods.
- object swap delete-at* [
- drop generic get "default-method" word-prop
- ] unless 1quotation ;
-
-GENERIC: mangle-method ( method generic -- quot )
-
-: single-combination ( words -- quot )
- [
- object bootstrap-word assumed set
- [ generic set ]
- [
- "methods" word-prop
- [ generic get mangle-method ] assoc-map
- [ find-default default set ]
- [
- generic get "inline" word-prop [
- <predicate-dispatch-engine>
- ] [
- <big-dispatch-engine>
- ] if
- ] bi
- engine>quot
- ] bi
- ] with-scope ;
-
-TUPLE: standard-combination # ;
-
-C: <standard-combination> standard-combination
-
-PREDICATE: standard-generic < generic
- "combination" word-prop standard-combination? ;
-
-PREDICATE: simple-generic < standard-generic
- "combination" word-prop #>> zero? ;
-
-: define-simple-generic ( word -- )
- T{ standard-combination f 0 } define-generic ;
-
-: with-standard ( combination quot -- quot' )
- >r #>> (dispatch#) r> with-variable ;
-
-M: standard-generic mangle-method
- drop ;
-
-M: standard-combination make-default-method
- [ empty-method ] with-standard ;
-
-M: standard-combination perform-combination
- [ single-combination ] with-standard ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-PREDICATE: hook-generic < generic
- "combination" word-prop hook-combination? ;
-
-: with-hook ( combination quot -- quot' )
- 0 (dispatch#) [
- dip var>> [ get ] curry prepend
- ] with-variable ; inline
-
-M: hook-generic mangle-method
- drop [ drop ] prepend ;
-
-M: hook-combination make-default-method
- [ error-method ] with-hook ;
-
-M: hook-combination perform-combination
- [ single-combination ] with-hook ;
-
-GENERIC: dispatch# ( word -- n )
-
-M: word dispatch# "combination" word-prop dispatch# ;
-
-M: standard-combination dispatch# #>> ;
-
-M: hook-combination dispatch# drop 0 ;
-
-M: simple-generic definer drop \ GENERIC: f ;
-
-M: standard-generic definer drop \ GENERIC# f ;
-
-M: hook-generic definer drop \ HOOK: f ;
diff --git a/core/generic/standard/new/new-tests.factor b/core/generic/standard/standard-tests.factor
similarity index 94%
rename from core/generic/standard/new/new-tests.factor
rename to core/generic/standard/standard-tests.factor
index d372926f43..fbca22471c 100644
--- a/core/generic/standard/new/new-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -1,10 +1,8 @@
-IN: generic.standard.new.tests
+IN: generic.standard.tests
USING: tools.test math math.functions math.constants
-generic.standard.new strings sequences arrays kernel accessors
+generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser ;
-<< : GENERIC: CREATE-GENERIC define-simple-generic ; parsing >>
-
GENERIC: lo-tag-test
M: integer lo-tag-test 3 + ;
@@ -24,7 +22,7 @@ GENERIC: hi-tag-test
M: string hi-tag-test ", in bed" append ;
-M: number hi-tag-test 3 + ;
+M: integer hi-tag-test 3 + ;
M: array hi-tag-test [ hi-tag-test ] map ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
old mode 100755
new mode 100644
index b77c0ed9e5..1de41f24ed
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -3,32 +3,23 @@
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic
-classes classes.algebra classes.private ;
+classes classes.algebra classes.private generic.standard.engines
+generic.standard.engines.tag generic.standard.engines.predicate
+generic.standard.engines.tuple accessors ;
IN: generic.standard
-TUPLE: standard-combination # ;
-
-C: <standard-combination> standard-combination
-
-SYMBOL: (dispatch#)
-
-: (picker) ( n -- quot )
+: unpickers
{
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
- } case ;
-
-: picker ( -- quot ) \ (dispatch#) get (picker) ;
-
-: unpickers { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } ; inline
+ [ nip ]
+ [ >r nip r> swap ]
+ [ >r >r nip r> r> -rot ]
+ } ; inline
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
ERROR: no-method object generic ;
-: error-method ( word -- quot )
+: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
: empty-method ( word -- quot )
@@ -38,144 +29,112 @@ ERROR: no-method object generic ;
error-method \ drop prefix , \ if ,
] [ ] make ;
-: class-predicates ( assoc -- assoc )
- [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
-
-: simplify-alist ( class assoc -- default assoc' )
- {
- { [ dup empty? ] [ 2drop [ "Unreachable" throw ] { } ] }
- { [ dup length 1 = ] [ nip first second { } ] }
- { [ 2dup second first class< ] [ 1 tail-slice simplify-alist ] }
- { [ t ] [ nip [ first second ] [ 1 tail-slice ] bi ] }
- } cond ;
-
: default-method ( word -- pair )
"default-method" word-prop
object bootstrap-word swap 2array ;
-: method-alist>quot ( alist base-class -- quot )
- bootstrap-word swap simplify-alist
- class-predicates alist>quot ;
-
-: small-generic ( methods -- def )
- object method-alist>quot ;
-
-: hash-methods ( methods -- buckets )
- V{ } clone [
- tuple bootstrap-word over class< [
- drop t
- ] [
- class-hashes
- ] if
- ] distribute-buckets ;
-
-: class-hash-dispatch-quot ( methods quot picker -- quot )
- >r >r hash-methods r> map
- hash-dispatch-quot r> [ class-hash ] rot 3append ; inline
-
-: big-generic ( methods -- quot )
- [ small-generic ] picker class-hash-dispatch-quot ;
-
-: vtable-class ( n -- class )
- bootstrap-type>class [ \ hi-tag bootstrap-word ] unless* ;
-
-: group-methods ( assoc -- vtable )
- #! Input is a predicate -> method association.
- #! n is vtable size (either num-types or num-tags).
- num-tags get [
- vtable-class
- [ swap first classes-intersect? ] curry subset
- ] with map ;
-
-: build-type-vtable ( alist-seq -- alist-seq )
- dup length [
- vtable-class
- swap simplify-alist
- class-predicates alist>quot
- ] 2map ;
-
-: tag-generic ( methods -- quot )
+: push-method ( method specializer atomic assoc -- )
[
- picker %
- \ tag ,
- group-methods build-type-vtable ,
- \ dispatch ,
- ] [ ] make ;
+ [ H{ } clone <predicate-dispatch-engine> ] unless*
+ [ methods>> set-at ] keep
+ ] change-at ;
-: flatten-method ( class body -- )
- over members pick object bootstrap-word eq? not and [
- >r members r> [ flatten-method ] curry each
- ] [
- swap set
- ] if ;
+: flatten-method ( class method assoc -- )
+ >r >r dup flatten-class keys swap r> r> [
+ >r spin r> push-method
+ ] 3curry each ;
-: flatten-methods ( methods -- newmethods )
- [ [ flatten-method ] assoc-each ] V{ } make-assoc ;
+: flatten-methods ( assoc -- assoc' )
+ H{ } clone [
+ [
+ flatten-method
+ ] curry assoc-each
+ ] keep ;
-: dispatched-types ( methods -- seq )
- keys object bootstrap-word swap remove prune ;
+: <big-dispatch-engine> ( assoc -- engine )
+ flatten-methods
+ convert-tuple-methods
+ convert-hi-tag-methods
+ <lo-tag-dispatch-engine> ;
-: single-combination ( methods -- quot )
- dup length 4 <= [
- small-generic
- ] [
- flatten-methods
- dup dispatched-types [ number class< ] all?
- [ tag-generic ] [ big-generic ] if
- ] if ;
+: find-default ( methods -- quot )
+ #! Side-effects methods.
+ object swap delete-at* [
+ drop generic get "default-method" word-prop 1quotation
+ ] unless ;
-: standard-methods ( word -- alist )
- dup methods swap default-method prefix
- [ 1quotation ] assoc-map ;
+GENERIC: mangle-method ( method generic -- quot )
-M: standard-combination make-default-method
- standard-combination-# (dispatch#)
- [ empty-method ] with-variable ;
-
-M: standard-combination perform-combination
- standard-combination-# (dispatch#) [
- [ standard-methods ] keep "inline" word-prop
- [ small-generic ] [ single-combination ] if
- ] with-variable ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-: with-hook ( combination quot -- quot' )
- 0 (dispatch#) [
- swap slip
- hook-combination-var [ get ] curry
- prepend
- ] with-variable ; inline
-
-M: hook-combination make-default-method
- [ error-method ] with-hook ;
-
-M: hook-combination perform-combination
+: single-combination ( words -- quot )
[
- standard-methods
- [ [ drop ] prepend ] assoc-map
- single-combination
- ] with-hook ;
+ object bootstrap-word assumed set
+ [ generic set ]
+ [
+ "methods" word-prop
+ [ generic get mangle-method ] assoc-map
+ [ find-default default set ]
+ [
+ generic get "inline" word-prop [
+ <predicate-dispatch-engine>
+ ] [
+ <big-dispatch-engine>
+ ] if
+ ] bi
+ engine>quot
+ ] bi
+ ] with-scope ;
-: define-simple-generic ( word -- )
- T{ standard-combination f 0 } define-generic ;
+TUPLE: standard-combination # ;
+
+C: <standard-combination> standard-combination
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
PREDICATE: simple-generic < standard-generic
- "combination" word-prop standard-combination-# zero? ;
+ "combination" word-prop #>> zero? ;
+
+: define-simple-generic ( word -- )
+ T{ standard-combination f 0 } define-generic ;
+
+: with-standard ( combination quot -- quot' )
+ >r #>> (dispatch#) r> with-variable ;
+
+M: standard-generic mangle-method
+ drop 1quotation ;
+
+M: standard-combination make-default-method
+ [ empty-method ] with-standard ;
+
+M: standard-combination perform-combination
+ [ single-combination ] with-standard ;
+
+TUPLE: hook-combination var ;
+
+C: <hook-combination> hook-combination
PREDICATE: hook-generic < generic
"combination" word-prop hook-combination? ;
+: with-hook ( combination quot -- quot' )
+ 0 (dispatch#) [
+ dip var>> [ get ] curry prepend
+ ] with-variable ; inline
+
+M: hook-generic mangle-method
+ drop 1quotation [ drop ] prepend ;
+
+M: hook-combination make-default-method
+ [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+ [ single-combination ] with-hook ;
+
GENERIC: dispatch# ( word -- n )
M: word dispatch# "combination" word-prop dispatch# ;
-M: standard-combination dispatch# standard-combination-# ;
+M: standard-combination dispatch# #>> ;
M: hook-combination dispatch# drop 0 ;
diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor
index fde8728858..a13e1331fa 100755
--- a/core/mirrors/mirrors.factor
+++ b/core/mirrors/mirrors.factor
@@ -48,27 +48,6 @@ M: mirror assoc-size mirror-slots length ;
INSTANCE: mirror assoc
-TUPLE: enum seq ;
-
-C: <enum> enum
-
-M: enum at*
- enum-seq 2dup bounds-check?
- [ nth t ] [ 2drop f f ] if ;
-
-M: enum set-at enum-seq set-nth ;
-
-M: enum delete-at enum-seq delete-nth ;
-
-M: enum >alist ( enum -- alist )
- enum-seq dup length swap 2array flip ;
-
-M: enum assoc-size enum-seq length ;
-
-M: enum clear-assoc enum-seq delete-all ;
-
-INSTANCE: enum assoc
-
: sort-assoc ( assoc -- alist )
>alist
[ dup first unparse-short swap ] { } map>assoc
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index cbdb1b9ec4..d115d0a1c6 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces sequences vectors words strings layouts combinators
-sequences.private classes generic.standard assocs ;
+sequences.private classes generic.standard
+generic.standard.engines assocs ;
IN: optimizer.specializers
: (make-specializer) ( class picker -- quot )
From 11feb563ebdb1ca453ac1d96e8391a9b07478bf1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 13:11:55 -0500
Subject: [PATCH 047/288] move singletons to core
---
core/bootstrap/syntax.factor | 1 +
{extra => core}/classes/singleton/authors.txt | 0
{extra => core}/classes/singleton/singleton-docs.factor | 0
{extra => core}/classes/singleton/singleton-tests.factor | 2 +-
{extra => core}/classes/singleton/singleton.factor | 3 ---
core/syntax/syntax.factor | 6 +++++-
6 files changed, 7 insertions(+), 5 deletions(-)
rename {extra => core}/classes/singleton/authors.txt (100%)
rename {extra => core}/classes/singleton/singleton-docs.factor (100%)
rename {extra => core}/classes/singleton/singleton-tests.factor (75%)
rename {extra => core}/classes/singleton/singleton.factor (92%)
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index e7e90d8dd0..e5a439c32b 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -43,6 +43,7 @@ IN: bootstrap.syntax
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
+ "SINLETON:"
"SYMBOL:"
"TUPLE:"
"T{"
diff --git a/extra/classes/singleton/authors.txt b/core/classes/singleton/authors.txt
similarity index 100%
rename from extra/classes/singleton/authors.txt
rename to core/classes/singleton/authors.txt
diff --git a/extra/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor
similarity index 100%
rename from extra/classes/singleton/singleton-docs.factor
rename to core/classes/singleton/singleton-docs.factor
diff --git a/extra/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
similarity index 75%
rename from extra/classes/singleton/singleton-tests.factor
rename to core/classes/singleton/singleton-tests.factor
index 586724ee3b..11a2a2d166 100644
--- a/extra/classes/singleton/singleton-tests.factor
+++ b/core/classes/singleton/singleton-tests.factor
@@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- )
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton? ] unit-test
-[ "USING: classes.singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
+[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
diff --git a/extra/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor
similarity index 92%
rename from extra/classes/singleton/singleton.factor
rename to core/classes/singleton/singleton.factor
index 61a519679c..13fd242dad 100755
--- a/extra/classes/singleton/singleton.factor
+++ b/core/classes/singleton/singleton.factor
@@ -15,8 +15,5 @@ PREDICATE: singleton < predicate-class
\ singleton
over [ eq? ] curry define-predicate-class ;
-: SINGLETON:
- scan define-singleton ; parsing
-
M: singleton see-class* ( class -- )
<colon \ SINGLETON: pprint-word pprint-word ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 19fdf0e45f..1191752ed7 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -6,7 +6,7 @@ namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units
-combinators debugger ;
+combinators debugger classes.singleton ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@@ -154,6 +154,10 @@ IN: bootstrap.syntax
parse-definition define-predicate-class
] define-syntax
+ "SINGLETON:" [
+ scan define-singleton
+ ] define-syntax
+
"TUPLE:" [
parse-tuple-definition define-tuple-class
] define-syntax
From e62c3c323c99490e9e0aebfafaeabb1b9e3ed7d4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 13:13:56 -0500
Subject: [PATCH 048/288] fix unit test
---
core/classes/singleton/singleton-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
index 11a2a2d166..92a9877477 100644
--- a/core/classes/singleton/singleton-tests.factor
+++ b/core/classes/singleton/singleton-tests.factor
@@ -4,7 +4,7 @@ IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
[ t ] [ bzzt bzzt eq? ] unit-test
-GENERIC: zammo ( obj -- )
+GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
From c89ee5bfccfb8d6e19906841b3dd5fc06917b74c Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Wed, 2 Apr 2008 15:11:11 -0500
Subject: [PATCH 049/288] add textwrangler binding
---
extra/editors/textwrangler/authors.txt | 1 +
extra/editors/textwrangler/summary.txt | 1 +
extra/editors/textwrangler/textwrangler.factor | 13 +++++++++++++
3 files changed, 15 insertions(+)
create mode 100644 extra/editors/textwrangler/authors.txt
create mode 100644 extra/editors/textwrangler/summary.txt
create mode 100644 extra/editors/textwrangler/textwrangler.factor
diff --git a/extra/editors/textwrangler/authors.txt b/extra/editors/textwrangler/authors.txt
new file mode 100644
index 0000000000..b4a113da41
--- /dev/null
+++ b/extra/editors/textwrangler/authors.txt
@@ -0,0 +1 @@
+Ben Schlingelhof
diff --git a/extra/editors/textwrangler/summary.txt b/extra/editors/textwrangler/summary.txt
new file mode 100644
index 0000000000..cf502f96e5
--- /dev/null
+++ b/extra/editors/textwrangler/summary.txt
@@ -0,0 +1 @@
+Textwrangler editor integration
diff --git a/extra/editors/textwrangler/textwrangler.factor b/extra/editors/textwrangler/textwrangler.factor
new file mode 100644
index 0000000000..e97dadcdcb
--- /dev/null
+++ b/extra/editors/textwrangler/textwrangler.factor
@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Ben Schlingelhof.
+! See http://factorcode.org/license.txt for BSD license.
+USING: definitions io.launcher kernel parser words sequences
+math math.parser namespaces editors ;
+IN: editors.textwrangler
+
+: tw ( file line -- )
+ [ "edit +" % # " " % % ] "" make run-process drop ;
+
+: tw-word ( word -- )
+ where first2 tw ;
+
+[ tw ] edit-hook set-global
From 47b54b13072b91c4b3bdf2ecfb7673bd77aedaea Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 15:41:29 -0500
Subject: [PATCH 050/288] add singletons to core
---
core/bootstrap/syntax.factor | 2 +-
core/classes/singleton/singleton-tests.factor | 2 +-
core/classes/singleton/singleton.factor | 16 ++++------------
core/prettyprint/prettyprint.factor | 5 ++++-
core/syntax/syntax.factor | 7 ++++---
5 files changed, 14 insertions(+), 18 deletions(-)
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index e5a439c32b..fb5923382e 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -43,7 +43,7 @@ IN: bootstrap.syntax
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
- "SINLETON:"
+ "SINGLETON:"
"SYMBOL:"
"TUPLE:"
"T{"
diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
index 92a9877477..2ed51abb93 100644
--- a/core/classes/singleton/singleton-tests.factor
+++ b/core/classes/singleton/singleton-tests.factor
@@ -8,5 +8,5 @@ GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
-[ t ] [ omg singleton? ] unit-test
+[ t ] [ omg singleton-class? ] unit-test
[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor
index 13fd242dad..65d7422ed7 100755
--- a/core/classes/singleton/singleton.factor
+++ b/core/classes/singleton/singleton.factor
@@ -1,19 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.predicate kernel namespaces parser quotations
-sequences words prettyprint prettyprint.backend prettyprint.sections
-compiler.units classes ;
+USING: classes.predicate kernel sequences words ;
IN: classes.singleton
-PREDICATE: singleton < predicate-class
+PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ]
[ [ eq? ] curry ] bi sequence= ;
-: define-singleton ( token -- )
- create-class-in
- dup save-location
- \ singleton
- over [ eq? ] curry define-predicate-class ;
-
-M: singleton see-class* ( class -- )
- <colon \ SINGLETON: pprint-word pprint-word ;
+: define-singleton-class ( word -- )
+ \ word over [ eq? ] curry define-predicate-class ;
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index d294f95be6..fd7133053a 100755
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -7,7 +7,7 @@ vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects classes.tuple io.files classes continuations
hashtables classes.mixin classes.union classes.predicate
-combinators quotations ;
+classes.singleton combinators quotations ;
: make-pprint ( obj quot -- block in use )
[
@@ -254,6 +254,9 @@ M: predicate-class see-class*
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
+M: singleton-class see-class* ( class -- )
+ \ SINGLETON: pprint-word pprint-word ;
+
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 1191752ed7..90bb1f0a6d 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -5,8 +5,8 @@ byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
-classes.union classes.mixin classes.predicate compiler.units
-combinators debugger classes.singleton ;
+classes.union classes.mixin classes.predicate classes.singleton
+compiler.units combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@@ -155,7 +155,8 @@ IN: bootstrap.syntax
] define-syntax
"SINGLETON:" [
- scan define-singleton
+ scan create-class-in
+ dup save-location define-singleton-class
] define-syntax
"TUPLE:" [
From 8b22f4436bcd57ae1c2384b3ce4b5b5056c7011a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 16:32:10 -0500
Subject: [PATCH 051/288] t is now a singleton
---
core/syntax/syntax.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 90bb1f0a6d..37df12e9a7 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -55,7 +55,7 @@ IN: bootstrap.syntax
"BIN:" [ 2 parse-base ] define-syntax
"f" [ f parsed ] define-syntax
- "t" "syntax" lookup define-symbol
+ "t" "syntax" lookup define-singleton-class
"CHAR:" [
scan {
From 7ec68e0aa7fce17bee0ea28fde27c0224c48ed8c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 16:32:34 -0500
Subject: [PATCH 052/288] singleton docs
---
core/classes/classes-docs.factor | 1 +
core/classes/singleton/singleton-docs.factor | 16 +++++++++++++++-
2 files changed, 16 insertions(+), 1 deletion(-)
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 9573de8949..5cc815fc36 100755
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -47,6 +47,7 @@ $nl
"Other sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
+{ $subsection "singletons" }
{ $subsection "mixins" }
{ $subsection "predicates" }
"Classes can be inspected and operated upon:"
diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor
index 95b5b6af18..8548f84a3a 100644
--- a/core/classes/singleton/singleton-docs.factor
+++ b/core/classes/singleton/singleton-docs.factor
@@ -1,6 +1,11 @@
USING: help.markup help.syntax kernel words ;
IN: classes.singleton
+ARTICLE: "singletons" "Singleton classes"
+"A singleton is a class with only one instance and with no state. Methods may dispatch off of singleton classes."
+{ $subsection POSTPONE: SINGLETON: }
+{ $subsection define-singleton-class } ;
+
HELP: SINGLETON:
{ $syntax "SINGLETON: class"
} { $values
@@ -8,7 +13,16 @@ HELP: SINGLETON:
} { $description
"Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton."
} { $examples
- { $example "USING: singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
+ { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
} { $see-also
POSTPONE: PREDICATE:
} ;
+
+HELP: define-singleton-class
+{ $values { "word" "a new word" } }
+{ $description
+ "Defines a newly created word to be a singleton class." } ;
+
+{ POSTPONE: SINGLETON: define-singleton-class } related-words
+
+ABOUT: "singletons"
From d736a8660da45d0778d340f504f6c9cacc4cb6e2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 16:32:58 -0500
Subject: [PATCH 053/288] cpu is now a singleton
---
core/bootstrap/compiler/compiler.factor | 2 +-
core/bootstrap/image/image.factor | 3 ++-
core/system/system.factor | 32 +++++++++++++++++++++++--
3 files changed, 33 insertions(+), 4 deletions(-)
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 7d4db3c473..ab09279a7b 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -14,7 +14,7 @@ IN: bootstrap.compiler
"alien.remote-control" require
] unless
-"cpu." cpu append require
+"cpu." cpu word-name append require
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index fc963683b6..e2fa5833eb 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -12,7 +12,8 @@ io.encodings.binary ;
IN: bootstrap.image
: my-arch ( -- arch )
- cpu dup "ppc" = [ >r os "-" r> 3append ] when ;
+ cpu word-name
+ dup "ppc" = [ >r os "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
diff --git a/core/system/system.factor b/core/system/system.factor
index 87bbcfdc3f..5a0faeece9 100755
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -2,12 +2,40 @@
! See http://factorcode.org/license.txt for BSD license.
IN: system
USING: kernel kernel.private sequences math namespaces
-splitting assocs system.private layouts ;
+init splitting assocs system.private layouts words ;
-: cpu ( -- cpu ) 8 getenv ; foldable
+! : cpu ( -- cpu ) 8 getenv ; foldable
: os ( -- os ) 9 getenv ; foldable
+SINGLETON: x86.32
+SINGLETON: x86.64
+SINGLETON: arm
+SINGLETON: ppc
+
+: cpu ( -- class ) \ cpu get ;
+
+! SINGLETON: winnt
+! SINGLETON: wince
+
+! MIXIN: windows
+! INSTANCE: winnt windows
+! INSTANCE: wince windows
+
+! SINGLETON: freebsd
+! SINGLETON: netbsd
+! SINGLETON: openbsd
+! SINGLETON: solaris
+! SINGLETON: macosx
+! SINGLETON: linux
+
+! : os ( -- class ) \ os get ;
+
+[
+ 8 getenv "system" lookup \ cpu set-global
+ ! 9 getenv "system" lookup \ os set-global
+] "system" add-init-hook
+
: image ( -- path ) 13 getenv ;
: vm ( -- path ) 14 getenv ;
From 7cb3fdcfec85f100a33f0a81b763a54aa75d19c1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 17:07:38 -0500
Subject: [PATCH 054/288] compiler backend now dispatches on the os
---
core/cpu/architecture/architecture.factor | 94 +++++++++----------
core/cpu/ppc/allot/allot.factor | 4 +-
core/cpu/ppc/architecture/architecture.factor | 86 +++++++++--------
core/cpu/ppc/ppc.factor | 2 -
core/cpu/x86/32/32.factor | 59 ++++++------
core/cpu/x86/64/64.factor | 63 ++++++-------
core/cpu/x86/allot/allot.factor | 4 +-
core/cpu/x86/architecture/architecture.factor | 72 +++++++-------
core/system/system.factor | 22 ++++-
9 files changed, 200 insertions(+), 206 deletions(-)
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 8d1e1f281f..4670cf86d2 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien
byte-arrays bit-arrays float-arrays combinators words ;
IN: cpu.architecture
-SYMBOL: compiler-backend
-
! A pseudo-register class for parameters spilled on the stack
TUPLE: stack-params ;
@@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs )
! Load a literal (immediate or indirect)
GENERIC# load-literal 1 ( obj vreg -- )
-HOOK: load-indirect compiler-backend ( obj reg -- )
+HOOK: load-indirect cpu ( obj reg -- )
-HOOK: stack-frame compiler-backend ( frame-size -- n )
+HOOK: stack-frame cpu ( frame-size -- n )
: stack-frame* ( -- n )
\ stack-frame get stack-frame ;
! Set up caller stack frame
-HOOK: %prologue compiler-backend ( n -- )
+HOOK: %prologue cpu ( n -- )
: %prologue-later \ %prologue-later , ;
! Tear down stack frame
-HOOK: %epilogue compiler-backend ( n -- )
+HOOK: %epilogue cpu ( n -- )
: %epilogue-later \ %epilogue-later , ;
! Store word XT in stack frame
-HOOK: %save-word-xt compiler-backend ( -- )
+HOOK: %save-word-xt cpu ( -- )
! Store dispatch branch XT in stack frame
-HOOK: %save-dispatch-xt compiler-backend ( -- )
+HOOK: %save-dispatch-xt cpu ( -- )
M: object %save-dispatch-xt %save-word-xt ;
! Call another word
-HOOK: %call compiler-backend ( word -- )
+HOOK: %call cpu ( word -- )
! Local jump for branches
-HOOK: %jump-label compiler-backend ( label -- )
+HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
-HOOK: %jump-t compiler-backend ( label -- )
+HOOK: %jump-t cpu ( label -- )
-HOOK: %dispatch compiler-backend ( -- )
+HOOK: %dispatch cpu ( -- )
-HOOK: %dispatch-label compiler-backend ( word -- )
+HOOK: %dispatch-label cpu ( word -- )
! Return to caller
-HOOK: %return compiler-backend ( -- )
+HOOK: %return cpu ( -- )
! Change datastack height
-HOOK: %inc-d compiler-backend ( n -- )
+HOOK: %inc-d cpu ( n -- )
! Change callstack height
-HOOK: %inc-r compiler-backend ( n -- )
+HOOK: %inc-r cpu ( n -- )
! Load stack into vreg
-HOOK: %peek compiler-backend ( vreg loc -- )
+HOOK: %peek cpu ( vreg loc -- )
! Store vreg to stack
-HOOK: %replace compiler-backend ( vreg loc -- )
+HOOK: %replace cpu ( vreg loc -- )
! Box and unbox floats
-HOOK: %unbox-float compiler-backend ( dst src -- )
-HOOK: %box-float compiler-backend ( dst src -- )
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src -- )
! FFI stuff
! Is this integer small enough to appear in value template
! slots?
-HOOK: small-enough? compiler-backend ( n -- ? )
+HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? compiler-backend ( size -- ? )
+HOOK: struct-small-enough? cpu ( size -- ? )
! Do we pass explode value structs?
-HOOK: value-structs? compiler-backend ( -- ? )
+HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? compiler-backend ( -- ? )
+HOOK: fp-shadows-int? cpu ( -- ? )
-HOOK: %prepare-unbox compiler-backend ( -- )
+HOOK: %prepare-unbox cpu ( -- )
-HOOK: %unbox compiler-backend ( n reg-class func -- )
+HOOK: %unbox cpu ( n reg-class func -- )
-HOOK: %unbox-long-long compiler-backend ( n func -- )
+HOOK: %unbox-long-long cpu ( n func -- )
-HOOK: %unbox-small-struct compiler-backend ( size -- )
+HOOK: %unbox-small-struct cpu ( size -- )
-HOOK: %unbox-large-struct compiler-backend ( n size -- )
+HOOK: %unbox-large-struct cpu ( n size -- )
-HOOK: %box compiler-backend ( n reg-class func -- )
+HOOK: %box cpu ( n reg-class func -- )
-HOOK: %box-long-long compiler-backend ( n func -- )
+HOOK: %box-long-long cpu ( n func -- )
-HOOK: %prepare-box-struct compiler-backend ( size -- )
+HOOK: %prepare-box-struct cpu ( size -- )
-HOOK: %box-small-struct compiler-backend ( size -- )
+HOOK: %box-small-struct cpu ( size -- )
-HOOK: %box-large-struct compiler-backend ( n size -- )
+HOOK: %box-large-struct cpu ( n size -- )
GENERIC: %save-param-reg ( stack reg reg-class -- )
GENERIC: %load-param-reg ( stack reg reg-class -- )
-HOOK: %prepare-alien-invoke compiler-backend ( -- )
+HOOK: %prepare-alien-invoke cpu ( -- )
-HOOK: %prepare-var-args compiler-backend ( -- )
+HOOK: %prepare-var-args cpu ( -- )
M: object %prepare-var-args ;
-HOOK: %alien-invoke compiler-backend ( function library -- )
+HOOK: %alien-invoke cpu ( function library -- )
-HOOK: %cleanup compiler-backend ( alien-node -- )
+HOOK: %cleanup cpu ( alien-node -- )
-HOOK: %alien-callback compiler-backend ( quot -- )
+HOOK: %alien-callback cpu ( quot -- )
-HOOK: %callback-value compiler-backend ( ctype -- )
+HOOK: %callback-value cpu ( ctype -- )
! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind compiler-backend ( n -- )
+HOOK: %unwind cpu ( n -- )
-HOOK: %prepare-alien-indirect compiler-backend ( -- )
+HOOK: %prepare-alien-indirect cpu ( -- )
-HOOK: %alien-indirect compiler-backend ( -- )
+HOOK: %alien-indirect cpu ( -- )
M: stack-params param-reg drop ;
@@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ;
] if-small-struct ;
! Alien accessors
-HOOK: %unbox-byte-array compiler-backend ( dst src -- )
+HOOK: %unbox-byte-array cpu ( dst src -- )
-HOOK: %unbox-alien compiler-backend ( dst src -- )
+HOOK: %unbox-alien cpu ( dst src -- )
-HOOK: %unbox-f compiler-backend ( dst src -- )
+HOOK: %unbox-f cpu ( dst src -- )
-HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-HOOK: %box-alien compiler-backend ( dst src -- )
+HOOK: %box-alien cpu ( dst src -- )
: operand ( var -- op ) get v>operand ; inline
diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor
index 6c37fce4f1..34ea82dc4e 100755
--- a/core/cpu/ppc/allot/allot.factor
+++ b/core/cpu/ppc/allot/allot.factor
@@ -32,7 +32,7 @@ IN: cpu.ppc.allot
12 11 float tag-number ORI
f fresh-object ;
-M: ppc-backend %box-float ( dst src -- )
+M: ppc %box-float ( dst src -- )
[ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- )
@@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- )
"end" resolve-label
] with-scope ;
-M: ppc-backend %box-alien ( dst src -- )
+M: ppc %box-alien ( dst src -- )
{ "end" "f" } [ define-label ] each
0 over v>operand 0 CMPI
"f" get BEQ
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index 903ac32df9..8055e4ff6e 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -7,8 +7,6 @@ layouts classes words.private alien combinators
compiler.constants ;
IN: cpu.ppc.architecture
-TUPLE: ppc-backend ;
-
! PowerPC register assignments
! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs
@@ -44,7 +42,7 @@ TUPLE: ppc-backend ;
: xt-save ( n -- i ) 2 cells - ;
-M: ppc-backend stack-frame ( n -- i )
+M: ppc stack-frame ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
@@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
M: immediate load-literal
[ v>operand ] bi@ LOAD ;
-M: ppc-backend load-indirect ( obj reg -- )
+M: ppc load-indirect ( obj reg -- )
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
dup 0 LWZ ;
-M: ppc-backend %save-word-xt ( -- )
+M: ppc %save-word-xt ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
-M: ppc-backend %prologue ( n -- )
+M: ppc %prologue ( n -- )
0 MFLR
1 1 pick neg ADDI
11 1 pick xt-save STW
@@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- )
11 1 pick next-save STW
0 1 rot lr-save + STW ;
-M: ppc-backend %epilogue ( n -- )
+M: ppc %epilogue ( n -- )
#! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0,
@@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- )
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
-M: ppc-backend %call ( label -- ) BL ;
+M: ppc %call ( label -- ) BL ;
-M: ppc-backend %jump-label ( label -- ) B ;
+M: ppc %jump-label ( label -- ) B ;
-M: ppc-backend %jump-t ( label -- )
+M: ppc %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
-M: ppc-backend %dispatch ( -- )
+M: ppc %dispatch ( -- )
[
%epilogue-later
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
@@ -124,25 +122,25 @@ M: ppc-backend %dispatch ( -- )
{ +scratch+ { { f "offset" } } }
} with-template ;
-M: ppc-backend %dispatch-label ( word -- )
+M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
-M: ppc-backend %return ( -- ) %epilogue-later BLR ;
+M: ppc %return ( -- ) %epilogue-later BLR ;
-M: ppc-backend %unwind drop %return ;
+M: ppc %unwind drop %return ;
-M: ppc-backend %peek ( vreg loc -- )
+M: ppc %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ;
-M: ppc-backend %replace
+M: ppc %replace
>r v>operand r> loc>operand STW ;
-M: ppc-backend %unbox-float ( dst src -- )
+M: ppc %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset LFD ;
-M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
+M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
-M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
+M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
M: int-regs %save-param-reg drop 1 rot local@ STW ;
@@ -166,19 +164,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- )
0 1 rot param@ stack-frame* + LWZ
0 1 rot local@ STW ;
-M: ppc-backend %prepare-unbox ( -- )
+M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
-M: ppc-backend %unbox ( n reg-class func -- )
+M: ppc %unbox ( n reg-class func -- )
! Value must be in r3
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-M: ppc-backend %unbox-long-long ( n func -- )
+M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the unboxer
f %alien-invoke
@@ -188,7 +186,7 @@ M: ppc-backend %unbox-long-long ( n func -- )
4 1 rot cell + local@ STW
] when* ;
-M: ppc-backend %unbox-large-struct ( n size -- )
+M: ppc %unbox-large-struct ( n size -- )
! Value must be in r3
! Compute destination address
4 1 roll local@ ADDI
@@ -197,7 +195,7 @@ M: ppc-backend %unbox-large-struct ( n size -- )
! Call the function
"to_value_struct" f %alien-invoke ;
-M: ppc-backend %box ( n reg-class func -- )
+M: ppc %box ( n reg-class func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
@@ -205,7 +203,7 @@ M: ppc-backend %box ( n reg-class func -- )
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ;
-M: ppc-backend %box-long-long ( n func -- )
+M: ppc %box-long-long ( n func -- )
>r [
3 1 pick local@ LWZ
4 1 rot cell + local@ LWZ
@@ -215,12 +213,12 @@ M: ppc-backend %box-long-long ( n func -- )
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
-M: ppc-backend %prepare-box-struct ( size -- )
+M: ppc %prepare-box-struct ( size -- )
#! Compute target address for value struct return
3 1 rot f struct-return@ ADDI
3 1 0 local@ STW ;
-M: ppc-backend %box-large-struct ( n size -- )
+M: ppc %box-large-struct ( n size -- )
#! If n = f, then we're boxing a returned struct
[ swap struct-return@ ] keep
! Compute destination address
@@ -230,7 +228,7 @@ M: ppc-backend %box-large-struct ( n size -- )
! Call the function
"box_value_struct" f %alien-invoke ;
-M: ppc-backend %prepare-alien-invoke
+M: ppc %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
@@ -240,20 +238,20 @@ M: ppc-backend %prepare-alien-invoke
ds-reg 11 8 STW
rs-reg 11 12 STW ;
-M: ppc-backend %alien-invoke ( symbol dll -- )
+M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym (%call) ;
-M: ppc-backend %alien-callback ( quot -- )
+M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
-M: ppc-backend %prepare-alien-indirect ( -- )
+M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
3 1 cell temp@ STW ;
-M: ppc-backend %alien-indirect ( -- )
+M: ppc %alien-indirect ( -- )
11 1 cell temp@ LWZ (%call) ;
-M: ppc-backend %callback-value ( ctype -- )
+M: ppc %callback-value ( ctype -- )
! Save top of data stack
3 ds-reg 0 LWZ
3 1 0 local@ STW
@@ -264,7 +262,7 @@ M: ppc-backend %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
-M: ppc-backend %cleanup ( alien-node -- ) drop ;
+M: ppc %cleanup ( alien-node -- ) drop ;
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
@@ -272,34 +270,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
-M: ppc-backend value-structs?
+M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
linux? not ;
-M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
+M: ppc fp-shadows-int? ( -- ? ) macosx? ;
-M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ;
+M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
-M: ppc-backend struct-small-enough? ( size -- ? ) drop f ;
+M: ppc struct-small-enough? ( size -- ? ) drop f ;
-M: ppc-backend %box-small-struct
+M: ppc %box-small-struct
drop "No small structs" throw ;
-M: ppc-backend %unbox-small-struct
+M: ppc %unbox-small-struct
drop "No small structs" throw ;
! Alien intrinsics
-M: ppc-backend %unbox-byte-array ( dst src -- )
+M: ppc %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset ADDI ;
-M: ppc-backend %unbox-alien ( dst src -- )
+M: ppc %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset LWZ ;
-M: ppc-backend %unbox-f ( dst src -- )
+M: ppc %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
-M: ppc-backend %unbox-any-c-ptr ( dst src -- )
+M: ppc %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12
0 12 LI
diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor
index 75de49acda..da17da9185 100755
--- a/core/cpu/ppc/ppc.factor
+++ b/core/cpu/ppc/ppc.factor
@@ -12,8 +12,6 @@ namespaces alien.c-types kernel system combinators ;
] }
} cond
-T{ ppc-backend } compiler-backend set-global
-
macosx? [
4 "double" c-type set-c-type-align
] when
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index f4af421cdd..3ebee73cbf 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -8,23 +8,20 @@ alien.compiler combinators command-line
compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32
-PREDICATE: x86-32-backend < x86-backend
- x86-backend-cell 4 = ;
-
! We implement the FFI for Linux, OS X and Windows all at once.
! OS X requires that the stack be 16-byte aligned, and we do
! this on all platforms, sacrificing some stack space for
! code simplicity.
-M: x86-32-backend ds-reg ESI ;
-M: x86-32-backend rs-reg EDI ;
-M: x86-32-backend stack-reg ESP ;
-M: x86-32-backend xt-reg ECX ;
-M: x86-32-backend stack-save-reg EDX ;
+M: x86.32 ds-reg ESI ;
+M: x86.32 rs-reg EDI ;
+M: x86.32 stack-reg ESP ;
+M: x86.32 xt-reg ECX ;
+M: x86.32 stack-save-reg EDX ;
M: temp-reg v>operand drop EBX ;
-M: x86-32-backend %alien-invoke ( symbol dll -- )
+M: x86.32 %alien-invoke ( symbol dll -- )
(CALL) rel-dlsym ;
! On x86, parameters are never passed in registers.
@@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
! On x86, we can always use an address as an operand
! directly.
-M: x86-32-backend address-operand ;
+M: x86.32 address-operand ;
-M: x86-32-backend fixnum>slot@ 1 SHR ;
+M: x86.32 fixnum>slot@ 1 SHR ;
-M: x86-32-backend prepare-division CDQ ;
+M: x86.32 prepare-division CDQ ;
-M: x86-32-backend load-indirect
+M: x86.32 load-indirect
0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ;
-M: x86-32-backend %prepare-unbox ( -- )
+M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
@@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- )
f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %unbox ( n reg-class func -- )
+M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
@@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- )
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
-M: x86-32-backend %unbox-long-long ( n func -- )
+M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
@@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- )
cell + stack@ EDX MOV
] when* ;
-M: x86-32-backend %unbox-struct-2
+M: x86.32 %unbox-struct-2
#! Alien must be in EAX.
4 [
EAX PUSH
@@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2
EAX EAX [] MOV
] with-aligned-stack ;
-M: x86-32-backend %unbox-large-struct ( n size -- )
+M: x86.32 %unbox-large-struct ( n size -- )
#! Alien must be in EAX.
! Compute destination address
ECX ESP roll [+] LEA
@@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- )
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
push-return-reg ;
-M: x86-32-backend %box ( n reg-class func -- )
+M: x86.32 %box ( n reg-class func -- )
over reg-size [
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
@@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- )
EDX PUSH
EAX PUSH ;
-M: x86-32-backend %box-long-long ( n func -- )
+M: x86.32 %box-long-long ( n func -- )
8 [
>r (%box-long-long) r> f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %box-large-struct ( n size -- )
+M: x86.32 %box-large-struct ( n size -- )
! Compute destination address
[ swap struct-return@ ] keep
ECX ESP roll [+] LEA
@@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- )
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %prepare-box-struct ( size -- )
+M: x86.32 %prepare-box-struct ( size -- )
! Compute target address for value struct return
EAX ESP rot f struct-return@ [+] LEA
! Store it as the first parameter
ESP [] EAX MOV ;
-M: x86-32-backend %unbox-struct-1
+M: x86.32 %unbox-struct-1
#! Alien must be in EAX.
4 [
EAX PUSH
@@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1
EAX EAX [] MOV
] with-aligned-stack ;
-M: x86-32-backend %box-small-struct ( size -- )
+M: x86.32 %box-small-struct ( size -- )
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
12 [
PUSH
@@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- )
"box_small_struct" f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %prepare-alien-indirect ( -- )
+M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ EAX MOV ;
-M: x86-32-backend %alien-indirect ( -- )
+M: x86.32 %alien-indirect ( -- )
cell temp@ CALL ;
-M: x86-32-backend %alien-callback ( quot -- )
+M: x86.32 %alien-callback ( quot -- )
4 [
EAX load-indirect
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %callback-value ( ctype -- )
+M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
! Save top of data stack
@@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- )
! Unbox EAX
unbox-return ;
-M: x86-32-backend %cleanup ( alien-node -- )
+M: x86.32 %cleanup ( alien-node -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
@@ -254,7 +251,7 @@ M: x86-32-backend %cleanup ( alien-node -- )
}
} cond ;
-M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ;
+M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
windows? [
cell "longlong" c-type set-c-type-align
@@ -265,8 +262,6 @@ windows? [
4 "double" c-type set-c-type-align
] unless
-T{ x86-backend f 4 } compiler-backend set-global
-
: sse2? "Intrinsic" throw ;
\ sse2? [
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index c2af60e983..d3ccffe00e 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64
-PREDICATE: amd64-backend < x86-backend
- x86-backend-cell 8 = ;
-
-M: amd64-backend ds-reg R14 ;
-M: amd64-backend rs-reg R15 ;
-M: amd64-backend stack-reg RSP ;
-M: amd64-backend xt-reg RCX ;
-M: amd64-backend stack-save-reg RSI ;
+M: x86.64 ds-reg R14 ;
+M: x86.64 rs-reg R15 ;
+M: x86.64 stack-reg RSP ;
+M: x86.64 xt-reg RCX ;
+M: x86.64 stack-save-reg RSI ;
M: temp-reg v>operand drop RBX ;
@@ -34,18 +31,18 @@ M: float-regs vregs
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-M: amd64-backend address-operand ( address -- operand )
+M: x86.64 address-operand ( address -- operand )
#! On AMD64, we have to load 64-bit addresses into a
#! scratch register first. The usage of R11 here is a hack.
#! This word can only be called right before a subroutine
#! call, where all vregs have been flushed anyway.
temp-reg v>operand [ swap MOV ] keep ;
-M: amd64-backend fixnum>slot@ drop ;
+M: x86.64 fixnum>slot@ drop ;
-M: amd64-backend prepare-division CQO ;
+M: x86.64 prepare-division CQO ;
-M: amd64-backend load-indirect ( literal reg -- )
+M: x86.64 load-indirect ( literal reg -- )
0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg
@@ -56,27 +53,27 @@ M: stack-params %load-param-reg
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
-M: amd64-backend %prepare-unbox ( -- )
+M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
RDI R14 [] MOV
R14 cell SUB ;
-M: amd64-backend %unbox ( n reg-class func -- )
+M: x86.64 %unbox ( n reg-class func -- )
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-M: amd64-backend %unbox-long-long ( n func -- )
+M: x86.64 %unbox-long-long ( n func -- )
T{ int-regs } swap %unbox ;
-M: amd64-backend %unbox-struct-1 ( -- )
+M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load first cell
RAX RAX [] MOV ;
-M: amd64-backend %unbox-struct-2 ( -- )
+M: x86.64 %unbox-struct-2 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load second cell
@@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- )
! Load first cell
RAX RAX [] MOV ;
-M: amd64-backend %unbox-large-struct ( n size -- )
+M: x86.64 %unbox-large-struct ( n size -- )
! Source is in RDI
! Load destination address
RSI RSP roll [+] LEA
@@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- )
0 over param-reg swap return-reg
2dup eq? [ 2drop ] [ MOV ] if ;
-M: amd64-backend %box ( n reg-class func -- )
+M: x86.64 %box ( n reg-class func -- )
rot [
rot [ 0 swap param-reg ] keep %load-param-reg
] [
@@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- )
] if*
f %alien-invoke ;
-M: amd64-backend %box-long-long ( n func -- )
+M: x86.64 %box-long-long ( n func -- )
T{ int-regs } swap %box ;
-M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ;
+M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
-M: amd64-backend %box-small-struct ( size -- )
+M: x86.64 %box-small-struct ( size -- )
#! Box a <= 16-byte struct returned in RAX:RDX.
RDI RAX MOV
RSI RDX MOV
RDX swap MOV
"box_small_struct" f %alien-invoke ;
-M: amd64-backend %box-large-struct ( n size -- )
+M: x86.64 %box-large-struct ( n size -- )
! Struct size is parameter 2
RSI over MOV
! Compute destination address
@@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- )
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
-M: amd64-backend %prepare-box-struct ( size -- )
+M: x86.64 %prepare-box-struct ( size -- )
! Compute target address for value struct return
RAX RSP rot f struct-return@ [+] LEA
RSP 0 [+] RAX MOV ;
-M: amd64-backend %prepare-var-args RAX RAX XOR ;
+M: x86.64 %prepare-var-args RAX RAX XOR ;
-M: amd64-backend %alien-invoke ( symbol dll -- )
+M: x86.64 %alien-invoke ( symbol dll -- )
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
-M: amd64-backend %prepare-alien-indirect ( -- )
+M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ RAX MOV ;
-M: amd64-backend %alien-indirect ( -- )
+M: x86.64 %alien-indirect ( -- )
cell temp@ CALL ;
-M: amd64-backend %alien-callback ( quot -- )
+M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
-M: amd64-backend %callback-value ( ctype -- )
+M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
! Put former top of data stack in RDI
@@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
-M: amd64-backend %cleanup ( alien-node -- ) drop ;
+M: x86.64 %cleanup ( alien-node -- ) drop ;
-M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ;
+M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
USE: cpu.x86.intrinsics
@@ -171,8 +168,6 @@ USE: cpu.x86.intrinsics
\ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter
-T{ x86-backend f 8 } compiler-backend set-global
-
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor
index 5519a9a8d5..f236cdcfa6 100755
--- a/core/cpu/x86/allot/allot.factor
+++ b/core/cpu/x86/allot/allot.factor
@@ -46,7 +46,7 @@ IN: cpu.x86.allot
allot-reg swap tag-number OR
allot-reg MOV ;
-M: x86-backend %box-float ( dst src -- )
+M: x86 %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg
float 16 [
@@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- )
"end" resolve-label
] with-scope ;
-M: x86-backend %box-alien ( dst src -- )
+M: x86 %box-alien ( dst src -- )
[
{ "end" "f" } [ define-label ] each
dup v>operand 0 CMP
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 31fa4c8e4b..76c4f1691a 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators compiler.constants ;
IN: cpu.x86.architecture
-TUPLE: x86-backend cell ;
-
-HOOK: ds-reg compiler-backend
-HOOK: rs-reg compiler-backend
-HOOK: stack-reg compiler-backend
-HOOK: xt-reg compiler-backend
-HOOK: stack-save-reg compiler-backend
+HOOK: ds-reg cpu
+HOOK: rs-reg cpu
+HOOK: stack-reg cpu
+HOOK: xt-reg cpu
+HOOK: stack-save-reg cpu
: stack@ stack-reg swap [+] ;
@@ -33,34 +31,34 @@ GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
-HOOK: address-operand compiler-backend ( address -- operand )
+HOOK: address-operand cpu ( address -- operand )
-HOOK: fixnum>slot@ compiler-backend
+HOOK: fixnum>slot@ cpu
-HOOK: prepare-division compiler-backend
+HOOK: prepare-division cpu
M: immediate load-literal v>operand swap v>operand MOV ;
-M: x86-backend stack-frame ( n -- i )
+M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ;
-M: x86-backend %save-word-xt ( -- )
+M: x86 %save-word-xt ( -- )
xt-reg 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ;
-M: x86-backend %prologue ( n -- )
+M: x86 %prologue ( n -- )
dup cell + PUSH
xt-reg PUSH
stack-reg swap 2 cells - SUB ;
-M: x86-backend %epilogue ( n -- )
+M: x86 %epilogue ( n -- )
stack-reg swap ADD ;
: %alien-global ( symbol dll register -- )
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
-M: x86-backend %prepare-alien-invoke
+M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
@@ -70,11 +68,11 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
-M: x86-backend %call ( label -- ) CALL ;
+M: x86 %call ( label -- ) CALL ;
-M: x86-backend %jump-label ( label -- ) JMP ;
+M: x86 %jump-label ( label -- ) JMP ;
-M: x86-backend %jump-t ( label -- )
+M: x86 %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
: code-alignment ( -- n )
@@ -83,7 +81,7 @@ M: x86-backend %jump-t ( label -- )
: align-code ( n -- )
0 <repetition> % ;
-M: x86-backend %dispatch ( -- )
+M: x86 %dispatch ( -- )
[
%epilogue-later
! Load jump table base. We use a temporary register
@@ -105,27 +103,27 @@ M: x86-backend %dispatch ( -- )
{ +clobber+ { "n" } }
} with-template ;
-M: x86-backend %dispatch-label ( word -- )
+M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
-M: x86-backend %unbox-float ( dst src -- )
+M: x86 %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset [+] MOVSD ;
-M: x86-backend %peek [ v>operand ] bi@ MOV ;
+M: x86 %peek [ v>operand ] bi@ MOV ;
-M: x86-backend %replace swap %peek ;
+M: x86 %replace swap %peek ;
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
-M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ;
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
-M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ;
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
-M: x86-backend fp-shadows-int? ( -- ? ) f ;
+M: x86 fp-shadows-int? ( -- ? ) f ;
-M: x86-backend value-structs? t ;
+M: x86 value-structs? t ;
-M: x86-backend small-enough? ( n -- ? )
+M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
: %untag ( reg -- ) tag-mask get bitnot AND ;
@@ -143,34 +141,34 @@ M: x86-backend small-enough? ( n -- ? )
\ stack-frame get swap -
] ?if ;
-HOOK: %unbox-struct-1 compiler-backend ( -- )
+HOOK: %unbox-struct-1 cpu ( -- )
-HOOK: %unbox-struct-2 compiler-backend ( -- )
+HOOK: %unbox-struct-2 cpu ( -- )
-M: x86-backend %unbox-small-struct ( size -- )
+M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
-M: x86-backend struct-small-enough? ( size -- ? )
+M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member?
os { "linux" "netbsd" "solaris" } member? not and ;
-M: x86-backend %return ( -- ) 0 %unwind ;
+M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
-M: x86-backend %unbox-byte-array ( dst src -- )
+M: x86 %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset [+] LEA ;
-M: x86-backend %unbox-alien ( dst src -- )
+M: x86 %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset [+] MOV ;
-M: x86-backend %unbox-f ( dst src -- )
+M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
-M: x86-backend %unbox-any-c-ptr ( dst src -- )
+M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg
ds-reg PUSH
diff --git a/core/system/system.factor b/core/system/system.factor
index 5a0faeece9..459af28537 100755
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -13,14 +13,14 @@ SINGLETON: x86.64
SINGLETON: arm
SINGLETON: ppc
+UNION: x86 x86.32 x86.64 ;
+
: cpu ( -- class ) \ cpu get ;
! SINGLETON: winnt
! SINGLETON: wince
-! MIXIN: windows
-! INSTANCE: winnt windows
-! INSTANCE: wince windows
+! UNION: windows winnt wince ;
! SINGLETON: freebsd
! SINGLETON: netbsd
@@ -29,11 +29,23 @@ SINGLETON: ppc
! SINGLETON: macosx
! SINGLETON: linux
+<PRIVATE
+
+: string>cpu ( str -- class )
+ H{
+ { "x86.32" x86.32 }
+ { "x86.64" x86.64 }
+ { "arm" arm }
+ { "ppc" ppc }
+ } at ;
+
+PRIVATE>
+
! : os ( -- class ) \ os get ;
[
- 8 getenv "system" lookup \ cpu set-global
- ! 9 getenv "system" lookup \ os set-global
+ 8 getenv string>cpu \ cpu set-global
+ ! 9 getenv string>os \ os set-global
] "system" add-init-hook
: image ( -- path ) 13 getenv ;
From 393f77715cafa447f6e9499ba61cd319c2620e28 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 18:25:33 -0500
Subject: [PATCH 055/288] update everything to use os singletons
---
core/alien/alien-docs.factor | 4 +-
core/alien/alien.factor | 2 +-
core/bootstrap/image/image.factor | 2 +-
core/bootstrap/stage2.factor | 6 +-
core/command-line/command-line.factor | 2 +-
core/cpu/ppc/architecture/architecture.factor | 16 ++--
core/cpu/ppc/ppc.factor | 9 +--
core/cpu/x86/32/32.factor | 5 +-
core/cpu/x86/architecture/architecture.factor | 2 +-
core/generator/fixup/fixup.factor | 2 +-
core/io/files/files.factor | 12 +--
core/system/system-docs.factor | 60 +++------------
core/system/system-tests.factor | 4 +-
core/system/system.factor | 75 ++++++++-----------
extra/bootstrap/io/io.factor | 6 +-
extra/bootstrap/random/random.factor | 4 +-
extra/bootstrap/ui/ui.factor | 6 +-
extra/builder/builder.factor | 2 +-
extra/cairo/ffi/ffi.factor | 8 +-
extra/calendar/calendar.factor | 4 +-
.../distributed/distributed-tests.factor | 66 ++++++++--------
extra/db/mysql/ffi/ffi.factor | 6 +-
extra/db/postgresql/ffi/ffi.factor | 6 +-
extra/db/sqlite/ffi/ffi.factor | 6 +-
extra/editors/gvim/gvim.factor | 4 +-
extra/freetype/freetype.factor | 4 +-
extra/hardware-info/hardware-info.factor | 6 +-
extra/io/files/unique/unique.factor | 4 +-
extra/io/sockets/impl/impl.factor | 4 +-
extra/io/unix/unix.factor | 2 +-
extra/io/windows/ce/backend/backend.factor | 2 +-
extra/io/windows/launcher/launcher.factor | 4 +-
extra/ogg/ogg.factor | 6 +-
extra/ogg/theora/theora.factor | 6 +-
extra/ogg/vorbis/vorbis.factor | 6 +-
extra/openal/openal.factor | 14 ++--
extra/opengl/gl/extensions/extensions.factor | 10 ++-
extra/openssl/libcrypto/libcrypto.factor | 6 +-
extra/openssl/libssl/libssl.factor | 6 +-
extra/oracle/liboci/liboci.factor | 6 +-
extra/tools/deploy/deploy.factor | 4 +-
extra/tools/disassembler/disassembler.factor | 2 +-
extra/ui/tools/deploy/deploy.factor | 2 +-
extra/unix/kqueue/kqueue.factor | 2 +-
extra/unix/stat/stat.factor | 10 +--
45 files changed, 186 insertions(+), 239 deletions(-)
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 7bba9d7332..fcafe3441c 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -76,8 +76,8 @@ $nl
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"
- " { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
- " { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
+ " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
+ " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" { [ t ] [ drop ] }"
"} cond >>"
}
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index cfa9fb2e16..56be3e66a5 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -29,7 +29,7 @@ M: f expired? drop t ;
f <displaced-alien> { simple-c-ptr } declare ; inline
: alien>native-string ( alien -- string )
- windows? [ alien>u16-string ] [ alien>char-string ] if ;
+ os windows? [ alien>u16-string ] [ alien>char-string ] if ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index e2fa5833eb..6e0f8e2970 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -13,7 +13,7 @@ IN: bootstrap.image
: my-arch ( -- arch )
cpu word-name
- dup "ppc" = [ >r os "-" r> 3append ] when ;
+ dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index bbb2e44843..c82ebbe9f8 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -11,7 +11,7 @@ IN: bootstrap.stage2
SYMBOL: bootstrap-time
: default-image-name ( -- string )
- vm file-name windows? [ "." split1 drop ] when
+ vm file-name os windows? [ "." split1 drop ] when
".image" append resource-path ;
: do-crossref ( -- )
@@ -65,8 +65,8 @@ parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless
! Set dll paths
-wince? [ "windows.ce" require ] when
-winnt? [ "windows.nt" require ] when
+os wince? [ "windows.ce" require ] when
+os winnt? [ "windows.nt" require ] when
"deploy-vocab" get [
"stage2: deployment mode" print
diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor
index 72c1e063e0..246bf2dabe 100644
--- a/core/command-line/command-line.factor
+++ b/core/command-line/command-line.factor
@@ -47,7 +47,7 @@ SYMBOL: main-vocab-hook
] bind ;
: ignore-cli-args? ( -- ? )
- macosx? "run" get "ui" = and ;
+ os macosx? "run" get "ui" = and ;
: script-mode ( -- )
t "quiet" set-global
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index 8055e4ff6e..a1a4bd3809 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -19,14 +19,14 @@ IN: cpu.ppc.architecture
: reserved-area-size
os {
- { "linux" [ 2 ] }
- { "macosx" [ 6 ] }
+ { linux [ 2 ] }
+ { macosx [ 6 ] }
} case cells ; foldable
: lr-save
os {
- { "linux" [ 1 ] }
- { "macosx" [ 2 ] }
+ { linux [ 1 ] }
+ { macosx [ 2 ] }
} case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline
@@ -58,8 +58,8 @@ M: int-regs vregs
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
- { "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
- { "linux" { 1 2 3 4 5 6 7 8 } }
+ { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+ { linux { 1 2 3 4 5 6 7 8 } }
} at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
@@ -273,9 +273,9 @@ M: ppc %cleanup ( alien-node -- ) drop ;
M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
- linux? not ;
+ os linux? not ;
-M: ppc fp-shadows-int? ( -- ? ) macosx? ;
+M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor
index da17da9185..eede86085b 100755
--- a/core/cpu/ppc/ppc.factor
+++ b/core/cpu/ppc/ppc.factor
@@ -2,16 +2,13 @@ USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture
namespaces alien.c-types kernel system combinators ;
{
- { [ macosx? ] [
+ { [ os macosx? ] [
4 "longlong" c-type set-c-type-align
4 "ulonglong" c-type set-c-type-align
+ 4 "double" c-type set-c-type-align
] }
- { [ linux? ] [
+ { [ os linux? ] [
t "longlong" c-type set-c-type-stack-align?
t "ulonglong" c-type set-c-type-stack-align?
] }
} cond
-
-macosx? [
- 4 "double" c-type set-c-type-align
-] when
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index 3ebee73cbf..4d447b38fc 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -253,12 +253,9 @@ M: x86.32 %cleanup ( alien-node -- )
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
-windows? [
+os windows? [
cell "longlong" c-type set-c-type-align
cell "ulonglong" c-type set-c-type-align
-] unless
-
-windows? [
4 "double" c-type set-c-type-align
] unless
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 76c4f1691a..6c9a4dc05f 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -154,7 +154,7 @@ M: x86 %unbox-small-struct ( size -- )
M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member?
- os { "linux" "netbsd" "solaris" } member? not and ;
+ os { linux netbsd solaris } member? not and ;
M: x86 %return ( -- ) 0 %unwind ;
diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor
index 7581377a6a..5cc0442464 100755
--- a/core/generator/fixup/fixup.factor
+++ b/core/generator/fixup/fixup.factor
@@ -111,7 +111,7 @@ SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get push-new* ;
: string>symbol ( str -- alien )
- [ wince? [ string>u16-alien ] [ string>char-alien ] if ]
+ [ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
over string? [ call ] [ map ] if ;
: add-dlsym-literals ( symbol dll -- )
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 720894d489..45bf0602f2 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -43,9 +43,9 @@ HOOK: (file-appender) io-backend ( path -- stream )
>r <file-appender> r> with-stream ; inline
! Pathnames
-: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
+: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
-: path-separator ( -- string ) windows? "\\" "/" ? ;
+: path-separator ( -- string ) os windows? "\\" "/" ? ;
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
@@ -112,7 +112,7 @@ PRIVATE>
{
{ [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] }
- { [ windows? ] [ windows-absolute-path? ] }
+ { [ os windows? ] [ windows-absolute-path? ] }
{ [ dup first path-separator? ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
@@ -322,7 +322,7 @@ M: pathname <=> [ pathname-string ] compare ;
! Home directory
: home ( -- dir )
{
- { [ winnt? ] [ "USERPROFILE" os-env ] }
- { [ wince? ] [ "" resource-path ] }
- { [ unix? ] [ "HOME" os-env ] }
+ { [ os winnt? ] [ "USERPROFILE" os-env ] }
+ { [ os wince? ] [ "" resource-path ] }
+ { [ os unix? ] [ "HOME" os-env ] }
} cond ;
diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index 7e7a5ff215..9124efcb8c 100755
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -5,14 +5,8 @@ IN: system
ARTICLE: "os" "System interface"
"Operating system detection:"
{ $subsection os }
-{ $subsection unix? }
-{ $subsection macosx? }
-{ $subsection solaris? }
-{ $subsection windows? }
-{ $subsection winnt? }
{ $subsection win32? }
{ $subsection win64? }
-{ $subsection wince? }
"Processor detection:"
{ $subsection cpu }
"Reading environment variables:"
@@ -32,23 +26,23 @@ ABOUT: "os"
HELP: cpu
{ $values { "cpu" string } }
{ $description
- "Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:"
- { $code "x86.32" "x86.64" "ppc" "arm" }
+ "Outputs a singleton class with the name of the current CPU architecture. Currently, this set of descriptors is:"
+ { $code x86.32 x86.64 ppc arm }
} ;
HELP: os
{ $values { "os" string } }
{ $description
- "Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:"
+ "Outputs a singleton class with the name of the current operating system family. Currently, this set of descriptors is:"
{ $code
- "freebsd"
- "linux"
- "macosx"
- "openbsd"
- "netbsd"
- "solaris"
- "wince"
- "winnt"
+ freebsd
+ linux
+ macosx
+ openbsd
+ netbsd
+ solaris
+ wince
+ winnt
}
} ;
@@ -56,34 +50,6 @@ HELP: embedded?
{ $values { "?" "a boolean" } }
{ $description "Tests if this Factor instance is embedded in another application." } ;
-HELP: windows?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows." } ;
-
-HELP: winnt?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows XP or Vista." } ;
-
-HELP: wince?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows CE." } ;
-
-HELP: macosx?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Mac OS X." } ;
-
-HELP: linux?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Linux." } ;
-
-HELP: solaris?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Solaris." } ;
-
-HELP: bsd?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on FreeBSD/OpenBSD/NetBSD." } ;
-
HELP: exit ( n -- )
{ $values { "n" "an integer exit code" } }
{ $description "Exits the Factor process." } ;
@@ -135,7 +101,3 @@ HELP: image
HELP: vm
{ $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor VM." } ;
-
-HELP: unix?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ;
diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor
index 4b074ed7aa..14e34ccb17 100755
--- a/core/system/system-tests.factor
+++ b/core/system/system-tests.factor
@@ -1,11 +1,11 @@
USING: math tools.test system prettyprint namespaces kernel ;
IN: system.tests
-wince? [
+os wince? [
[ ] [ os-envs . ] unit-test
] unless
-unix? [
+os unix? [
[ ] [ os-envs "envs" set ] unit-test
[ ] [ { { "A" "B" } } set-os-envs ] unit-test
[ "B" ] [ "A" os-env ] unit-test
diff --git a/core/system/system.factor b/core/system/system.factor
index 459af28537..00b3f87e98 100755
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -4,10 +4,6 @@ IN: system
USING: kernel kernel.private sequences math namespaces
init splitting assocs system.private layouts words ;
-! : cpu ( -- cpu ) 8 getenv ; foldable
-
-: os ( -- os ) 9 getenv ; foldable
-
SINGLETON: x86.32
SINGLETON: x86.64
SINGLETON: arm
@@ -17,17 +13,23 @@ UNION: x86 x86.32 x86.64 ;
: cpu ( -- class ) \ cpu get ;
-! SINGLETON: winnt
-! SINGLETON: wince
+SINGLETON: winnt
+SINGLETON: wince
-! UNION: windows winnt wince ;
+UNION: windows winnt wince ;
-! SINGLETON: freebsd
-! SINGLETON: netbsd
-! SINGLETON: openbsd
-! SINGLETON: solaris
-! SINGLETON: macosx
-! SINGLETON: linux
+SINGLETON: freebsd
+SINGLETON: netbsd
+SINGLETON: openbsd
+SINGLETON: solaris
+SINGLETON: macosx
+SINGLETON: linux
+
+UNION: bsd freebsd netbsd openbsd macosx ;
+
+UNION: unix bsd solaris linux ;
+
+: os ( -- class ) \ os get ;
<PRIVATE
@@ -39,52 +41,39 @@ UNION: x86 x86.32 x86.64 ;
{ "ppc" ppc }
} at ;
-PRIVATE>
+: string>os ( str -- class )
+ H{
+ { "winnt" winnt }
+ { "wince" wince }
+ { "freebsd" freebsd }
+ { "netbsd" netbsd }
+ { "openbsd" openbsd }
+ { "solaris" solaris }
+ { "macosx" macosx }
+ { "linux" linux }
+ } at ;
-! : os ( -- class ) \ os get ;
+PRIVATE>
[
8 getenv string>cpu \ cpu set-global
- ! 9 getenv string>os \ os set-global
+ 9 getenv string>os \ os set-global
] "system" add-init-hook
: image ( -- path ) 13 getenv ;
: vm ( -- path ) 14 getenv ;
-: wince? ( -- ? )
- os "wince" = ; foldable
-
-: winnt? ( -- ? )
- os "winnt" = ; foldable
-
-: windows? ( -- ? )
- wince? winnt? or ; foldable
-
: win32? ( -- ? )
- winnt? cell 4 = and ; foldable
+ os winnt?
+ cell 4 = and ; foldable
: win64? ( -- ? )
- winnt? cell 8 = and ; foldable
-
-: macosx? ( -- ? ) os "macosx" = ; foldable
+ os winnt?
+ cell 8 = and ; foldable
: embedded? ( -- ? ) 15 getenv ;
-: unix? ( -- ? )
- os {
- "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris"
- } member? ;
-
-: bsd? ( -- ? )
- os { "freebsd" "openbsd" "netbsd" "macosx" } member? ;
-
-: linux? ( -- ? )
- os "linux" = ;
-
-: solaris? ( -- ? )
- os "solaris" = ;
-
: os-envs ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>assoc ;
diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor
index 065f7dd5c4..a38107fbab 100755
--- a/extra/bootstrap/io/io.factor
+++ b/extra/bootstrap/io/io.factor
@@ -5,8 +5,8 @@ IN: bootstrap.io
"bootstrap.compiler" vocab [
"io." {
{ [ "io-backend" get ] [ "io-backend" get ] }
- { [ unix? ] [ "unix" ] }
- { [ winnt? ] [ "windows.nt" ] }
- { [ wince? ] [ "windows.ce" ] }
+ { [ os unix? ] [ "unix" ] }
+ { [ os winnt? ] [ "windows.nt" ] }
+ { [ os wince? ] [ "windows.ce" ] }
} cond append require
] when
diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor
index daf35b9c03..fa0c54d0c6 100755
--- a/extra/bootstrap/random/random.factor
+++ b/extra/bootstrap/random/random.factor
@@ -5,8 +5,8 @@ namespaces random ;
"random.mersenne-twister" require
{
- { [ windows? ] [ "random.windows" require ] }
- { [ unix? ] [ "random.unix" require ] }
+ { [ os windows? ] [ "random.windows" require ] }
+ { [ os unix? ] [ "random.unix" require ] }
} cond
! [ [ 32 random-bits ] with-secure-random <mersenne-twister> random-generator set-global ]
diff --git a/extra/bootstrap/ui/ui.factor b/extra/bootstrap/ui/ui.factor
index f8db831dbc..5aa7683efc 100644
--- a/extra/bootstrap/ui/ui.factor
+++ b/extra/bootstrap/ui/ui.factor
@@ -4,9 +4,9 @@ vocabs vocabs.loader ;
"bootstrap.compiler" vocab [
"ui-backend" get [
{
- { [ macosx? ] [ "cocoa" ] }
- { [ windows? ] [ "windows" ] }
- { [ unix? ] [ "x11" ] }
+ { [ os macosx? ] [ "cocoa" ] }
+ { [ os windows? ] [ "windows" ] }
+ { [ os unix? ] [ "x11" ] }
} cond
] unless* "ui." prepend require
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 75664ce5e5..ece6d64ed9 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -245,4 +245,4 @@ USE: bootstrap.image.download
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MAIN: build-loop
\ No newline at end of file
+MAIN: build-loop
diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor
index c319ade93b..dd4faf9f96 100644
--- a/extra/cairo/ffi/ffi.factor
+++ b/extra/cairo/ffi/ffi.factor
@@ -13,10 +13,10 @@ USING: alien alien.syntax combinators system ;
IN: cairo.ffi
<< "cairo" {
- { [ win32? ] [ "libcairo-2.dll" ] }
- ! { [ macosx? ] [ "libcairo.dylib" ] }
- { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
- { [ unix? ] [ "libcairo.so.2" ] }
+ { [ os win32? ] [ "libcairo-2.dll" ] }
+ ! { [ os macosx? ] [ "libcairo.dylib" ] }
+ { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+ { [ os unix? ] [ "libcairo.so.2" ] }
} cond "cdecl" add-library >>
LIBRARY: cairo
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 6c29c0d1ac..8dcb4af7f1 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -377,6 +377,6 @@ M: timestamp sleep-until timestamp>millis sleep-until ;
M: duration sleep from-now sleep-until ;
{
- { [ unix? ] [ "calendar.unix" ] }
- { [ windows? ] [ "calendar.windows" ] }
+ { [ os unix? ] [ "calendar.unix" ] }
+ { [ os windows? ] [ "calendar.windows" ] }
} cond require
diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor
index 856c37a6bc..e2abd6deb9 100755
--- a/extra/concurrency/distributed/distributed-tests.factor
+++ b/extra/concurrency/distributed/distributed-tests.factor
@@ -1,33 +1,33 @@
-IN: concurrency.distributed.tests
-USING: tools.test concurrency.distributed kernel io.files
-arrays io.sockets system combinators threads math sequences
-concurrency.messaging continuations ;
-
-: test-node
- {
- { [ unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
- { [ windows? ] [ "127.0.0.1" 1238 <inet4> ] }
- } cond ;
-
-[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
-
-[ ] [ test-node dup 1array swap (start-node) ] unit-test
-
-[ ] [ yield ] unit-test
-
-[ ] [
- [
- receive first2 >r 3 + r> send
- "thread-a" unregister-process
- ] "Thread A" spawn
- "thread-a" swap register-process
-] unit-test
-
-[ 8 ] [
- 5 self 2array
- "thread-a" test-node <remote-process> send
-
- receive
-] unit-test
-
-[ ] [ test-node stop-node ] unit-test
+IN: concurrency.distributed.tests
+USING: tools.test concurrency.distributed kernel io.files
+arrays io.sockets system combinators threads math sequences
+concurrency.messaging continuations ;
+
+: test-node
+ {
+ { [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
+ { [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
+ } cond ;
+
+[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
+
+[ ] [ test-node dup 1array swap (start-node) ] unit-test
+
+[ ] [ yield ] unit-test
+
+[ ] [
+ [
+ receive first2 >r 3 + r> send
+ "thread-a" unregister-process
+ ] "Thread A" spawn
+ "thread-a" swap register-process
+] unit-test
+
+[ 8 ] [
+ 5 self 2array
+ "thread-a" test-node <remote-process> send
+
+ receive
+] unit-test
+
+[ ] [ test-node stop-node ] unit-test
diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor
index 845381a23c..424cc7c754 100644
--- a/extra/db/mysql/ffi/ffi.factor
+++ b/extra/db/mysql/ffi/ffi.factor
@@ -6,9 +6,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: db.mysql.ffi
<< "mysql" {
- { [ win32? ] [ "libmySQL.dll" "stdcall" ] }
- { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
- { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
+ { [ os win32? ] [ "libmySQL.dll" "stdcall" ] }
+ { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
} cond add-library >>
LIBRARY: mysql
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index be491b8c85..b6aee3dcce 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -5,9 +5,9 @@ USING: alien alien.syntax combinators system ;
IN: db.postgresql.ffi
<< "postgresql" {
- { [ win32? ] [ "libpq.dll" ] }
- { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
- { [ unix? ] [ "libpq.so" ] }
+ { [ os win32? ] [ "libpq.dll" ] }
+ { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
+ { [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
! ConnSatusType
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index 1d356b1592..c724025874 100755
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -7,9 +7,9 @@ USING: alien compiler kernel math namespaces sequences strings alien.syntax
IN: db.sqlite.ffi
<< "sqlite" {
- { [ winnt? ] [ "sqlite3.dll" ] }
- { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
- { [ unix? ] [ "libsqlite3.so" ] }
+ { [ os winnt? ] [ "sqlite3.dll" ] }
+ { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ os unix? ] [ "libsqlite3.so" ] }
} cond "cdecl" add-library >>
! Return values from sqlite functions
diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor
index 775d008963..62150bdf49 100755
--- a/extra/editors/gvim/gvim.factor
+++ b/extra/editors/gvim/gvim.factor
@@ -13,6 +13,6 @@ t vim-detach set-global ! don't block the ui
T{ gvim } vim-editor set-global
{
- { [ unix? ] [ "editors.gvim.unix" ] }
- { [ windows? ] [ "editors.gvim.windows" ] }
+ { [ os unix? ] [ "editors.gvim.unix" ] }
+ { [ os windows? ] [ "editors.gvim.windows" ] }
} cond require
diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor
index 00f7de1370..f34bdc9920 100755
--- a/extra/freetype/freetype.factor
+++ b/extra/freetype/freetype.factor
@@ -4,8 +4,8 @@ USING: alien alien.syntax kernel system combinators ;
IN: freetype
<< "freetype" {
- { [ macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
- { [ windows? ] [ "freetype6.dll" "cdecl" add-library ] }
+ { [ os macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
+ { [ os windows? ] [ "freetype6.dll" "cdecl" add-library ] }
{ [ t ] [ drop ] }
} cond >>
diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor
index 69b8678749..83e59b3123 100755
--- a/extra/hardware-info/hardware-info.factor
+++ b/extra/hardware-info/hardware-info.factor
@@ -8,9 +8,9 @@ IN: hardware-info
<<
{
- { [ windows? ] [ "hardware-info.windows" ] }
- { [ linux? ] [ "hardware-info.linux" ] }
- { [ macosx? ] [ "hardware-info.macosx" ] }
+ { [ os windows? ] [ "hardware-info.windows" ] }
+ { [ os linux? ] [ "hardware-info.linux" ] }
+ { [ os macosx? ] [ "hardware-info.macosx" ] }
{ [ t ] [ f ] }
} cond [ require ] when* >>
diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor
index a180a28f23..06a3ec8dd2 100644
--- a/extra/io/files/unique/unique.factor
+++ b/extra/io/files/unique/unique.factor
@@ -42,6 +42,6 @@ PRIVATE>
[ with-directory ] curry keep delete-tree ; inline
{
- { [ unix? ] [ "io.unix.files.unique" ] }
- { [ windows? ] [ "io.windows.files.unique" ] }
+ { [ os unix? ] [ "io.unix.files.unique" ] }
+ { [ os windows? ] [ "io.windows.files.unique" ] }
} cond require
diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor
index 8480fcd856..45130c0ab6 100755
--- a/extra/io/sockets/impl/impl.factor
+++ b/extra/io/sockets/impl/impl.factor
@@ -6,8 +6,8 @@ alien.c-types combinators namespaces alien parser ;
IN: io.sockets.impl
<< {
- { [ windows? ] [ "windows.winsock" ] }
- { [ unix? ] [ "unix" ] }
+ { [ os windows? ] [ "windows.winsock" ] }
+ { [ os unix? ] [ "unix" ] }
} cond use+ >>
GENERIC: protocol-family ( addrspec -- af )
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 0a7fc72662..f6607d98f9 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -2,4 +2,4 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader sequences ;
-"io.unix." os append require
+"io.unix." os word-name append require
diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor
index 152e76a6c7..b8b024d710 100755
--- a/extra/io/windows/ce/backend/backend.factor
+++ b/extra/io/windows/ce/backend/backend.factor
@@ -37,7 +37,7 @@ M: windows-ce-io (init-stdio) ( -- )
#! We support Windows NT too, to make this I/O backend
#! easier to debug.
512 default-buffer-size [
- winnt? [
+ os winnt? [
STD_INPUT_HANDLE GetStdHandle
STD_OUTPUT_HANDLE GetStdHandle
STD_ERROR_HANDLE GetStdHandle
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 579745710e..3f230a4ac0 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -82,7 +82,7 @@ TUPLE: CreateProcess-args
: fill-dwCreateFlags ( process args -- process args )
0
pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
- pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
+ pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
pick lookup-priority [ bitor ] when*
>>dwCreateFlags ;
@@ -105,7 +105,7 @@ M: windows-ce-io fill-redirection 2drop ;
: make-CreateProcess-args ( process -- args )
default-CreateProcess-args
- wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
+ os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags
fill-lpEnvironment
fill-startup-info
diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor
index 830249a3df..9a6997ce29 100644
--- a/extra/ogg/ogg.factor
+++ b/extra/ogg/ogg.factor
@@ -6,9 +6,9 @@ IN: ogg
<<
"ogg" {
- { [ win32? ] [ "ogg.dll" ] }
- { [ macosx? ] [ "libogg.0.dylib" ] }
- { [ unix? ] [ "libogg.so" ] }
+ { [ os win32? ] [ "ogg.dll" ] }
+ { [ os macosx? ] [ "libogg.0.dylib" ] }
+ { [ os unix? ] [ "libogg.so" ] }
} cond "cdecl" add-library
>>
diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor
index 48b61b41a3..12d2aa4efb 100644
--- a/extra/ogg/theora/theora.factor
+++ b/extra/ogg/theora/theora.factor
@@ -6,9 +6,9 @@ IN: ogg.theora
<<
"theora" {
- { [ win32? ] [ "theora.dll" ] }
- { [ macosx? ] [ "libtheora.0.dylib" ] }
- { [ unix? ] [ "libtheora.so" ] }
+ { [ os win32? ] [ "theora.dll" ] }
+ { [ os macosx? ] [ "libtheora.0.dylib" ] }
+ { [ os unix? ] [ "libtheora.so" ] }
} cond "cdecl" add-library
>>
diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor
index 170d0ea6ef..6dbea7869a 100644
--- a/extra/ogg/vorbis/vorbis.factor
+++ b/extra/ogg/vorbis/vorbis.factor
@@ -6,9 +6,9 @@ IN: ogg.vorbis
<<
"vorbis" {
- { [ win32? ] [ "vorbis.dll" ] }
- { [ macosx? ] [ "libvorbis.0.dylib" ] }
- { [ unix? ] [ "libvorbis.so" ] }
+ { [ os win32? ] [ "vorbis.dll" ] }
+ { [ os macosx? ] [ "libvorbis.0.dylib" ] }
+ { [ os unix? ] [ "libvorbis.so" ] }
} cond "cdecl" add-library
>>
diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor
index f7b97d2bf5..e37988a8ce 100644
--- a/extra/openal/openal.factor
+++ b/extra/openal/openal.factor
@@ -7,15 +7,15 @@ USING: kernel alien system combinators alien.syntax namespaces
openal.backend ;
<< "alut" {
- { [ win32? ] [ "alut.dll" ] }
- { [ macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
- { [ unix? ] [ "libalut.so" ] }
+ { [ os win32? ] [ "alut.dll" ] }
+ { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
+ { [ os unix? ] [ "libalut.so" ] }
} cond "cdecl" add-library >>
<< "openal" {
- { [ win32? ] [ "OpenAL32.dll" ] }
- { [ macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
- { [ unix? ] [ "libopenal.so" ] }
+ { [ os win32? ] [ "OpenAL32.dll" ] }
+ { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
+ { [ os unix? ] [ "libopenal.so" ] }
} cond "cdecl" add-library >>
LIBRARY: openal
@@ -257,7 +257,7 @@ SYMBOL: init
"create-buffer-from-file failed" throw
] when ;
-macosx? "openal.macosx" "openal.other" ? require
+os macosx? "openal.macosx" "openal.other" ? require
: create-buffer-from-wav ( filename -- buffer )
gen-buffer dup rot load-wav-file
diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor
index fd9be4eb12..b0a683dac6 100644
--- a/extra/opengl/gl/extensions/extensions.factor
+++ b/extra/opengl/gl/extensions/extensions.factor
@@ -1,11 +1,13 @@
USING: alien alien.syntax combinators kernel parser sequences
system words namespaces hashtables init math arrays assocs
sequences.lib continuations ;
+
+ERROR: unknown-gl-platform ;
<< {
- { [ windows? ] [ "opengl.gl.windows" ] }
- { [ macosx? ] [ "opengl.gl.macosx" ] }
- { [ unix? ] [ "opengl.gl.unix" ] }
- { [ t ] [ "Unknown OpenGL platform" throw ] }
+ { [ os windows? ] [ "opengl.gl.windows" ] }
+ { [ os macosx? ] [ "opengl.gl.macosx" ] }
+ { [ os unix? ] [ "opengl.gl.unix" ] }
+ { [ t ] [ unknown-gl-platform ] }
} cond use+ >>
IN: opengl.gl.extensions
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor
index d06afdc5ea..a68cda34ea 100755
--- a/extra/openssl/libcrypto/libcrypto.factor
+++ b/extra/openssl/libcrypto/libcrypto.factor
@@ -11,9 +11,9 @@ IN: openssl.libcrypto
<<
"libcrypto" {
- { [ win32? ] [ "libeay32.dll" "cdecl" ] }
- { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
- { [ unix? ] [ "libcrypto.so" "cdecl" ] }
+ { [ os win32? ] [ "libeay32.dll" "cdecl" ] }
+ { [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
>>
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index 11dcee31f6..098e1f9382 100755
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libssl
<< "libssl" {
- { [ win32? ] [ "ssleay32.dll" "cdecl" ] }
- { [ macosx? ] [ "libssl.dylib" "cdecl" ] }
- { [ unix? ] [ "libssl.so" "cdecl" ] }
+ { [ os win32? ] [ "ssleay32.dll" "cdecl" ] }
+ { [ os macosx? ] [ "libssl.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
: X509_FILETYPE_PEM 1 ; inline
diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor
index e5313d5b77..6a482b9f56 100644
--- a/extra/oracle/liboci/liboci.factor
+++ b/extra/oracle/liboci/liboci.factor
@@ -12,9 +12,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: oracle.liboci
"oci" {
- { [ win32? ] [ "oci.dll" "stdcall" ] }
- { [ macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] }
- { [ unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] }
+ { [ os win32? ] [ "oci.dll" "stdcall" ] }
+ { [ os macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] }
+ { [ os unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] }
} cond add-library
! ===============================================
diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor
index f12512f510..893b43844a 100755
--- a/extra/tools/deploy/deploy.factor
+++ b/extra/tools/deploy/deploy.factor
@@ -5,5 +5,5 @@ IN: tools.deploy
: deploy ( vocab -- ) deploy* ;
-macosx? [ "tools.deploy.macosx" require ] when
-winnt? [ "tools.deploy.windows" require ] when
+os macosx? [ "tools.deploy.macosx" require ] when
+os winnt? [ "tools.deploy.windows" require ] when
diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor
index 927f7111fa..5b835cd52f 100755
--- a/extra/tools/disassembler/disassembler.factor
+++ b/extra/tools/disassembler/disassembler.factor
@@ -27,7 +27,7 @@ M: method-spec make-disassemble-cmd
first2 method make-disassemble-cmd ;
: gdb-binary ( -- string )
- os "freebsd" = "gdb66" "gdb" ? ;
+ os freebsd? "gdb66" "gdb" ? ;
: run-gdb ( -- lines )
<process>
diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor
index eca5740bbc..522c26e92e 100755
--- a/extra/ui/tools/deploy/deploy.factor
+++ b/extra/ui/tools/deploy/deploy.factor
@@ -49,7 +49,7 @@ TUPLE: deploy-gadget vocab settings ;
[
bundle-name
deploy-ui
- macosx? [ exit-when-windows-closed ] when
+ os macosx? [ exit-when-windows-closed ] when
io-settings
reflection-settings
advanced-settings
diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor
index 55b53bd6d0..50020072c5 100644
--- a/extra/unix/kqueue/kqueue.factor
+++ b/extra/unix/kqueue/kqueue.factor
@@ -3,7 +3,7 @@
USING: alien.syntax system sequences vocabs.loader ;
IN: unix.kqueue
-<< "unix.kqueue." os append require >>
+<< "unix.kqueue." os word-name append require >>
FUNCTION: int kqueue ( ) ;
diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor
index f7432332b9..342047d9af 100644
--- a/extra/unix/stat/stat.factor
+++ b/extra/unix/stat/stat.factor
@@ -60,11 +60,11 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ;
<<
os
{
- { "linux" [ "unix.stat.linux" require ] }
- { "macosx" [ "unix.stat.macosx" require ] }
- { "freebsd" [ "unix.stat.freebsd" require ] }
- { "netbsd" [ "unix.stat.netbsd" require ] }
- { "openbsd" [ "unix.stat.openbsd" require ] }
+ { linux [ "unix.stat.linux" require ] }
+ { macosx [ "unix.stat.macosx" require ] }
+ { freebsd [ "unix.stat.freebsd" require ] }
+ { netbsd [ "unix.stat.netbsd" require ] }
+ { openbsd [ "unix.stat.openbsd" require ] }
}
case
>>
From 28d804d2c4916692b4f2589f0f6223929cda46b9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 18:28:55 -0500
Subject: [PATCH 056/288] remove calendar-backend and use os
---
extra/calendar/backend/backend.factor | 5 ++---
extra/calendar/unix/unix.factor | 9 ++-------
extra/calendar/windows/windows.factor | 8 ++------
3 files changed, 6 insertions(+), 16 deletions(-)
diff --git a/extra/calendar/backend/backend.factor b/extra/calendar/backend/backend.factor
index 01c36c65ae..56ccf9e6cc 100644
--- a/extra/calendar/backend/backend.factor
+++ b/extra/calendar/backend/backend.factor
@@ -1,5 +1,4 @@
-USING: kernel ;
+USING: kernel system ;
IN: calendar.backend
-SYMBOL: calendar-backend
-HOOK: gmt-offset calendar-backend ( -- hours minutes seconds )
+HOOK: gmt-offset os ( -- hours minutes seconds )
diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor
index 2877fa07b5..6383d4ec42 100644
--- a/extra/calendar/unix/unix.factor
+++ b/extra/calendar/unix/unix.factor
@@ -1,17 +1,12 @@
USING: alien alien.c-types arrays calendar.backend
-kernel structs math unix.time namespaces ;
-
+kernel structs math unix.time namespaces system ;
IN: calendar.unix
-TUPLE: unix-calendar ;
-
-T{ unix-calendar } calendar-backend set-global
-
: get-time ( -- alien )
f time <uint> localtime ;
: timezone-name ( -- string )
get-time tm-zone ;
-M: unix-calendar gmt-offset ( -- hours minutes seconds )
+M: unix gmt-offset ( -- hours minutes seconds )
get-time tm-gmtoff 3600 /mod 60 /mod ;
diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor
index 8548e4ee52..2986422155 100755
--- a/extra/calendar/windows/windows.factor
+++ b/extra/calendar/windows/windows.factor
@@ -1,12 +1,8 @@
-USING: calendar.backend namespaces alien.c-types
+USING: calendar.backend namespaces alien.c-types system
windows windows.kernel32 kernel math combinators ;
IN: calendar.windows
-TUPLE: windows-calendar ;
-
-T{ windows-calendar } calendar-backend set-global
-
-M: windows-calendar gmt-offset ( -- hours minutes seconds )
+M: windows gmt-offset ( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
dup GetTimeZoneInformation {
{ [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }
From 5db2e8570aef4582a1d62aa3a42e2b3c9b61ff5b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 18:30:52 -0500
Subject: [PATCH 057/288] change editors.gvim to use the os singletons
---
extra/editors/gvim/unix/unix.factor | 5 +++--
extra/editors/gvim/windows/windows.factor | 4 ++--
2 files changed, 5 insertions(+), 4 deletions(-)
diff --git a/extra/editors/gvim/unix/unix.factor b/extra/editors/gvim/unix/unix.factor
index a7de09c013..3b8f7454c1 100644
--- a/extra/editors/gvim/unix/unix.factor
+++ b/extra/editors/gvim/unix/unix.factor
@@ -1,7 +1,8 @@
-USING: io.unix.backend kernel namespaces editors.gvim.backend ;
+USING: io.unix.backend kernel namespaces editors.gvim.backend
+system ;
IN: editors.gvim.unix
-M: unix-io gvim-path
+M: unix gvim-path
\ gvim-path get-global [
"gvim"
] unless* ;
diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor
index 489000498e..daf5409c94 100755
--- a/extra/editors/gvim/windows/windows.factor
+++ b/extra/editors/gvim/windows/windows.factor
@@ -1,8 +1,8 @@
USING: editors.gvim.backend io.files io.windows kernel namespaces
-sequences windows.shell32 io.paths ;
+sequences windows.shell32 io.paths system ;
IN: editors.gvim.windows
-M: windows-io gvim-path
+M: windows gvim-path
\ gvim-path get-global [
program-files "vim" append-path
t [ "gvim.exe" tail? ] find-file
From 8fde3fb914f178fbe6c2e48077a947640e98a6dc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 18:50:21 -0500
Subject: [PATCH 058/288] More inheritance debugging
---
core/bootstrap/image/image.factor | 1 +
core/bootstrap/primitives.factor | 100 ++++++++++--------
core/bootstrap/stage1.factor | 1 -
core/classes/algebra/algebra.factor | 10 +-
core/classes/classes.factor | 10 +-
core/classes/tuple/tuple-tests.factor | 4 +-
core/generic/generic-docs.factor | 7 +-
core/generic/generic-tests.factor | 31 ------
core/generic/generic.factor | 43 ++++----
core/generic/math/math.factor | 4 +-
.../engines/predicate/predicate.factor | 4 +
core/generic/standard/engines/tag/tag.factor | 32 ++++--
.../standard/engines/tuple/tuple.factor | 37 +++++--
core/generic/standard/standard.factor | 39 +++----
core/kernel/kernel.factor | 2 +-
core/words/words.factor | 5 +-
16 files changed, 174 insertions(+), 156 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index fc963683b6..f0d9b77981 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -444,6 +444,7 @@ PRIVATE>
"resource:/core/bootstrap/stage1.factor" run-file
build-image
write-image
+ \ word-props target-word
] with-scope ;
: make-images ( -- )
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 48a1117574..6c4462ed98 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -31,6 +31,7 @@ crossref off
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
H{ } clone changed-words set
+H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
@@ -126,27 +127,49 @@ num-types get f <array> builtins set
: register-builtin ( class -- )
[ dup lookup-type-number "type" set-word-prop ]
[ dup "type" word-prop builtins get set-nth ]
- bi ;
+ [ f f builtin-class define-class ]
+ tri ;
: define-builtin-slots ( symbol slotspec -- )
[ drop ] [ 1 simple-slots ] 2bi
[ "slots" set-word-prop ] [ define-slots ] 2bi ;
: define-builtin ( symbol slotspec -- )
- >r
- {
- [ register-builtin ]
- [ f f builtin-class define-class ]
- [ define-builtin-predicate ]
- [ ]
- } cleave
+ >r [ define-builtin-predicate ] keep
r> define-builtin-slots ;
-! Forward definitions
-"object" "kernel" create t "class" set-word-prop
-"object" "kernel" create union-class "metaclass" set-word-prop
+"fixnum" "math" create register-builtin
+"bignum" "math" create register-builtin
+"tuple" "kernel" create register-builtin
+"ratio" "math" create register-builtin
+"float" "math" create register-builtin
+"complex" "math" create register-builtin
+"f" "syntax" lookup register-builtin
+"array" "arrays" create register-builtin
+"wrapper" "kernel" create register-builtin
+"float-array" "float-arrays" create register-builtin
+"callstack" "kernel" create register-builtin
+"string" "strings" create register-builtin
+"bit-array" "bit-arrays" create register-builtin
+"quotation" "quotations" create register-builtin
+"dll" "alien" create register-builtin
+"alien" "alien" create register-builtin
+"word" "words" create register-builtin
+"byte-array" "byte-arrays" create register-builtin
+"tuple-layout" "classes.tuple.private" create register-builtin
-"null" "kernel" create drop
+! Catch-all class for providing a default method.
+"object" "kernel" create [ drop t ] "predicate" set-word-prop
+"object" "kernel" create
+f builtins get [ ] subset union-class define-class
+
+! Class of objects with object tag
+"hi-tag" "kernel.private" create
+f builtins get num-tags get tail union-class define-class
+
+! Empty class with no instances
+"null" "kernel" create [ drop f ] "predicate" set-word-prop
+"null" "kernel" create f { } union-class define-class
"fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@@ -335,23 +358,25 @@ define-builtin
}
} define-builtin
-"tuple" "kernel" create { } define-builtin
-
-"tuple" "kernel" lookup
-{
- {
- { "object" "kernel" }
- "delegate"
- { "delegate" "kernel" }
- { "set-delegate" "kernel" }
- }
-}
-[ drop ] [ generate-tuple-slots ] 2bi
-[ [ name>> ] map "slot-names" set-word-prop ]
-[ "slots" set-word-prop ]
-[ define-slots ] 2tri
-
-"tuple" "kernel" lookup define-tuple-layout
+"tuple" "kernel" create {
+ [ { } define-builtin ]
+ [ { "delegate" } "slot-names" set-word-prop ]
+ [ define-tuple-layout ]
+ [
+ {
+ {
+ { "object" "kernel" }
+ "delegate"
+ { "delegate" "kernel" }
+ { "set-delegate" "kernel" }
+ }
+ }
+ [ drop ] [ generate-tuple-slots ] 2bi
+ [ "slots" set-word-prop ]
+ [ define-slots ]
+ 2bi
+ ]
+} cleave
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create
@@ -359,23 +384,10 @@ f "f" "syntax" lookup builtins get remove [ ] subset union-class
define-class
"f" "syntax" create [ not ] "predicate" set-word-prop
-"f?" "syntax" create "syntax" vocab-words delete-at
+"f?" "syntax" vocab-words delete-at
"general-t" "kernel" create [ ] "predicate" set-word-prop
-"general-t?" "kernel" create "syntax" vocab-words delete-at
-
-! Catch-all class for providing a default method.
-"object" "kernel" create [ drop t ] "predicate" set-word-prop
-"object" "kernel" create
-f builtins get [ ] subset union-class define-class
-
-! Class of objects with object tag
-"hi-tag" "kernel.private" create
-f builtins get num-tags get tail union-class define-class
-
-! Null class with no instances.
-"null" "kernel" create [ drop f ] "predicate" set-word-prop
-"null" "kernel" create f { } union-class define-class
+"general-t?" "kernel" vocab-words delete-at
! Create special tombstone values
"tombstone" "hashtables.private" create
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index 34f758c9df..f99c8eb82f 100755
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ;
! Rehash hashtables, since bootstrap.image creates them
! using the host image's hashing algorithms
[ hashtable? ] instances [ rehash ] each
-
boot
] %
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 5d7c114cbc..97309dbea2 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
-;
+kernel.private ;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
@@ -211,12 +211,6 @@ C: <anonymous-complement> anonymous-complement
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
-: class-hashes ( class -- seq )
- flatten-class keys [
- dup builtin-class?
- [ "type" word-prop ] [ hashcode ] if
- ] map ;
-
: flatten-builtin-class ( class -- assoc )
flatten-class [
dup tuple class< [ 2drop tuple tuple ] when
@@ -229,5 +223,5 @@ C: <anonymous-complement> anonymous-complement
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
- [ drop object tag-number ] when
+ [ drop \ hi-tag tag-number ] when
] map prune ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 914e070e03..0baf235edb 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -25,9 +25,11 @@ SYMBOL: class-or-cache
class-and-cache get clear-assoc
class-or-cache get clear-assoc ;
-PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
-
SYMBOL: update-map
+
+PREDICATE: class < word
+ "class" word-prop ;
+
SYMBOL: builtins
PREDICATE: builtin-class < class
@@ -58,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
dup class? [ "superclass" word-prop ] [ drop f ] if ;
: superclasses ( class -- supers )
- [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
+ [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
@@ -72,7 +74,7 @@ M: word reset-class drop ;
! update-map
: class-uses ( class -- seq )
- dup members swap superclass [ suffix ] when* ;
+ [ members ] [ superclass ] bi [ suffix ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 228de8aabf..ff34c25416 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -394,7 +394,9 @@ test-server-slot-values
! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
-T{ test2 f "a" "b" } "test" set
+C: <test2> test2
+
+"a" "b" <test2> "test" set
: test-a/b
[ "a" ] [ "test" get a>> ] unit-test
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 100475455a..04252b6b3b 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -37,7 +37,6 @@ $nl
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
-{ $subsection methods }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@@ -120,10 +119,6 @@ HELP: <method>
{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $description "Creates a new method." } ;
-HELP: methods
-{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
HELP: order
{ $values { "generic" generic } { "seq" "a sequence of classes" } }
{ $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
@@ -151,4 +146,4 @@ HELP: forget-methods
{ $values { "class" class } }
{ $description "Remove all method definitions which specialize on the class." } ;
-{ sort-classes methods order } related-words
+{ sort-classes order } related-words
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index 6a7f8f29fc..fd313d8165 100755
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -171,37 +171,6 @@ M: f tag-and-f 4 ;
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
-! define-class hashing issue
-TUPLE: debug-combination ;
-
-M: debug-combination make-default-method
- 2drop [ "Oops" throw ] ;
-
-M: debug-combination perform-combination
- drop
- order [ dup class-hashes ] { } map>assoc sort-keys
- 1quotation ;
-
-SYMBOL: redefinition-test-generic
-
-[
- redefinition-test-generic
- T{ debug-combination }
- define-generic
-] with-compilation-unit
-
-TUPLE: redefinition-test-tuple ;
-
-"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
-
-[ t ] [
- [
- redefinition-test-generic ,
- "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
- redefinition-test-generic ,
- ] { } make all-equal?
-] unit-test
-
! Issues with forget
GENERIC: generic-forget-test-1
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index dc98883654..2ec285146e 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -25,8 +25,9 @@ PREDICATE: generic < word
M: generic definition drop f ;
: make-generic ( word -- )
- dup { "unannotated-def" } reset-props
- dup dup "combination" word-prop perform-combination define ;
+ [ { "unannotated-def" } reset-props ]
+ [ dup "combination" word-prop perform-combination ]
+ bi ;
: method ( class generic -- method/f )
"methods" word-prop at ;
@@ -37,13 +38,6 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
-: sort-methods ( assoc -- assoc' )
- [ keys sort-classes ]
- [ [ dupd at ] curry ] bi { } map>assoc ;
-
-: methods ( word -- assoc )
- "methods" word-prop sort-methods ;
-
TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
@@ -64,6 +58,9 @@ PREDICATE: method-body < word
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
+M: method-body crossref?
+ drop t ;
+
: method-word-props ( class generic -- assoc )
[
"method-generic" set
@@ -122,9 +119,12 @@ M: method-body definer
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
- dup "method-class" word-prop
- over "method-generic" word-prop forget-method
- t "forgotten" set-word-prop
+ [
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ forget-method
+ ]
+ [ t "forgotten" set-word-prop ] bi
] if ;
: implementors* ( classes -- words )
@@ -137,12 +137,13 @@ M: method-body forget*
dup associate implementors* ;
: forget-methods ( class -- )
- [ implementors ] keep [ swap 2array ] curry map forget-all ;
+ [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
- dup forget-methods
- dup update-map-
- forget-word ;
+ [ forget-methods ]
+ [ update-map- ]
+ [ forget-word ]
+ tri ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
@@ -158,11 +159,15 @@ M: assoc update-methods ( assoc -- )
] if ;
M: generic subwords
- dup "methods" word-prop values
- swap "default-method" word-prop suffix ;
+ [
+ [ "default-method" word-prop , ]
+ [ "methods" word-prop values % ]
+ [ "engines" word-prop % ]
+ tri
+ ] { } make ;
M: generic forget-word
- dup subwords [ forget ] each (forget-word) ;
+ [ subwords forget-all ] [ (forget-word) ] bi ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 85bd736139..2fda2c9621 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -71,13 +71,15 @@ M: math-combination make-default-method
M: math-combination perform-combination
drop
+ dup
\ over [
dup math-class? [
\ dup [ >r 2dup r> math-method ] math-vtable
] [
over object-method
] if nip
- ] math-vtable nip ;
+ ] math-vtable nip
+ define ;
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor
index 2d43a313f0..ce7d5c6c21 100644
--- a/core/generic/standard/engines/predicate/predicate.factor
+++ b/core/generic/standard/engines/predicate/predicate.factor
@@ -21,6 +21,10 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
{ [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
} cond ;
+: sort-methods ( assoc -- assoc' )
+ [ keys sort-classes ]
+ [ [ dupd at ] curry ] bi { } map>assoc ;
+
M: predicate-dispatch-engine engine>quot
methods>> clone
default get object bootstrap-word pick set-at engines>quots
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 3dd8b83579..6344bec536 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -1,26 +1,27 @@
USING: classes.private generic.standard.engines namespaces
arrays assocs sequences.private quotations kernel.private
-layouts math slots.private math.private kernel accessors ;
+math slots.private math.private kernel accessors words
+layouts ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
- \ hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
-
: direct-dispatch-quot ( alist n -- quot )
default get <array>
[ <enum> swap update ] keep
[ dispatch ] curry >quotation ;
+: lo-tag-number ( class -- n )
+ dup \ hi-tag bootstrap-word eq? [
+ drop \ hi-tag tag-number
+ ] [
+ "type" word-prop
+ ] if ;
+
M: lo-tag-dispatch-engine engine>quot
- methods>> engines>quots* [ >r tag-number r> ] assoc-map
+ methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
linear-dispatch-quot
@@ -29,12 +30,21 @@ M: lo-tag-dispatch-engine engine>quot
] if-small? %
] [ ] make ;
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+ \ hi-tag bootstrap-word
+ \ <hi-tag-dispatch-engine> convert-methods ;
+
: num-hi-tags num-types get num-tags get - ;
-: hi-tag-number type-number num-tags get - ;
+: hi-tag-number ( class -- n )
+ "type" word-prop num-tags get - ;
: hi-tag-quot ( -- quot )
- [ 0 slot ] num-tags get [ fixnum- ] curry compose ;
+ [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index ce0f50337d..510d5ef732 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -2,7 +2,7 @@ IN: generic.standard.engines.tuple
USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
-classes.algebra math math.private quotations ;
+classes.algebra math math.private quotations arrays ;
TUPLE: echelon-dispatch-engine n methods ;
@@ -27,17 +27,25 @@ TUPLE: tuple-dispatch-engine echelons ;
: <tuple-dispatch-engine> ( methods -- engine )
echelon-sort
- [ dupd <echelon-dispatch-engine> ] assoc-map
+ [
+ over zero? [
+ dup assoc-empty?
+ [ drop f ] [ values first ] if
+ ] [
+ dupd <echelon-dispatch-engine>
+ ] if
+ ] assoc-map [ nip ] assoc-subset
\ tuple-dispatch-engine construct-boa ;
: convert-tuple-methods ( assoc -- assoc' )
- tuple \ <tuple-dispatch-engine> convert-methods ;
+ tuple bootstrap-word
+ \ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
methods>> engines>quots* linear-dispatch-quot ;
: hash-methods ( methods -- buckets )
- >alist V{ } clone [ class-hashes ] distribute-buckets
+ >alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
: class-hash-dispatch-quot ( methods -- quot )
@@ -60,12 +68,20 @@ PREDICATE: tuple-dispatch-engine-word < word
M: tuple-dispatch-engine-word stack-effect
"tuple-dispatch-generic" word-prop stack-effect ;
+M: tuple-dispatch-engine-word crossref?
+ drop t ;
+
+: remember-engine ( word -- )
+ generic get "engines" word-prop push ;
+
: <tuple-dispatch-engine-word> ( engine -- word )
tuple-dispatch-engine-word-name f <word>
- [ t "tuple-dispatch-engine" set-word-prop ]
- [ generic get "tuple-dispatch-generic" set-word-prop ]
- [ ]
- tri ;
+ {
+ [ t "tuple-dispatch-engine" set-word-prop ]
+ [ generic get "tuple-dispatch-generic" set-word-prop ]
+ [ remember-engine ]
+ [ ]
+ } cleave ;
: define-tuple-dispatch-engine-word ( engine quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ;
@@ -104,6 +120,9 @@ M: tuple-dispatch-engine engine>quot
picker %
[ 1 slot 5 slot ] %
echelons>>
- [ [ engine>quot dup default set ] assoc-map ] with-scope
+ [
+ tuple assumed set
+ [ engine>quot dup default set ] assoc-map
+ ] with-scope
>=-case-quot %
] [ ] make ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 1de41f24ed..0d29bdecd5 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -59,29 +59,32 @@ ERROR: no-method object generic ;
: find-default ( methods -- quot )
#! Side-effects methods.
- object swap delete-at* [
+ object bootstrap-word swap delete-at* [
drop generic get "default-method" word-prop 1quotation
] unless ;
GENERIC: mangle-method ( method generic -- quot )
-: single-combination ( words -- quot )
+: single-combination ( word -- quot )
[
- object bootstrap-word assumed set
- [ generic set ]
- [
- "methods" word-prop
- [ generic get mangle-method ] assoc-map
- [ find-default default set ]
+ object bootstrap-word assumed set {
+ [ generic set ]
+ [ "engines" word-prop forget-all ]
+ [ V{ } clone "engines" set-word-prop ]
[
- generic get "inline" word-prop [
- <predicate-dispatch-engine>
- ] [
- <big-dispatch-engine>
- ] if
- ] bi
- engine>quot
- ] bi
+ "methods" word-prop
+ [ generic get mangle-method ] assoc-map
+ [ find-default default set ]
+ [
+ generic get "inline" word-prop [
+ <predicate-dispatch-engine>
+ ] [
+ <big-dispatch-engine>
+ ] if
+ ] bi
+ engine>quot
+ ]
+ } cleave
] with-scope ;
TUPLE: standard-combination # ;
@@ -107,7 +110,7 @@ M: standard-combination make-default-method
[ empty-method ] with-standard ;
M: standard-combination perform-combination
- [ single-combination ] with-standard ;
+ [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
TUPLE: hook-combination var ;
@@ -128,7 +131,7 @@ M: hook-combination make-default-method
[ error-method ] with-hook ;
M: hook-combination perform-combination
- [ single-combination ] with-hook ;
+ [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
GENERIC: dispatch# ( word -- n )
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index eed5b22e5f..ae775ec116 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -194,7 +194,7 @@ GENERIC: construct-boa ( ... class -- tuple )
<PRIVATE
-: hi-tag ( obj -- n ) 0 slot ;
+: hi-tag ( obj -- n ) 0 slot ; inline
: declare ( spec -- ) drop ;
diff --git a/core/words/words.factor b/core/words/words.factor
index 5c0d84d4cc..a45e1627e9 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -63,10 +63,11 @@ SYMBOL: bootstrapping?
: bootstrap-word ( word -- target )
[ target-word ] [ ] if-bootstrapping ;
-: crossref? ( word -- ? )
+GENERIC: crossref? ( word -- ? )
+
+M: word crossref?
{
{ [ dup "forgotten" word-prop ] [ f ] }
- { [ dup "method-generic" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
From 7cd21081af327a06b267278806e245cc68f9ff52 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 18:50:35 -0500
Subject: [PATCH 059/288] Don't JIT inside heap scan loop, too fragile
---
vm/data_gc.c | 1 -
vm/factor.c | 24 +++++++++++++++++++-----
vm/run.c | 7 +++++--
3 files changed, 24 insertions(+), 8 deletions(-)
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 0a1fad575a..24f7cfecb9 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -730,7 +730,6 @@ void garbage_collection(CELL gen,
/* collect objects referenced from stacks and environment */
collect_roots();
-
/* collect objects referenced from older generations */
collect_cards();
diff --git a/vm/factor.c b/vm/factor.c
index 20667a23f5..5825f97bdd 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -36,22 +36,36 @@ void do_stage1_init(void)
fprintf(stderr,"*** Stage 2 early init... ");
fflush(stderr);
+ GROWABLE_ARRAY(words);
+
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
- default_word_code(word,false);
- update_word_xt(word);
- }
+ GROWABLE_ADD(words,obj);
}
/* End heap scan */
gc_off = false;
+ GROWABLE_TRIM(words);
+ REGISTER_ROOT(words);
+
+ CELL i;
+ CELL length = array_capacity(untag_object(words));
+ for(i = 0; i < length; i++)
+ {
+ F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ REGISTER_UNTAGGED(word);
+ default_word_code(word,false);
+ UNREGISTER_UNTAGGED(word);
+ update_word_xt(word);
+ }
+
+ UNREGISTER_ROOT(words);
+
iterate_code_heap(relocate_code_block);
userenv[STAGE2_ENV] = T;
diff --git a/vm/run.c b/vm/run.c
index d03d999ffd..cec19b5445 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -22,8 +22,11 @@ void fix_stacks(void)
be stored in registers, so callbacks must save and restore the correct values */
void save_stacks(void)
{
- stack_chain->datastack = ds;
- stack_chain->retainstack = rs;
+ if(stack_chain)
+ {
+ stack_chain->datastack = ds;
+ stack_chain->retainstack = rs;
+ }
}
/* called on entry into a compiled callback */
From 93ebbfb7e4e39835d06daf2582044d73facda692 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 18:50:42 -0500
Subject: [PATCH 060/288] Try to fix inotify again
---
extra/io/unix/linux/linux.factor | 17 +++++++++++------
1 file changed, 11 insertions(+), 6 deletions(-)
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 2ae4065fb6..0c79ce970d 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -24,8 +24,10 @@ TUPLE: inotify watches ;
: <inotify> ( -- port/f )
H{ } clone
- inotify_init [ io-error ] [ inotify <buffered-port> ] bi
- { set-inotify-watches set-delegate } inotify construct ;
+ inotify_init dup 0 < [ 2drop f ] [
+ inotify <buffered-port>
+ { set-inotify-watches set-delegate } inotify construct
+ ] if ;
: inotify-fd inotify get-global handle>> ;
@@ -109,9 +111,12 @@ TUPLE: inotify-task ;
f inotify-task <input-task> ;
: init-inotify ( mx -- )
- <inotify>
- dup inotify set-global
- <inotify-task> swap register-io-task ;
+ <inotify> dup [
+ dup inotify set-global
+ <inotify-task> swap register-io-task
+ ] [
+ 2drop
+ ] if ;
M: inotify-task do-io-task ( task -- )
io-task-port read-notifications f ;
@@ -119,7 +124,7 @@ M: inotify-task do-io-task ( task -- )
M: linux-io init-io ( -- )
<select-mx>
[ mx set-global ]
- [ [ init-inotify ] curry ignore-errors ] bi ;
+ [ init-inotify ] bi ;
T{ linux-io } set-io-backend
From a9cd31704daa40b2d5a013613f2f39d9de59d7a9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 18:53:24 -0500
Subject: [PATCH 061/288] remove win32? and win64? words
---
core/alien/c-types/c-types.factor | 2 +-
core/system/system-docs.factor | 10 --------
core/system/system.factor | 8 ------
extra/cairo/ffi/ffi.factor | 4 +--
extra/db/mysql/ffi/ffi.factor | 2 +-
extra/db/postgresql/ffi/ffi.factor | 2 +-
extra/ogg/ogg.factor | 2 +-
extra/ogg/theora/theora.factor | 2 +-
extra/ogg/vorbis/vorbis.factor | 2 +-
extra/openal/backend/backend.factor | 8 ++----
extra/openal/macosx/macosx.factor | 32 +++++++++++-------------
extra/openal/openal.factor | 16 ++++++------
extra/openal/other/other.factor | 28 ++++++++++-----------
extra/openssl/libcrypto/libcrypto.factor | 2 +-
extra/openssl/libssl/libssl.factor | 2 +-
extra/oracle/liboci/liboci.factor | 2 +-
16 files changed, 49 insertions(+), 75 deletions(-)
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index ae99f9e6bf..ca1a89b4ae 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -388,6 +388,6 @@ M: long-long-type box-return ( type -- )
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
- win64? "longlong" "long" ? "ptrdiff_t" typedef
+ os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit
diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index 9124efcb8c..9d25ee1138 100755
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -5,8 +5,6 @@ IN: system
ARTICLE: "os" "System interface"
"Operating system detection:"
{ $subsection os }
-{ $subsection win32? }
-{ $subsection win64? }
"Processor detection:"
{ $subsection cpu }
"Reading environment variables:"
@@ -86,14 +84,6 @@ HELP: set-os-envs
{ os-env os-envs set-os-envs } related-words
-HELP: win32?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 32-bit Windows." } ;
-
-HELP: win64?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 64-bit Windows." } ;
-
HELP: image
{ $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor image." } ;
diff --git a/core/system/system.factor b/core/system/system.factor
index 00b3f87e98..98dc605acc 100755
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -64,14 +64,6 @@ PRIVATE>
: vm ( -- path ) 14 getenv ;
-: win32? ( -- ? )
- os winnt?
- cell 4 = and ; foldable
-
-: win64? ( -- ? )
- os winnt?
- cell 8 = and ; foldable
-
: embedded? ( -- ? ) 15 getenv ;
: os-envs ( -- assoc )
diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor
index dd4faf9f96..200c85c929 100644
--- a/extra/cairo/ffi/ffi.factor
+++ b/extra/cairo/ffi/ffi.factor
@@ -7,13 +7,11 @@
! - most of the matrix stuff
! - most of the query functions
-
USING: alien alien.syntax combinators system ;
-
IN: cairo.ffi
<< "cairo" {
- { [ os win32? ] [ "libcairo-2.dll" ] }
+ { [ os winnt? ] [ "libcairo-2.dll" ] }
! { [ os macosx? ] [ "libcairo.dylib" ] }
{ [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
{ [ os unix? ] [ "libcairo.so.2" ] }
diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor
index 424cc7c754..c047393c99 100644
--- a/extra/db/mysql/ffi/ffi.factor
+++ b/extra/db/mysql/ffi/ffi.factor
@@ -6,7 +6,7 @@ USING: alien alien.syntax combinators kernel system ;
IN: db.mysql.ffi
<< "mysql" {
- { [ os win32? ] [ "libmySQL.dll" "stdcall" ] }
+ { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] }
{ [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
{ [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
} cond add-library >>
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index b6aee3dcce..7925989bf5 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -5,7 +5,7 @@ USING: alien alien.syntax combinators system ;
IN: db.postgresql.ffi
<< "postgresql" {
- { [ os win32? ] [ "libpq.dll" ] }
+ { [ os winnt? ] [ "libpq.dll" ] }
{ [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
{ [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor
index 9a6997ce29..37dd30f7fd 100644
--- a/extra/ogg/ogg.factor
+++ b/extra/ogg/ogg.factor
@@ -6,7 +6,7 @@ IN: ogg
<<
"ogg" {
- { [ os win32? ] [ "ogg.dll" ] }
+ { [ os winnt? ] [ "ogg.dll" ] }
{ [ os macosx? ] [ "libogg.0.dylib" ] }
{ [ os unix? ] [ "libogg.so" ] }
} cond "cdecl" add-library
diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor
index 12d2aa4efb..3d73fb8820 100644
--- a/extra/ogg/theora/theora.factor
+++ b/extra/ogg/theora/theora.factor
@@ -6,7 +6,7 @@ IN: ogg.theora
<<
"theora" {
- { [ os win32? ] [ "theora.dll" ] }
+ { [ os winnt? ] [ "theora.dll" ] }
{ [ os macosx? ] [ "libtheora.0.dylib" ] }
{ [ os unix? ] [ "libtheora.so" ] }
} cond "cdecl" add-library
diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor
index 6dbea7869a..5712272ebc 100644
--- a/extra/ogg/vorbis/vorbis.factor
+++ b/extra/ogg/vorbis/vorbis.factor
@@ -6,7 +6,7 @@ IN: ogg.vorbis
<<
"vorbis" {
- { [ os win32? ] [ "vorbis.dll" ] }
+ { [ os winnt? ] [ "vorbis.dll" ] }
{ [ os macosx? ] [ "libvorbis.0.dylib" ] }
{ [ os unix? ] [ "libvorbis.so" ] }
} cond "cdecl" add-library
diff --git a/extra/openal/backend/backend.factor b/extra/openal/backend/backend.factor
index edbb227fcc..41069dcddf 100644
--- a/extra/openal/backend/backend.factor
+++ b/extra/openal/backend/backend.factor
@@ -1,8 +1,4 @@
-USING: namespaces ;
+USING: namespaces system ;
IN: openal.backend
-SYMBOL: openal-backend
-HOOK: load-wav-file openal-backend ( filename -- format data size frequency )
-
-TUPLE: other-openal-backend ;
-T{ other-openal-backend } openal-backend set-global
+HOOK: load-wav-file os ( filename -- format data size frequency )
diff --git a/extra/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor
index 7828021f53..c03ad5693c 100644
--- a/extra/openal/macosx/macosx.factor
+++ b/extra/openal/macosx/macosx.factor
@@ -1,18 +1,14 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-IN: openal.macosx
-USING: alien.c-types kernel alien alien.syntax shuffle
-combinators.lib openal.backend namespaces ;
-
-TUPLE: macosx-openal-backend ;
-LIBRARY: alut
-
-T{ macosx-openal-backend } openal-backend set-global
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
-
-M: macosx-openal-backend load-wav-file ( path -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ alutLoadWAVFile ] 4keep
- >r >r >r *int r> *void* r> *int r> *int ;
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel alien alien.syntax shuffle
+combinators.lib openal.backend namespaces ;
+IN: openal.macosx
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
+
+M: macosx load-wav-file ( path -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ alutLoadWAVFile ] 4keep
+ >r >r >r *int r> *void* r> *int r> *int ;
diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor
index e37988a8ce..ff67a30ea3 100644
--- a/extra/openal/openal.factor
+++ b/extra/openal/openal.factor
@@ -1,20 +1,23 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-!
-IN: openal
USING: kernel alien system combinators alien.syntax namespaces
alien.c-types sequences vocabs.loader shuffle combinators.lib
openal.backend ;
+IN: openal
<< "alut" {
- { [ os win32? ] [ "alut.dll" ] }
- { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
+ { [ os windows? ] [ "alut.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
{ [ os unix? ] [ "libalut.so" ] }
} cond "cdecl" add-library >>
<< "openal" {
- { [ os win32? ] [ "OpenAL32.dll" ] }
- { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
+ { [ os windows? ] [ "OpenAL32.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
{ [ os unix? ] [ "libopenal.so" ] }
} cond "cdecl" add-library >>
@@ -290,4 +293,3 @@ os macosx? "openal.macosx" "openal.other" ? require
: source-playing? ( source -- bool )
AL_SOURCE_STATE get-source-param AL_PLAYING = ;
-
diff --git a/extra/openal/other/other.factor b/extra/openal/other/other.factor
index e32b007973..d0429fb3c3 100644
--- a/extra/openal/other/other.factor
+++ b/extra/openal/other/other.factor
@@ -1,14 +1,14 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-IN: openal.other
-USING: openal.backend alien.c-types kernel alien alien.syntax shuffle combinators.lib ;
-
-LIBRARY: alut
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
-
-M: other-openal-backend load-wav-file ( filename -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ 0 <char> alutLoadWAVFile ] 4keep
- >r >r >r *int r> *void* r> *int r> *int ;
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: openal.backend alien.c-types kernel alien alien.syntax
+shuffle combinators.lib ;
+IN: openal.other
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
+
+M: object load-wav-file ( filename -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ 0 <char> alutLoadWAVFile ] 4keep
+ >r >r >r *int r> *void* r> *int r> *int ;
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor
index a68cda34ea..312c7b04b3 100755
--- a/extra/openssl/libcrypto/libcrypto.factor
+++ b/extra/openssl/libcrypto/libcrypto.factor
@@ -11,7 +11,7 @@ IN: openssl.libcrypto
<<
"libcrypto" {
- { [ os win32? ] [ "libeay32.dll" "cdecl" ] }
+ { [ os winnt? ] [ "libeay32.dll" "cdecl" ] }
{ [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] }
{ [ os unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index 098e1f9382..0f2e7b3184 100755
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -10,7 +10,7 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libssl
<< "libssl" {
- { [ os win32? ] [ "ssleay32.dll" "cdecl" ] }
+ { [ os winnt? ] [ "ssleay32.dll" "cdecl" ] }
{ [ os macosx? ] [ "libssl.dylib" "cdecl" ] }
{ [ os unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor
index 6a482b9f56..7af69a97bb 100644
--- a/extra/oracle/liboci/liboci.factor
+++ b/extra/oracle/liboci/liboci.factor
@@ -12,7 +12,7 @@ USING: alien alien.syntax combinators kernel system ;
IN: oracle.liboci
"oci" {
- { [ os win32? ] [ "oci.dll" "stdcall" ] }
+ { [ os winnt? ] [ "oci.dll" "stdcall" ] }
{ [ os macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] }
{ [ os unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] }
} cond add-library
From 0d8a27e5e43f9d45b84bc0f3baeaf77495a26a55 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 19:23:26 -0500
Subject: [PATCH 062/288] update docs
---
core/system/system-docs.factor | 60 ++++++++++++++++++-----------
extra/help/handbook/handbook.factor | 2 +-
2 files changed, 39 insertions(+), 23 deletions(-)
diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index 9d25ee1138..df112bd786 100755
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -1,12 +1,12 @@
USING: generic help.markup help.syntax kernel math memory
-namespaces sequences kernel.private strings ;
+namespaces sequences kernel.private strings classes.singleton ;
IN: system
-ARTICLE: "os" "System interface"
-"Operating system detection:"
-{ $subsection os }
-"Processor detection:"
-{ $subsection cpu }
+ABOUT: "system"
+
+ARTICLE: "system" "System interface"
+{ $subsection "cpu" }
+{ $subsection "os" }
"Reading environment variables:"
{ $subsection os-env }
{ $subsection os-envs }
@@ -19,29 +19,45 @@ ARTICLE: "os" "System interface"
{ $subsection exit }
{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
-ABOUT: "os"
+ARTICLE: "cpu" "Processor Detection"
+"Processor detection:"
+{ $subsection cpu }
+"Supported processors:"
+{ $subsection x86.32 }
+{ $subsection x86.64 }
+{ $subsection ppc }
+{ $subsection arm }
+"Processor families:"
+{ $subsection x86 } ;
+
+ARTICLE: "os" "Operating System Detection"
+"Operating system detection:"
+{ $subsection os }
+"Supported operating systems:"
+{ $subsection freebsd }
+{ $subsection linux }
+{ $subsection macosx }
+{ $subsection openbsd }
+{ $subsection netbsd }
+{ $subsection solaris }
+{ $subsection wince }
+{ $subsection winnt }
+"Operating system families:"
+{ $subsection bsd }
+{ $subsection unix }
+{ $subsection windows } ;
+
HELP: cpu
-{ $values { "cpu" string } }
+{ $values { "class" singleton-class } }
{ $description
- "Outputs a singleton class with the name of the current CPU architecture. Currently, this set of descriptors is:"
- { $code x86.32 x86.64 ppc arm }
+ "Outputs a singleton class with the name of the current CPU architecture."
} ;
HELP: os
-{ $values { "os" string } }
+{ $values { "class" singleton-class } }
{ $description
- "Outputs a singleton class with the name of the current operating system family. Currently, this set of descriptors is:"
- { $code
- freebsd
- linux
- macosx
- openbsd
- netbsd
- solaris
- wince
- winnt
- }
+ "Outputs a singleton class with the name of the current operating system family."
} ;
HELP: embedded?
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index 1c2dfde85c..e45c49aa25 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -261,7 +261,7 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "collections" }
{ $subsection "io" }
{ $subsection "concurrency" }
-{ $subsection "os" }
+{ $subsection "system" }
{ $subsection "alien" }
{ $heading "Environment reference" }
{ $subsection "cli" }
From de30882cb1b74ac77df1188f0103f5cb0593cf7f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 19:23:37 -0500
Subject: [PATCH 063/288] fix load error
---
extra/hardware-info/hardware-info.factor | 4 +---
extra/hardware-info/windows/windows.factor | 4 ++--
2 files changed, 3 insertions(+), 5 deletions(-)
diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor
index 83e59b3123..ecdcc42cb5 100755
--- a/extra/hardware-info/hardware-info.factor
+++ b/extra/hardware-info/hardware-info.factor
@@ -6,11 +6,9 @@ IN: hardware-info
: megs. ( x -- ) 20 2^ /f . ;
: gigs. ( x -- ) 30 2^ /f . ;
-<<
-{
+<< {
{ [ os windows? ] [ "hardware-info.windows" ] }
{ [ os linux? ] [ "hardware-info.linux" ] }
{ [ os macosx? ] [ "hardware-info.macosx" ] }
{ [ t ] [ f ] }
} cond [ require ] when* >>
-
diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor
index f3a1eb33f5..807fd158ba 100755
--- a/extra/hardware-info/windows/windows.factor
+++ b/extra/hardware-info/windows/windows.factor
@@ -65,6 +65,6 @@ IN: hardware-info.windows
<<
{
- { [ wince? ] [ "hardware-info.windows.ce" ] }
- { [ winnt? ] [ "hardware-info.windows.nt" ] }
+ { [ os wince? ] [ "hardware-info.windows.ce" ] }
+ { [ os winnt? ] [ "hardware-info.windows.nt" ] }
} cond [ require ] when* >>
From 83d9b936b2ca8bbb17b972ec9db444aed0ec69bc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 19:44:01 -0500
Subject: [PATCH 064/288] change ui backends to singletons
---
extra/ui/cocoa/cocoa.factor | 4 ++--
extra/ui/windows/windows.factor | 4 ++--
extra/ui/x11/x11.factor | 4 ++--
3 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index 79b7041dcb..59adcf9af1 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -12,7 +12,7 @@ TUPLE: handle view window ;
C: <handle> handle
-TUPLE: cocoa-ui-backend ;
+SINGLETON: cocoa-ui-backend
SYMBOL: stop-after-last-window?
@@ -119,6 +119,6 @@ M: cocoa-ui-backend ui
] ui-running
] with-cocoa ;
-T{ cocoa-ui-backend } ui-backend set-global
+cocoa-ui-backend ui-backend set-global
[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index f47a82275b..e0c9f24122 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -10,7 +10,7 @@ shuffle opengl ui.render unicode.case ascii math.bitfields
locals symbols ;
IN: ui.windows
-TUPLE: windows-ui-backend ;
+SINGLETON: windows-ui-backend
: crlf>lf CHAR: \r swap remove ;
: lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
@@ -496,6 +496,6 @@ M: windows-ui-backend ui
] [ cleanup-win32-ui ] [ ] cleanup
] ui-running ;
-T{ windows-ui-backend } ui-backend set-global
+windows-ui-backend ui-backend set-global
[ "ui" ] main-vocab-hook set-global
diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor
index eaf87acace..9445486656 100755
--- a/extra/ui/x11/x11.factor
+++ b/extra/ui/x11/x11.factor
@@ -8,7 +8,7 @@ io.encodings.utf8 combinators debugger system command-line
ui.render math.vectors classes.tuple opengl.gl threads ;
IN: ui.x11
-TUPLE: x11-ui-backend ;
+SINGLETON: x11-ui-backend
: XA_NET_WM_NAME "_NET_WM_NAME" x-atom ;
@@ -259,7 +259,7 @@ M: x11-ui-backend ui ( -- )
] with-x
] ui-running ;
-T{ x11-ui-backend } ui-backend set-global
+x11-ui-backend ui-backend set-global
[ "DISPLAY" os-env "ui" "listener" ? ]
main-vocab-hook set-global
From 72c06fc028e56dd39f657b6c1f31494dd631a88a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 19:46:37 -0500
Subject: [PATCH 065/288] use OS symbol in deploy
---
extra/tools/deploy/backend/backend.factor | 4 +---
extra/tools/deploy/macosx/macosx.factor | 6 +-----
extra/tools/deploy/windows/windows.factor | 6 +-----
3 files changed, 3 insertions(+), 13 deletions(-)
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index 395c4ff924..e11d16c4ec 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -107,6 +107,4 @@ DEFER: ?make-staging-image
make-boot-image
deploy-command-line run-factor ;
-SYMBOL: deploy-implementation
-
-HOOK: deploy* deploy-implementation ( vocab -- )
+HOOK: deploy* os ( vocab -- )
diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor
index 6d9c8e9d8a..3a7f8e5d03 100755
--- a/extra/tools/deploy/macosx/macosx.factor
+++ b/extra/tools/deploy/macosx/macosx.factor
@@ -50,17 +50,13 @@ IN: tools.deploy.macosx
: bundle-name ( -- string )
deploy-name get ".app" append ;
-TUPLE: macosx-deploy-implementation ;
-
-T{ macosx-deploy-implementation } deploy-implementation set-global
-
: show-in-finder ( path -- )
NSWorkspace
-> sharedWorkspace
over <NSString> rot parent-directory <NSString>
-> selectFile:inFileViewerRootedAtPath: drop ;
-M: macosx-deploy-implementation deploy* ( vocab -- )
+M: macosx deploy* ( vocab -- )
".app deploy tool" assert.app
"resource:" [
dup deploy-config [
diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor
index 1c9a8195c5..33ab877ee1 100755
--- a/extra/tools/deploy/windows/windows.factor
+++ b/extra/tools/deploy/windows/windows.factor
@@ -25,11 +25,7 @@ IN: tools.deploy.windows
: image-name ( vocab bundle-name -- str )
prepend-path ".image" append ;
-TUPLE: windows-deploy-implementation ;
-
-T{ windows-deploy-implementation } deploy-implementation set-global
-
-M: windows-deploy-implementation deploy*
+M: winnt deploy*
"." resource-path [
dup deploy-config [
[ deploy-name get create-exe-dir ] keep
From c53e75ef0f54f52a86659eb3ec39f18bdcc2bf43 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 20:09:56 -0500
Subject: [PATCH 066/288] io backend now uses OS singletons
---
extra/io/unix/backend/backend.factor | 8 ++---
extra/io/unix/bsd/bsd.factor | 10 ++----
extra/io/unix/files/files.factor | 32 ++++++++++----------
extra/io/unix/files/unique/unique.factor | 6 ++--
extra/io/unix/freebsd/freebsd.factor | 9 ++----
extra/io/unix/launcher/launcher.factor | 8 ++---
extra/io/unix/linux/linux.factor | 10 ++----
extra/io/unix/macosx/macosx.factor | 12 +++-----
extra/io/unix/netbsd/netbsd.factor | 9 ++----
extra/io/unix/openbsd/openbsd.factor | 9 ++----
extra/io/windows/ce/backend/backend.factor | 8 ++---
extra/io/windows/ce/ce.factor | 16 ++++++----
extra/io/windows/ce/files/files.factor | 8 ++---
extra/io/windows/ce/sockets/sockets.factor | 16 +++++-----
extra/io/windows/files/files.factor | 8 ++---
extra/io/windows/files/unique/unique.factor | 4 +--
extra/io/windows/launcher/launcher.factor | 10 +++---
extra/io/windows/mmap/mmap.factor | 10 +++---
extra/io/windows/nt/backend/backend.factor | 10 +++---
extra/io/windows/nt/files/files.factor | 14 ++++-----
extra/io/windows/nt/launcher/launcher.factor | 4 +--
extra/io/windows/nt/monitors/monitors.factor | 4 +--
extra/io/windows/nt/nt.factor | 3 +-
extra/io/windows/nt/sockets/sockets.factor | 16 +++++-----
extra/io/windows/windows.factor | 30 ++++++++----------
25 files changed, 123 insertions(+), 151 deletions(-)
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 63d2adbdf7..865490b0ce 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -8,8 +8,6 @@ qualified namespaces io.timeouts io.encodings.utf8 accessors ;
QUALIFIED: io
IN: io.unix.backend
-MIXIN: unix-io
-
! I/O tasks
TUPLE: io-task port callbacks ;
@@ -120,7 +118,7 @@ M: integer close-handle ( fd -- )
[ dup reads>> handle-timeout ]
[ dup writes>> handle-timeout ] 2bi ;
-M: unix-io cancel-io ( port -- )
+M: unix cancel-io ( port -- )
mx get-global cancel-io-tasks ;
! Readers
@@ -180,10 +178,10 @@ M: write-task do-io-task
M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
-M: unix-io io-multiplex ( ms/f -- )
+M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
-M: unix-io (init-stdio) ( -- )
+M: unix (init-stdio) ( -- )
0 <reader>
1 <writer>
2 <writer> ;
diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor
index 89b0757da5..6f6517868e 100755
--- a/extra/io/unix/bsd/bsd.factor
+++ b/extra/io/unix/bsd/bsd.factor
@@ -3,7 +3,7 @@
IN: io.unix.bsd
USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
io.launcher io.unix.launcher namespaces kernel assocs
-threads continuations ;
+threads continuations system ;
! On Mac OS X, we use select() for the top-level
! multiplexer, and we hang a kqueue off of it for process exit
@@ -12,16 +12,12 @@ threads continuations ;
! kqueue is buggy with files and ptys so we can't use it as the
! main multiplexer.
-MIXIN: bsd-io
-
-INSTANCE: bsd-io unix-io
-
-M: bsd-io init-io ( -- )
+M: bsd init-io ( -- )
<select-mx> mx set-global
<kqueue-mx> kqueue-mx set-global
kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
2dup mx get-global mx-reads set-at
mx get-global mx-writes set-at ;
-M: bsd-io register-process ( process -- )
+M: bsd register-process ( process -- )
process-handle kqueue-mx get-global add-pid-task ;
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index 7d0e7c4330..f6bb3edcde 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -3,15 +3,15 @@
USING: io.backend io.nonblocking io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar
-io.encodings.binary accessors sequences strings ;
+io.encodings.binary accessors sequences strings system ;
IN: io.unix.files
-M: unix-io cwd ( -- path )
+M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
-M: unix-io cd ( path -- )
+M: unix cd ( path -- )
chdir io-error ;
: read-flags O_RDONLY ; inline
@@ -19,7 +19,7 @@ M: unix-io cd ( path -- )
: open-read ( path -- fd )
O_RDONLY file-mode open dup io-error ;
-M: unix-io (file-reader) ( path -- stream )
+M: unix (file-reader) ( path -- stream )
open-read <reader> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
@@ -27,7 +27,7 @@ M: unix-io (file-reader) ( path -- stream )
: open-write ( path -- fd )
write-flags file-mode open dup io-error ;
-M: unix-io (file-writer) ( path -- stream )
+M: unix (file-writer) ( path -- stream )
open-write <writer> ;
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
@@ -36,28 +36,28 @@ M: unix-io (file-writer) ( path -- stream )
append-flags file-mode open dup io-error
[ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ;
-M: unix-io (file-appender) ( path -- stream )
+M: unix (file-appender) ( path -- stream )
open-append <writer> ;
: touch-mode ( -- n )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
-M: unix-io touch-file ( path -- )
+M: unix touch-file ( path -- )
normalize-path
touch-mode file-mode open
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
close ;
-M: unix-io move-file ( from to -- )
+M: unix move-file ( from to -- )
[ normalize-path ] bi@ rename io-error ;
-M: unix-io delete-file ( path -- )
+M: unix delete-file ( path -- )
normalize-path unlink io-error ;
-M: unix-io make-directory ( path -- )
+M: unix make-directory ( path -- )
normalize-path OCT: 777 mkdir io-error ;
-M: unix-io delete-directory ( path -- )
+M: unix delete-directory ( path -- )
normalize-path rmdir io-error ;
: (copy-file) ( from to -- )
@@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal
] with-disposal ;
-M: unix-io copy-file ( from to -- )
+M: unix copy-file ( from to -- )
[ normalize-path ] bi@
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
@@ -95,16 +95,16 @@ M: unix-io copy-file ( from to -- )
} cleave
\ file-info construct-boa ;
-M: unix-io file-info ( path -- info )
+M: unix file-info ( path -- info )
normalize-path stat* stat>file-info ;
-M: unix-io link-info ( path -- info )
+M: unix link-info ( path -- info )
normalize-path lstat* stat>file-info ;
-M: unix-io make-link ( path1 path2 -- )
+M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ;
-M: unix-io read-link ( path -- path' )
+M: unix read-link ( path -- path' )
normalize-path
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ;
diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor
index c5365d8d5c..035e6398ee 100644
--- a/extra/io/unix/files/unique/unique.factor
+++ b/extra/io/unix/files/unique/unique.factor
@@ -1,11 +1,11 @@
USING: kernel io.nonblocking io.unix.backend math.bitfields
-unix io.files.unique.backend ;
+unix io.files.unique.backend system ;
IN: io.unix.files.unique
: open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ;
-M: unix-io (make-unique-file) ( path -- )
+M: unix (make-unique-file) ( path -- )
open-unique-flags file-mode open dup io-error close ;
-M: unix-io temporary-path ( -- path ) "/tmp" ;
+M: unix temporary-path ( -- path ) "/tmp" ;
diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor
index 65b4a6f0f7..49fbc9af7e 100644
--- a/extra/io/unix/freebsd/freebsd.factor
+++ b/extra/io/unix/freebsd/freebsd.factor
@@ -1,8 +1,3 @@
-IN: io.unix.freebsd
-USING: io.unix.bsd io.backend ;
+USING: io.unix.bsd io.backend system ;
-TUPLE: freebsd-io ;
-
-INSTANCE: freebsd-io bsd-io
-
-T{ freebsd-io } set-io-backend
+freebsd set-io-backend
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 4986024e78..8e5531a40c 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -79,12 +79,12 @@ USE: unix
(io-error)
] [ 255 exit ] recover ;
-M: unix-io current-process-handle ( -- handle ) getpid ;
+M: unix current-process-handle ( -- handle ) getpid ;
-M: unix-io run-process* ( process -- pid )
+M: unix run-process* ( process -- pid )
[ spawn-process ] curry [ ] with-fork ;
-M: unix-io kill-process* ( pid -- )
+M: unix kill-process* ( pid -- )
SIGTERM kill io-error ;
: open-pipe ( -- pair )
@@ -95,7 +95,7 @@ M: unix-io kill-process* ( pid -- )
2dup first close second close
>r first 0 dup2 drop r> second 1 dup2 drop ;
-M: unix-io (process-stream)
+M: unix (process-stream)
>r open-pipe open-pipe r>
[ >r setup-stdio-pipe r> spawn-process ] curry
[ -rot 2dup second close first close ]
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 2ae4065fb6..9f135f2958 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -7,10 +7,6 @@ namespaces threads continuations init math alien.c-types alien
vocabs.loader accessors ;
IN: io.unix.linux
-TUPLE: linux-io ;
-
-INSTANCE: linux-io unix-io
-
TUPLE: linux-monitor ;
: <linux-monitor> ( wd -- monitor )
@@ -50,7 +46,7 @@ TUPLE: inotify watches ;
"inotify is not supported by this Linux release" throw
] unless ;
-M: linux-io <monitor> ( path recursive? -- monitor )
+M: linux <monitor> ( path recursive? -- monitor )
check-inotify
drop IN_CHANGE_EVENTS add-watch ;
@@ -116,11 +112,11 @@ TUPLE: inotify-task ;
M: inotify-task do-io-task ( task -- )
io-task-port read-notifications f ;
-M: linux-io init-io ( -- )
+M: linux init-io ( -- )
<select-mx>
[ mx set-global ]
[ [ init-inotify ] curry ignore-errors ] bi ;
-T{ linux-io } set-io-backend
+linux set-io-backend
[ start-wait-thread ] "io.unix.linux" add-init-hook
diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor
index bd48fbc9b5..c1c73ea018 100644
--- a/extra/io/unix/macosx/macosx.factor
+++ b/extra/io/unix/macosx/macosx.factor
@@ -1,13 +1,9 @@
-IN: io.unix.macosx
USING: io.unix.bsd io.backend io.monitors io.monitors.private
continuations kernel core-foundation.fsevents sequences
-namespaces arrays ;
+namespaces arrays system ;
+IN: io.unix.macosx
-TUPLE: macosx-io ;
-
-INSTANCE: macosx-io bsd-io
-
-T{ macosx-io } set-io-backend
+macosx set-io-backend
TUPLE: macosx-monitor ;
@@ -16,7 +12,7 @@ TUPLE: macosx-monitor ;
[ [ first { +modify-file+ } swap changed-file ] each ] bind
notify-callback ;
-M: macosx-io <monitor>
+M: macosx <monitor>
drop
f macosx-monitor construct-simple-monitor
dup [ enqueue-notifications ] curry
diff --git a/extra/io/unix/netbsd/netbsd.factor b/extra/io/unix/netbsd/netbsd.factor
index 3aa8678702..c5771c8ffc 100644
--- a/extra/io/unix/netbsd/netbsd.factor
+++ b/extra/io/unix/netbsd/netbsd.factor
@@ -1,8 +1,3 @@
-IN: io.unix.netbsd
-USING: io.unix.bsd io.backend ;
+USING: io.backend system ;
-TUPLE: netbsd-io ;
-
-INSTANCE: netbsd-io bsd-io
-
-T{ netbsd-io } set-io-backend
+netbsd set-io-backend
diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor
index 767861ec75..9b3021646d 100644
--- a/extra/io/unix/openbsd/openbsd.factor
+++ b/extra/io/unix/openbsd/openbsd.factor
@@ -1,8 +1,3 @@
-IN: io.unix.openbsd
-USING: io.unix.bsd io.backend core-foundation.fsevents ;
+USING: io.unix.bsd io.backend core-foundation.fsevents system ;
-TUPLE: openbsd-io ;
-
-INSTANCE: openbsd-io bsd-io
-
-T{ openbsd-io } set-io-backend
+openbsd set-io-backend
diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor
index b8b024d710..a8ff4c14e3 100755
--- a/extra/io/windows/ce/backend/backend.factor
+++ b/extra/io/windows/ce/backend/backend.factor
@@ -7,10 +7,10 @@ IN: io.windows.ce.backend
: port-errored ( port -- )
win32-error-string swap set-port-error ;
-M: windows-ce-io io-multiplex ( ms -- )
+M: wince io-multiplex ( ms -- )
60 60 * 1000 * or (sleep) ;
-M: windows-ce-io add-completion ( handle -- ) drop ;
+M: wince add-completion ( handle -- ) drop ;
GENERIC: wince-read ( port port-handle -- )
@@ -26,14 +26,14 @@ M: port port-flush
dup dup port-handle wince-write port-flush
] if ;
-M: windows-ce-io init-io ( -- )
+M: wince init-io ( -- )
init-winsock ;
LIBRARY: libc
FUNCTION: void* _getstdfilex int fd ;
FUNCTION: void* _fileno void* file ;
-M: windows-ce-io (init-stdio) ( -- )
+M: wince (init-stdio) ( -- )
#! We support Windows NT too, to make this I/O backend
#! easier to debug.
512 default-buffer-size [
diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor
index 878f5899f6..a0a8de8513 100755
--- a/extra/io/windows/ce/ce.factor
+++ b/extra/io/windows/ce/ce.factor
@@ -1,7 +1,11 @@
-USING: io.backend io.windows io.windows.ce.backend
-io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher
-namespaces io.windows.mmap ;
-IN: io.windows.ce
-
+USE: io.backend
+USE: io.windows
+USE: io.windows.ce.backend
+USE: io.windows.ce.files
+USE: io.windows.ce.sockets
+USE: io.windows.ce.launcher
+USE: io.windows.mmap system
USE: io.windows.files
-T{ windows-ce-io } set-io-backend
+USE: system
+
+wince set-io-backend
diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor
index 1e5cedae57..8f7390aa7c 100755
--- a/extra/io/windows/ce/files/files.factor
+++ b/extra/io/windows/ce/files/files.factor
@@ -1,15 +1,15 @@
USING: alien alien.c-types combinators io io.backend io.buffers
io.files io.nonblocking io.windows kernel libc math namespaces
prettyprint sequences strings threads threads.private
-windows windows.kernel32 io.windows.ce.backend ;
+windows windows.kernel32 io.windows.ce.backend system ;
IN: windows.ce.files
-! M: windows-ce-io normalize-path ( string -- string )
+! M: wince normalize-path ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
-M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
+M: wince CreateFile-flags ( DWORD -- DWORD )
FILE_ATTRIBUTE_NORMAL bitor ;
-M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
+M: wince FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- )
swap [ drop port-errored ] [ swap n>buffer ] if ;
diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor
index 9bc583a3d8..0001bb5142 100755
--- a/extra/io/windows/ce/sockets/sockets.factor
+++ b/extra/io/windows/ce/sockets/sockets.factor
@@ -2,11 +2,11 @@ USING: alien alien.c-types combinators io io.backend io.buffers
io.nonblocking io.sockets io.sockets.impl io.windows kernel libc
math namespaces prettyprint qualified sequences strings threads
threads.private windows windows.kernel32 io.windows.ce.backend
-byte-arrays ;
+byte-arrays system ;
QUALIFIED: windows.winsock
IN: io.windows.ce
-M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
+M: wince WSASocket-flags ( -- DWORD ) 0 ;
M: win32-socket wince-read ( port port-handle -- )
win32-file-handle over buffer-end pick buffer-capacity 0
@@ -31,15 +31,15 @@ M: win32-socket wince-write ( port port-handle -- )
windows.winsock:WSAConnect
windows.winsock:winsock-error!=0/f ;
-M: windows-ce-io (client) ( addrspec -- reader writer )
+M: wince (client) ( addrspec -- reader writer )
do-connect <win32-socket> dup <reader&writer> ;
-M: windows-ce-io (server) ( addrspec -- handle )
+M: wince (server) ( addrspec -- handle )
windows.winsock:SOCK_STREAM server-fd
dup listen-on-socket
<win32-socket> ;
-M: windows-ce-io (accept) ( server -- client )
+M: wince (accept) ( server -- client )
[
dup check-server-port
[
@@ -55,7 +55,7 @@ M: windows-ce-io (accept) ( server -- client )
<win32-socket> <reader&writer>
] with-timeout ;
-M: windows-ce-io <datagram> ( addrspec -- datagram )
+M: wince <datagram> ( addrspec -- datagram )
[
windows.winsock:SOCK_DGRAM server-fd <win32-socket>
] keep <datagram-port> ;
@@ -81,7 +81,7 @@ M: windows-ce-io <datagram> ( addrspec -- datagram )
packet-size <byte-array> receive-buffer set-global
-M: windows-ce-io receive ( datagram -- packet addrspec )
+M: wince receive ( datagram -- packet addrspec )
dup check-datagram-port
[
port-handle win32-file-handle
@@ -104,7 +104,7 @@ M: windows-ce-io receive ( datagram -- packet addrspec )
dup length receive-buffer rot pick memcpy
receive-buffer make-WSABUF ;
-M: windows-ce-io send ( packet addrspec datagram -- )
+M: wince send ( packet addrspec datagram -- )
3dup check-datagram-send
port-handle win32-file-handle
rot send-WSABUF
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index a23a78b3da..4f31d2dfce 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -3,7 +3,7 @@
USING: alien.c-types io.backend io.files io.windows kernel math
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols
-combinators.lib io.nonblocking destructors ;
+combinators.lib io.nonblocking destructors system ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
@@ -88,10 +88,10 @@ SYMBOLS: +read-only+ +hidden+ +system+
get-file-information BY_HANDLE_FILE_INFORMATION>file-info
] if ;
-M: windows-nt-io file-info ( path -- info )
+M: winnt file-info ( path -- info )
normalize-path get-file-information-stat ;
-M: windows-nt-io link-info ( path -- info )
+M: winnt link-info ( path -- info )
file-info ;
: file-times ( path -- timestamp timestamp timestamp )
@@ -125,7 +125,7 @@ M: windows-nt-io link-info ( path -- info )
: set-file-write-time ( path timestamp -- )
>r f f r> set-file-times ;
-M: windows-nt-io touch-file ( path -- )
+M: winnt touch-file ( path -- )
[
normalize-path
maybe-create-file over close-always
diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor
index 7e7610eb72..0449980286 100644
--- a/extra/io/windows/files/unique/unique.factor
+++ b/extra/io/windows/files/unique/unique.factor
@@ -2,9 +2,9 @@ USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.nonblocking windows ;
IN: io.windows.files.unique
-M: windows-io (make-unique-file) ( path -- )
+M: windows (make-unique-file) ( path -- )
GENERIC_WRITE CREATE_NEW 0 open-file
CloseHandle win32-error=0/f ;
-M: windows-io temporary-path ( -- path )
+M: windows temporary-path ( -- path )
"TEMP" os-env ;
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 3f230a4ac0..2724966a8f 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -101,7 +101,7 @@ TUPLE: CreateProcess-args
HOOK: fill-redirection io-backend ( process args -- )
-M: windows-ce-io fill-redirection 2drop ;
+M: wince fill-redirection 2drop ;
: make-CreateProcess-args ( process -- args )
default-CreateProcess-args
@@ -111,10 +111,10 @@ M: windows-ce-io fill-redirection 2drop ;
fill-startup-info
nip ;
-M: windows-io current-process-handle ( -- handle )
+M: windows current-process-handle ( -- handle )
GetCurrentProcessId ;
-M: windows-io run-process* ( process -- handle )
+M: windows run-process* ( process -- handle )
[
dup make-CreateProcess-args
tuck fill-redirection
@@ -122,7 +122,7 @@ M: windows-io run-process* ( process -- handle )
lpProcessInformation>>
] with-destructors ;
-M: windows-io kill-process* ( handle -- )
+M: windows kill-process* ( handle -- )
PROCESS_INFORMATION-hProcess
255 TerminateProcess win32-error=0/f ;
@@ -161,7 +161,7 @@ SYMBOL: wait-flag
<flag> wait-flag set-global
[ wait-loop t ] "Process wait" spawn-server drop ;
-M: windows-io register-process
+M: windows register-process
drop wait-flag get-global raise-flag ;
[ start-wait-thread ] "io.windows.launcher" add-init-hook
diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor
index d1cafa4c0f..8d3690bbb5 100755
--- a/extra/io/windows/mmap/mmap.factor
+++ b/extra/io/windows/mmap/mmap.factor
@@ -1,7 +1,7 @@
USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.nonblocking io.windows
kernel libc math namespaces quotations sequences windows
-windows.advapi32 windows.kernel32 io.backend ;
+windows.advapi32 windows.kernel32 io.backend system ;
IN: io.windows.mmap
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
@@ -53,11 +53,11 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
HOOK: with-privileges io-backend ( seq quot -- ) inline
-M: windows-nt-io with-privileges
+M: winnt with-privileges
over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
-M: windows-ce-io with-privileges
+M: wince with-privileges
nip call ;
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
@@ -70,7 +70,7 @@ M: windows-ce-io with-privileges
dup close-later
] with-privileges ;
-M: windows-io <mapped-file> ( path length -- mmap )
+M: windows <mapped-file> ( path length -- mmap )
[
swap
GENERIC_WRITE GENERIC_READ bitor
@@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
f \ mapped-file construct-boa
] with-destructors ;
-M: windows-io close-mapped-file ( mapped-file -- )
+M: windows close-mapped-file ( mapped-file -- )
[
dup mapped-file-handle [ close-always ] each
mapped-file-address UnmapViewOfFile win32-error=0/f
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index dcd13895b2..822973b85b 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -3,7 +3,7 @@ continuations destructors io io.backend io.nonblocking
io.windows libc kernel math namespaces sequences
threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii
-combinators.lib ;
+combinators.lib system ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
@@ -28,7 +28,7 @@ SYMBOL: master-completion-port
: <master-completion-port> ( -- handle )
INVALID_HANDLE_VALUE f <completion-port> ;
-M: windows-nt-io add-completion ( handle -- )
+M: winnt add-completion ( handle -- )
master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? )
@@ -89,13 +89,13 @@ M: windows-nt-io add-completion ( handle -- )
: drain-overlapped ( timeout -- )
handle-overlapped [ 0 drain-overlapped ] unless ;
-M: windows-nt-io cancel-io
+M: winnt cancel-io
port-handle win32-file-handle CancelIo drop ;
-M: windows-nt-io io-multiplex ( ms -- )
+M: winnt io-multiplex ( ms -- )
drain-overlapped ;
-M: windows-nt-io init-io ( -- )
+M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global
windows.winsock:init-winsock ;
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 91ad0139b2..7bac540ddc 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -1,22 +1,22 @@
USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend
-kernel libc math threads windows windows.kernel32
+kernel libc math threads windows windows.kernel32 system
alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs namespaces ;
IN: io.windows.nt.files
-M: windows-nt-io cwd
+M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
alien>u16-string ;
-M: windows-nt-io cd
+M: winnt cd
SetCurrentDirectory win32-error=0/f ;
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
-M: windows-nt-io root-directory? ( path -- ? )
+M: winnt root-directory? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] }
@@ -40,15 +40,15 @@ ERROR: not-absolute-path ;
unicode-prefix prepend
] unless ;
-M: windows-nt-io normalize-path ( string -- string' )
+M: winnt normalize-path ( string -- string' )
(normalize-path)
{ { CHAR: / CHAR: \\ } } substitute
prepend-prefix ;
-M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
+M: winnt CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
-M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
+M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
: update-file-ptr ( n port -- )
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index 895890e898..4bbf7c8e32 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -112,13 +112,13 @@ IN: io.windows.nt.launcher
dup pipe-out f set-inherit
>>stdin-pipe ;
-M: windows-nt-io fill-redirection ( process args -- )
+M: winnt fill-redirection ( process args -- )
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
[ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
[ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
2drop ;
-M: windows-nt-io (process-stream)
+M: winnt (process-stream)
[
dup make-CreateProcess-args
diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor
index 83e062c3a9..164b529b61 100755
--- a/extra/io/windows/nt/monitors/monitors.factor
+++ b/extra/io/windows/nt/monitors/monitors.factor
@@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations
io.monitors io.monitors.private io.nonblocking io.buffers
io.files io.timeouts io sequences hashtables sorting arrays
-combinators math.bitfields strings ;
+combinators math.bitfields strings system ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
@@ -30,7 +30,7 @@ TUPLE: win32-monitor path recursive? ;
set-delegate
} win32-monitor construct ;
-M: windows-nt-io <monitor> ( path recursive? -- monitor )
+M: winnt <monitor> ( path recursive? -- monitor )
[
over open-directory win32-monitor <buffered-port>
<win32-monitor>
diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor
index 1baec5658f..33bb3a88b9 100755
--- a/extra/io/windows/nt/nt.factor
+++ b/extra/io/windows/nt/nt.factor
@@ -11,5 +11,6 @@ USE: io.windows.nt.sockets
USE: io.windows.mmap
USE: io.windows.files
USE: io.backend
+USE: system
-T{ windows-nt-io } set-io-backend
+winnt set-io-backend
diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor
index 85bb34b225..36acaac992 100755
--- a/extra/io/windows/nt/sockets/sockets.factor
+++ b/extra/io/windows/nt/sockets/sockets.factor
@@ -2,13 +2,13 @@ USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
-threads classes.tuple.lib ;
+threads classes.tuple.lib system ;
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
"int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
-M: windows-nt-io WSASocket-flags ( -- DWORD )
+M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
: get-ConnectEx-ptr ( socket -- void* )
@@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port
2dup save-callback
get-overlapped-result drop ;
-M: windows-nt-io (client) ( addrspec -- client-in client-out )
+M: winnt (client) ( addrspec -- client-in client-out )
[
\ ConnectEx-args construct-empty
over make-sockaddr/size pick init-connect
@@ -119,7 +119,7 @@ TUPLE: AcceptEx-args port
[ AcceptEx-args-sAcceptSocket* add-completion ] keep
AcceptEx-args-sAcceptSocket* <win32-socket> ;
-M: windows-nt-io (accept) ( server -- addrspec handle )
+M: winnt (accept) ( server -- addrspec handle )
[
[
dup check-server-port
@@ -131,14 +131,14 @@ M: windows-nt-io (accept) ( server -- addrspec handle )
] with-timeout
] with-destructors ;
-M: windows-nt-io (server) ( addrspec -- handle )
+M: winnt (server) ( addrspec -- handle )
[
SOCK_STREAM server-fd dup listen-on-socket
dup add-completion
<win32-socket>
] with-destructors ;
-M: windows-nt-io <datagram> ( addrspec -- datagram )
+M: winnt <datagram> ( addrspec -- datagram )
[
[
SOCK_DGRAM server-fd
@@ -190,7 +190,7 @@ TUPLE: WSARecvFrom-args port
[ WSARecvFrom-args-lpFrom* ] keep
WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
-M: windows-nt-io receive ( datagram -- packet addrspec )
+M: winnt receive ( datagram -- packet addrspec )
[
dup check-datagram-port
\ WSARecvFrom-args construct-empty
@@ -242,7 +242,7 @@ TUPLE: WSASendTo-args port
USE: io.sockets
-M: windows-nt-io send ( packet addrspec datagram -- )
+M: winnt send ( packet addrspec datagram -- )
[
3dup check-datagram-send
\ WSASendTo-args construct-empty
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 45c1adaf50..7755f111c6 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -5,16 +5,12 @@ io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings io.streams.duplex
kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
-continuations math.bitfields ;
+continuations math.bitfields system ;
IN: io.windows
-TUPLE: windows-nt-io ;
-TUPLE: windows-ce-io ;
-UNION: windows-io windows-nt-io windows-ce-io ;
+M: windows destruct-handle CloseHandle drop ;
-M: windows-io destruct-handle CloseHandle drop ;
-
-M: windows-io destruct-socket closesocket drop ;
+M: windows destruct-socket closesocket drop ;
TUPLE: win32-file handle ptr ;
@@ -24,7 +20,7 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
-M: windows-io normalize-directory ( string -- string )
+M: windows normalize-directory ( string -- string )
normalize-path "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
@@ -125,30 +121,30 @@ C: <FileArgs> FileArgs
[ FileArgs-lpNumberOfBytesRet ] keep
FileArgs-lpOverlapped ;
-M: windows-io (file-reader) ( path -- stream )
+M: windows (file-reader) ( path -- stream )
open-read <win32-file> <reader> ;
-M: windows-io (file-writer) ( path -- stream )
+M: windows (file-writer) ( path -- stream )
open-write <win32-file> <writer> ;
-M: windows-io (file-appender) ( path -- stream )
+M: windows (file-appender) ( path -- stream )
open-append <win32-file> <writer> ;
-M: windows-io move-file ( from to -- )
+M: windows move-file ( from to -- )
[ normalize-path ] bi@ MoveFile win32-error=0/f ;
-M: windows-io delete-file ( path -- )
+M: windows delete-file ( path -- )
normalize-path DeleteFile win32-error=0/f ;
-M: windows-io copy-file ( from to -- )
+M: windows copy-file ( from to -- )
dup parent-directory make-directories
[ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
-M: windows-io make-directory ( path -- )
+M: windows make-directory ( path -- )
normalize-path
f CreateDirectory win32-error=0/f ;
-M: windows-io delete-directory ( path -- )
+M: windows delete-directory ( path -- )
normalize-path
RemoveDirectory win32-error=0/f ;
@@ -194,7 +190,7 @@ USE: namespaces
M: win32-socket dispose ( stream -- )
win32-file-handle closesocket drop ;
-M: windows-io addrinfo-error ( n -- )
+M: windows addrinfo-error ( n -- )
winsock-return-check ;
: tcp-socket ( addrspec -- socket )
From 5de68cd30f3bcf16177aab4344feeeebaa4c5c1e Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Wed, 2 Apr 2008 20:33:36 -0500
Subject: [PATCH 067/288] fix bootstrap on intel mac
---
extra/io/unix/mmap/mmap.factor | 4 ++--
extra/io/unix/sockets/sockets.factor | 16 ++++++++--------
extra/io/unix/unix.factor | 2 +-
extra/unix/bsd/bsd.factor | 8 ++++----
extra/unix/kqueue/kqueue.factor | 2 +-
extra/unix/types/types.factor | 23 ++++++++++-------------
extra/unix/unix.factor | 6 +++---
7 files changed, 29 insertions(+), 32 deletions(-)
diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor
index 71c55f2303..f042366b13 100755
--- a/extra/io/unix/mmap/mmap.factor
+++ b/extra/io/unix/mmap/mmap.factor
@@ -10,12 +10,12 @@ IN: io.unix.mmap
>r f -roll r> open-r/w [ 0 mmap ] keep
over MAP_FAILED = [ close (io-error) ] when ;
-M: unix-io <mapped-file> ( path length -- obj )
+M: unix <mapped-file> ( path length -- obj )
swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
r> mmap-open f mapped-file construct-boa ;
-M: unix-io close-mapped-file ( mmap -- )
+M: unix close-mapped-file ( mmap -- )
[ mapped-file-address ] keep
[ mapped-file-length munmap ] keep
mapped-file-handle close
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index 69ce6a3069..477757e0ed 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend io.files ;
+combinators io.backend io.files system ;
IN: io.unix.sockets
: pending-init-error ( port -- )
@@ -23,7 +23,7 @@ IN: io.unix.sockets
: sockopt ( fd level opt -- )
1 <int> "int" heap-size setsockopt io-error ;
-M: unix-io addrinfo-error ( n -- )
+M: unix addrinfo-error ( n -- )
dup zero? [ drop ] [ gai_strerror throw ] if ;
! Client sockets - TCP and Unix domain
@@ -42,7 +42,7 @@ M: connect-task do-io-task
: wait-to-connect ( port -- )
[ <connect-task> add-io-task ] with-port-continuation drop ;
-M: unix-io (client) ( addrspec -- client-in client-out )
+M: unix (client) ( addrspec -- client-in client-out )
dup make-sockaddr/size >r >r
protocol-family SOCK_STREAM socket-fd
dup r> r> connect
@@ -91,11 +91,11 @@ USE: io.sockets
dup rot make-sockaddr/size bind
zero? [ dup close (io-error) ] unless ;
-M: unix-io (server) ( addrspec -- handle )
+M: unix (server) ( addrspec -- handle )
SOCK_STREAM server-fd
dup 10 listen zero? [ dup close (io-error) ] unless ;
-M: unix-io (accept) ( server -- addrspec handle )
+M: unix (accept) ( server -- addrspec handle )
#! Wait for a client connection.
dup check-server-port
dup wait-to-accept
@@ -104,7 +104,7 @@ M: unix-io (accept) ( server -- addrspec handle )
swap server-port-client ;
! Datagram sockets - UDP and Unix domain
-M: unix-io <datagram>
+M: unix <datagram>
[ SOCK_DGRAM server-fd ] keep <datagram-port> ;
SYMBOL: receive-buffer
@@ -147,7 +147,7 @@ M: receive-task do-io-task
: wait-receive ( stream -- )
[ <receive-task> add-io-task ] with-port-continuation drop ;
-M: unix-io receive ( datagram -- packet addrspec )
+M: unix receive ( datagram -- packet addrspec )
dup check-datagram-port
dup wait-receive
dup pending-error
@@ -179,7 +179,7 @@ M: send-task do-io-task
[ <send-task> add-io-task ] with-port-continuation
2drop 2drop ;
-M: unix-io send ( packet addrspec datagram -- )
+M: unix send ( packet addrspec datagram -- )
3dup check-datagram-send
[ >r make-sockaddr/size r> wait-send ] keep
pending-error ;
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index f6607d98f9..b4328f31b3 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -1,5 +1,5 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
-system vocabs.loader sequences ;
+system vocabs.loader sequences words ;
"io.unix." os word-name append require
diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor
index 6cb5d6385b..d80db44348 100755
--- a/extra/unix/bsd/bsd.factor
+++ b/extra/unix/bsd/bsd.factor
@@ -73,8 +73,8 @@ C-STRUCT: sockaddr-un
: SEEK_END 2 ; inline
os {
- { "macosx" [ "unix.bsd.macosx" require ] }
- { "freebsd" [ "unix.bsd.freebsd" require ] }
- { "openbsd" [ "unix.bsd.openbsd" require ] }
- { "netbsd" [ "unix.bsd.netbsd" require ] }
+ { macosx [ "unix.bsd.macosx" require ] }
+ { freebsd [ "unix.bsd.freebsd" require ] }
+ { openbsd [ "unix.bsd.openbsd" require ] }
+ { netbsd [ "unix.bsd.netbsd" require ] }
} case
diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor
index 50020072c5..080820ebd0 100644
--- a/extra/unix/kqueue/kqueue.factor
+++ b/extra/unix/kqueue/kqueue.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system sequences vocabs.loader ;
+USING: alien.syntax system sequences vocabs.loader words ;
IN: unix.kqueue
<< "unix.kqueue." os word-name append require >>
diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor
index 983d5d677d..0ac2fa608e 100644
--- a/extra/unix/types/types.factor
+++ b/extra/unix/types/types.factor
@@ -1,17 +1,14 @@
-
-USING: kernel system alien.syntax combinators vocabs.loader ;
-
+USING: kernel system alien.syntax combinators vocabs.loader
+system ;
IN: unix.types
TYPEDEF: void* caddr_t
-os
- {
- { "linux" [ "unix.types.linux" require ] }
- { "macosx" [ "unix.types.macosx" require ] }
- { "freebsd" [ "unix.types.freebsd" require ] }
- { "openbsd" [ "unix.types.openbsd" require ] }
- { "netbsd" [ "unix.types.netbsd" require ] }
- { "winnt" [ ] }
- }
-case
+os {
+ { linux [ "unix.types.linux" require ] }
+ { macosx [ "unix.types.macosx" require ] }
+ { freebsd [ "unix.types.freebsd" require ] }
+ { openbsd [ "unix.types.openbsd" require ] }
+ { netbsd [ "unix.types.netbsd" require ] }
+ { winnt [ ] }
+} case
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index ffd102901c..e911a5c039 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -161,8 +161,8 @@ FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
{
- { [ linux? ] [ "unix.linux" require ] }
- { [ bsd? ] [ "unix.bsd" require ] }
- { [ solaris? ] [ "unix.solaris" require ] }
+ { [ os linux? ] [ "unix.linux" require ] }
+ { [ os bsd? ] [ "unix.bsd" require ] }
+ { [ os solaris? ] [ "unix.solaris" require ] }
} cond
From f10f601e3f17fe2a437f1badfe5638946084a225 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 20:50:20 -0500
Subject: [PATCH 068/288] fix teh bootstrap
---
extra/io/unix/linux/linux.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 9f135f2958..a452878a43 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -4,7 +4,7 @@ USING: kernel io.backend io.monitors io.monitors.private
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
io.unix.select io.unix.launcher unix.linux.inotify assocs
namespaces threads continuations init math alien.c-types alien
-vocabs.loader accessors ;
+vocabs.loader accessors system ;
IN: io.unix.linux
TUPLE: linux-monitor ;
From 5346e1899f2fea2bccdad4ed55adbb6cfd471160 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 21:27:49 -0500
Subject: [PATCH 069/288] Working on call-next-method, and identity-tuple
---
core/bootstrap/compiler/compiler.factor | 6 ---
core/bootstrap/image/image.factor | 1 -
core/bootstrap/primitives.factor | 25 +++++------
core/bootstrap/syntax.factor | 1 +
core/classes/algebra/algebra-tests.factor | 4 +-
core/classes/classes-docs.factor | 1 -
core/classes/classes-tests.factor | 9 +++-
core/classes/classes.factor | 5 ++-
core/classes/tuple/tuple-docs.factor | 8 ----
core/classes/tuple/tuple-tests.factor | 31 +++++++++++++
core/classes/tuple/tuple.factor | 44 ++++++++-----------
core/compiler/compiler-docs.factor | 15 +++++--
core/compiler/compiler.factor | 6 +++
core/definitions/definitions-tests.factor | 2 +-
core/generic/generic-tests.factor | 23 ----------
core/generic/generic.factor | 23 +++++-----
core/generic/math/math.factor | 4 +-
.../standard/engines/tuple/tuple.factor | 2 +-
core/generic/standard/standard.factor | 37 ++++++++++++----
core/inference/class/class-tests.factor | 14 +++++-
core/inference/class/class.factor | 17 +++++--
core/inference/dataflow/dataflow.factor | 9 ++--
.../transforms/transforms-tests.factor | 5 ++-
core/inference/transforms/transforms.factor | 10 ++++-
core/kernel/kernel-docs.factor | 40 ++++++++++-------
core/kernel/kernel.factor | 44 +++++++++++--------
core/optimizer/control/control.factor | 2 +-
core/optimizer/inlining/inlining.factor | 12 ++++-
core/optimizer/known-words/known-words.factor | 2 +-
core/optimizer/math/math.factor | 2 +-
core/parser/parser.factor | 12 ++++-
core/prettyprint/prettyprint-tests.factor | 2 -
core/sequences/sequences.factor | 3 ++
core/syntax/syntax-docs.factor | 2 +-
core/syntax/syntax.factor | 6 +++
core/vocabs/vocabs.factor | 8 +---
core/words/words.factor | 2 +-
extra/io/launcher/launcher.factor | 4 +-
extra/io/sockets/impl/impl.factor | 9 ++--
extra/models/models.factor | 5 +--
extra/ui/freetype/freetype.factor | 5 +--
extra/ui/gadgets/gadgets.factor | 8 ++--
extra/ui/gadgets/worlds/worlds.factor | 4 +-
43 files changed, 279 insertions(+), 195 deletions(-)
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 7d4db3c473..035d95d3ab 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -16,12 +16,6 @@ IN: bootstrap.compiler
"cpu." cpu append require
-: enable-compiler ( -- )
- [ optimized-recompile-hook ] recompile-hook set-global ;
-
-: disable-compiler ( -- )
- [ default-recompile-hook ] recompile-hook set-global ;
-
enable-compiler
nl
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index f0d9b77981..fc963683b6 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -444,7 +444,6 @@ PRIVATE>
"resource:/core/bootstrap/stage1.factor" run-file
build-image
write-image
- \ word-props target-word
] with-scope ;
: make-images ( -- )
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 6c4462ed98..f3846de5b1 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -159,17 +159,24 @@ num-types get f <array> builtins set
"tuple-layout" "classes.tuple.private" create register-builtin
! Catch-all class for providing a default method.
-"object" "kernel" create [ drop t ] "predicate" set-word-prop
"object" "kernel" create
-f builtins get [ ] subset union-class define-class
+[ f builtins get [ ] subset union-class define-class ]
+[ [ drop t ] "predicate" set-word-prop ]
+bi
+
+"object?" "kernel" vocab-words delete-at
! Class of objects with object tag
"hi-tag" "kernel.private" create
-f builtins get num-tags get tail union-class define-class
+builtins get num-tags get tail define-union-class
! Empty class with no instances
-"null" "kernel" create [ drop f ] "predicate" set-word-prop
-"null" "kernel" create f { } union-class define-class
+"null" "kernel" create
+[ f { } union-class define-class ]
+[ [ drop f ] "predicate" set-word-prop ]
+bi
+
+"null?" "kernel" vocab-words delete-at
"fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@@ -378,17 +385,9 @@ define-builtin
]
} cleave
-! Define general-t type, which is any object that is not f.
-"general-t" "kernel" create
-f "f" "syntax" lookup builtins get remove [ ] subset union-class
-define-class
-
"f" "syntax" create [ not ] "predicate" set-word-prop
"f?" "syntax" vocab-words delete-at
-"general-t" "kernel" create [ ] "predicate" set-word-prop
-"general-t?" "kernel" vocab-words delete-at
-
! Create special tombstone values
"tombstone" "hashtables.private" create
"tuple" "kernel" lookup
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index e7e90d8dd0..b3e5cb0120 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -66,6 +66,7 @@ IN: bootstrap.syntax
"CS{"
"<<"
">>"
+ "call-next-method"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index 32664dc823..0f468908a9 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -23,8 +23,8 @@ random inference effects kernel.private ;
[ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test
-[ t ] [ general-t \ f null class-and* ] unit-test
-[ t ] [ general-t \ f object class-or* ] unit-test
+[ t ] [ \ f class-not \ f null class-and* ] unit-test
+[ t ] [ \ f class-not \ f object class-or* ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 9573de8949..0560a0e755 100755
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -21,7 +21,6 @@ $nl
{ { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } }
{ { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } }
{ { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } }
- { { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } }
}
"The set of class predicate words is a class:"
{ $subsection predicate }
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index ae9e6ec154..ae19f38d14 100755
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
-compiler.units ;
+compiler.units kernel.private ;
IN: classes.tests
! DEFER: bah
@@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
! Test generic see and parsing
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test
+
+[ t ] [ 3 object instance? ] unit-test
+[ t ] [ 3 fixnum instance? ] unit-test
+[ f ] [ 3 float instance? ] unit-test
+[ t ] [ 3 number instance? ] unit-test
+[ f ] [ 3 null instance? ] unit-test
+[ t ] [ "hi" \ hi-tag instance? ] unit-test
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 0baf235edb..c45fd7360b 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -60,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
dup class? [ "superclass" word-prop ] [ drop f ] if ;
: superclasses ( class -- supers )
- [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ;
+ [ superclass ] follow reverse ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
@@ -133,3 +133,6 @@ GENERIC: class ( object -- class )
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;
+
+: instance? ( obj class -- ? )
+ "predicate" word-prop call ;
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 18c8143654..664f0545fa 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -153,14 +153,6 @@ HELP: tuple=
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
-HELP: removed-slots
-{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
-{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
-
-HELP: forget-removed-slots
-{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
-{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
-
HELP: tuple
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
$nl
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index ff34c25416..735f328a67 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -511,3 +511,34 @@ USE: vocabs
define-tuple-class
] with-compilation-unit
] unit-test
+
+[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with
+
+! Accessors not being forgotten...
+[ [ ] ] [
+ "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
+ <string-reader>
+ "forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+: accessor-exists? ( class name -- ? )
+ >r "forget-accessors-test" "classes.tuple.tests" lookup r>
+ ">>" append "accessors" lookup method >boolean ;
+
+[ t ] [ "x" accessor-exists? ] unit-test
+[ t ] [ "y" accessor-exists? ] unit-test
+[ t ] [ "z" accessor-exists? ] unit-test
+
+[ [ ] ] [
+ "IN: classes.tuple.tests GENERIC: forget-accessors-test"
+ <string-reader>
+ "forget-accessors-test" parse-stream
+] unit-test
+
+[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+[ f ] [ "x" accessor-exists? ] unit-test
+[ f ] [ "y" accessor-exists? ] unit-test
+[ f ] [ "z" accessor-exists? ] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index bbc221b85d..ac1a7b8849 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -19,7 +19,7 @@ ERROR: no-tuple-class class ;
GENERIC: tuple-layout ( object -- layout )
-M: class tuple-layout "layout" word-prop ;
+M: tuple-class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
@@ -40,7 +40,9 @@ PRIVATE>
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
- prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ;
+ prepare-tuple>array
+ >r copy-tuple-slots r>
+ layout-class prefix ;
: tuple-slots ( tuple -- array )
prepare-tuple>array drop copy-tuple-slots ;
@@ -120,15 +122,6 @@ PRIVATE>
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: removed-slots ( class newslots -- seq )
- swap slot-names seq-diff ;
-
-: forget-removed-slots ( class slots -- )
- dupd removed-slots [
- [ reader-word forget-method ]
- [ writer-word forget-method ] 2bi
- ] with each ;
-
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
@@ -189,9 +182,8 @@ M: tuple-class update-class
tri
] each-subclass
]
- [ nip forget-removed-slots ]
[ define-new-tuple-class ]
- 3tri ;
+ 3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
@@ -213,7 +205,19 @@ M: tuple-class define-tuple-class
dup [ construct-boa throw ] curry define ;
M: tuple-class reset-class
- { "metaclass" "superclass" "slots" "layout" } reset-props ;
+ [
+ dup "slot-names" word-prop [
+ [ reader-word forget-method ]
+ [ writer-word forget-method ] 2bi
+ ] with each
+ ] [
+ {
+ "metaclass"
+ "superclass"
+ "layout"
+ "slots"
+ } reset-props
+ ] bi ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@@ -228,12 +232,6 @@ M: tuple hashcode*
] 2curry reduce
] recursive-hashcode ;
-M: object construct-empty ( class -- tuple )
- tuple-layout <tuple> ;
-
-M: object construct-boa ( ... class -- tuple )
- tuple-layout <tuple-boa> ;
-
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
@@ -241,10 +239,6 @@ M: object get-slots ( obj slots -- ... )
M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
-M: object construct ( ... slots class -- tuple )
- construct-empty [ swap set-slots ] keep ;
-
-: delegates ( obj -- seq )
- [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
+: delegates ( obj -- seq ) [ delegate ] follow ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor
index 3520104e1f..341d56f1d5 100755
--- a/core/compiler/compiler-docs.factor
+++ b/core/compiler/compiler-docs.factor
@@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser
assocs words.private sequences compiler.units ;
IN: compiler
+HELP: enable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
+HELP: disable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
-"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
-$nl
-"The main entry point to the optimizing compiler:"
+"Normally, new word definitions are recompiled automatically. This can be changed:"
+{ $subsection disable-compiler }
+{ $subsection enable-compiler }
+"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile }
-"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ;
+"Higher-level words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 111d84cde0..a0599f79a1 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -56,5 +56,11 @@ IN: compiler
compiled get >alist
] with-scope ;
+: enable-compiler ( -- )
+ [ optimized-recompile-hook ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+ [ default-recompile-hook ] recompile-hook set-global ;
+
: recompile-all ( -- )
forget-errors all-words compile ;
diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
index ebbce4d7e2..3dc28139ea 100755
--- a/core/definitions/definitions-tests.factor
+++ b/core/definitions/definitions-tests.factor
@@ -4,7 +4,7 @@ compiler.units words ;
TUPLE: combination-1 ;
-M: combination-1 perform-combination 2drop [ ] ;
+M: combination-1 perform-combination drop [ ] define ;
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index fd313d8165..524835f461 100755
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -21,19 +21,6 @@ M: word class-of drop "word" ;
[ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
-GENERIC: bool>str ( x -- y )
-M: general-t bool>str drop "true" ;
-M: f bool>str drop "false" ;
-
-: str>bool
- H{
- { "true" t }
- { "false" f }
- } at ;
-
-[ t ] [ t bool>str str>bool ] unit-test
-[ f ] [ f bool>str str>bool ] unit-test
-
! Testing unions
UNION: funnies quotation float complex ;
@@ -51,16 +38,6 @@ M: very-funny gooey sq ;
[ 0.25 ] [ 0.5 gooey ] unit-test
-DEFER: complement-test
-FORGET: complement-test
-GENERIC: complement-test ( x -- y )
-
-M: f complement-test drop "f" ;
-M: general-t complement-test drop "general-t" ;
-
-[ "general-t" ] [ 5 complement-test ] unit-test
-[ "f" ] [ f complement-test ] unit-test
-
GENERIC: empty-method-test ( x -- y )
M: object empty-method-test ;
TUPLE: for-arguments-sake ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 2ec285146e..b0099f770c 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -6,16 +6,7 @@ classes.algebra quotations arrays vocabs effects ;
IN: generic
! Method combination protocol
-GENERIC: perform-combination ( word combination -- quot )
-
-M: object perform-combination
- #! We delay the invalid method combination error for a
- #! reason. If we call forget-vocab on a vocabulary which
- #! defines a method combination, a generic using this
- #! method combination, and a method on the generic, and the
- #! method combination is forgotten first, then forgetting
- #! the method will throw an error. We don't want that.
- nip [ "Invalid method combination" throw ] curry [ ] like ;
+GENERIC: perform-combination ( word combination -- )
GENERIC: make-default-method ( generic combination -- method )
@@ -38,6 +29,18 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
+: next-method-class ( class generic -- class/f )
+ order [ class< ] with subset reverse dup length 1 =
+ [ drop f ] [ second ] if ;
+
+: next-method ( class generic -- class/f )
+ [ next-method-class ] keep method ;
+
+GENERIC: next-method-quot ( class generic -- quot )
+
+: (call-next-method) ( class generic -- )
+ next-method-quot call ;
+
TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 2fda2c9621..46208744f0 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -12,9 +12,9 @@ PREDICATE: math-class < class
number bootstrap-word class<
] if ;
-: last/first ( seq -- pair ) dup peek swap first 2array ;
+: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
-: math-precedence ( class -- n )
+: math-precedence ( class -- pair )
{
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 510d5ef732..40e749f473 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -15,7 +15,7 @@ C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
TUPLE: tuple-dispatch-engine echelons ;
: push-echelon ( class method assoc -- )
- >r swap dup tuple-layout layout-echelon r>
+ >r swap dup "layout" word-prop layout-echelon r>
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 0d29bdecd5..2b2dbd2b2d 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -8,6 +8,10 @@ generic.standard.engines.tag generic.standard.engines.predicate
generic.standard.engines.tuple accessors ;
IN: generic.standard
+GENERIC: dispatch# ( word -- n )
+
+M: word dispatch# "combination" word-prop dispatch# ;
+
: unpickers
{
[ nip ]
@@ -101,7 +105,7 @@ PREDICATE: simple-generic < standard-generic
T{ standard-combination f 0 } define-generic ;
: with-standard ( combination quot -- quot' )
- >r #>> (dispatch#) r> with-variable ;
+ >r #>> (dispatch#) r> with-variable ; inline
M: standard-generic mangle-method
drop 1quotation ;
@@ -112,6 +116,27 @@ M: standard-combination make-default-method
M: standard-combination perform-combination
[ drop ] [ [ single-combination ] with-standard ] 2bi define ;
+M: standard-combination dispatch# #>> ;
+
+ERROR: inconsistent-next-method object class generic ;
+
+ERROR: no-next-method class generic ;
+
+M: standard-generic next-method-quot
+ [
+ [
+ [ [ instance? ] curry ]
+ [ dispatch# (picker) ] bi* prepend %
+ ]
+ [
+ 2dup next-method
+ [ 2nip 1quotation ]
+ [ [ no-next-method ] 2curry ] if* ,
+ ]
+ [ [ inconsistent-next-method ] 2curry , ]
+ 2tri
+ ] [ ] make ;
+
TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
@@ -124,6 +149,8 @@ PREDICATE: hook-generic < generic
dip var>> [ get ] curry prepend
] with-variable ; inline
+M: hook-combination dispatch# drop 0 ;
+
M: hook-generic mangle-method
drop 1quotation [ drop ] prepend ;
@@ -133,14 +160,6 @@ M: hook-combination make-default-method
M: hook-combination perform-combination
[ drop ] [ [ single-combination ] with-hook ] 2bi define ;
-GENERIC: dispatch# ( word -- n )
-
-M: word dispatch# "combination" word-prop dispatch# ;
-
-M: standard-combination dispatch# #>> ;
-
-M: hook-combination dispatch# drop 0 ;
-
M: simple-generic definer drop \ GENERIC: f ;
M: standard-generic definer drop \ GENERIC# f ;
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 7d18aaa489..b54dbe256a 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -21,7 +21,7 @@ GENERIC: mynot ( x -- y )
M: f mynot drop t ;
-M: general-t mynot drop f ;
+M: object mynot drop f ;
GENERIC: detect-f ( x -- y )
@@ -297,3 +297,15 @@ cell-bits 32 = [
[ t ] [
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
] unit-test
+
+[ t ] [
+ [
+ dup integer? [
+ dup fixnum? [
+ 1 +
+ ] [
+ 2 +
+ ] if
+ ] when
+ ] \ + inlined?
+] unit-test
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index 4aac98ce41..8269952409 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -176,9 +176,18 @@ M: pair constraint-satisfied?
: predicate-constraints ( class #call -- )
[
- 0 `input class,
- general-t 0 `output class,
- ] set-constraints ;
+ ! If word outputs true, input is an instance of class
+ [
+ 0 `input class,
+ \ f class-not 0 `output class,
+ ] set-constraints
+ ] [
+ ! If word outputs false, input is not an instance of class
+ [
+ class-not 0 `input class,
+ \ f 0 `output class,
+ ] set-constraints
+ ] 2bi ;
: compute-constraints ( #call -- )
dup node-param "constraints" word-prop [
@@ -209,7 +218,7 @@ M: #push infer-classes-before
M: #if child-constraints
[
- general-t 0 `input class,
+ \ f class-not 0 `input class,
f 0 `input literal,
] make-constraints ;
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index 7fa2fbbcd3..01c0a9c5f4 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/core/inference/dataflow/dataflow.factor
@@ -9,15 +9,13 @@ IN: inference.dataflow
: <computed> \ <computed> counter ;
! Literal value
-TUPLE: value literal uid recursion ;
+TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value )
<computed> recursive-state get value construct-boa ;
M: value hashcode* nip value-uid ;
-M: value equal? 2drop f ;
-
! Result of curry
TUPLE: curried obj quot ;
@@ -30,13 +28,12 @@ C: <composed> composed
UNION: special curried composed ;
-TUPLE: node param
+TUPLE: node < identity-tuple
+param
in-d out-d in-r out-r
classes literals intervals
history successor children ;
-M: node equal? 2drop f ;
-
M: node hashcode* drop node hashcode* ;
GENERIC: flatten-curry ( value -- )
diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor
index cb8024d3c5..3fc8f37b4f 100755
--- a/core/inference/transforms/transforms-tests.factor
+++ b/core/inference/transforms/transforms-tests.factor
@@ -1,6 +1,7 @@
IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel
-quotations inference accessors combinators words arrays ;
+quotations inference accessors combinators words arrays
+classes ;
: compose-n-quot <repetition> >quotation ;
: compose-n compose-n-quot call ;
@@ -56,3 +57,5 @@ C: <color> color
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
+
+[ fixnum instance? ] must-infer
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 06c2a8f476..d95ff9c3bc 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -3,7 +3,7 @@
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables ;
+inspector hashtables classes generic ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@@ -98,3 +98,11 @@ M: duplicated-slots-error summary
\ construct-empty 1 1 <effect> make-call-node
] if
] "infer" set-word-prop
+
+\ instance? [
+ [ +inlined+ depends-on ] [ "predicate" word-prop ] bi
+] 1 define-transform
+
+\ (call-next-method) [
+ [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 2df5e69998..53618d4628 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -250,8 +250,9 @@ $nl
{ $subsection eq? }
"Value comparison:"
{ $subsection = }
-"Generic words for custom value comparison methods:"
+"Custom value comparison methods:"
{ $subsection equal? }
+{ $subsection identity-tuple }
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
{ $subsection <=> }
{ $subsection compare }
@@ -377,10 +378,13 @@ HELP: equal?
}
$nl
"If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word."
-}
+} ;
+
+HELP: identity-tuple
+{ $class-description "A class defining an " { $link equal? } " method which always returns f." }
{ $examples
- "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
- { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" }
+ "To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
+ { $code "TUPLE: foo < identity-tuple ;" }
"By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:"
{ $unchecked-example "T{ foo } dup = ." "t" }
{ $unchecked-example "T{ foo } dup clone = ." "f" }
@@ -665,6 +669,11 @@ HELP: bi@
"[ p ] bi@"
">r p r> p"
}
+ "The following two lines are also equivalent:"
+ { $code
+ "[ p ] bi@"
+ "[ p ] [ p ] bi*"
+ }
} ;
HELP: 2bi@
@@ -676,6 +685,11 @@ HELP: 2bi@
"[ p ] 2bi@"
">r >r p r> r> p"
}
+ "The following two lines are also equivalent:"
+ { $code
+ "[ p ] 2bi@"
+ "[ p ] [ p ] 2bi*"
+ }
} ;
HELP: tri@
@@ -687,6 +701,11 @@ HELP: tri@
"[ p ] tri@"
">r >r p r> p r> p"
}
+ "The following two lines are also equivalent:"
+ { $code
+ "[ p ] tri@"
+ "[ p ] [ p ] [ p ] tri*"
+ }
} ;
HELP: if ( cond true false -- )
@@ -785,19 +804,6 @@ HELP: null
"The canonical empty class with no instances."
} ;
-HELP: general-t
-{ $class-description
- "The class of all objects not equal to " { $link f } "."
-}
-{ $examples
- "Here is an implementation of " { $link if } " using generic words:"
- { $code
- "GENERIC# my-if 2 ( ? true false -- )"
- "M: f my-if 2nip call ;"
- "M: general-t my-if drop nip call ;"
- }
-} ;
-
HELP: most
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index ae775ec116..1935c89431 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel.private slots.private ;
+USING: kernel.private slots.private classes.tuple.private ;
IN: kernel
! Stack stuff
@@ -114,12 +114,6 @@ DEFER: if
[ 2nip call ] if ; inline
! Object protocol
-GENERIC: delegate ( obj -- delegate )
-
-M: object delegate drop f ;
-
-GENERIC: set-delegate ( delegate tuple -- )
-
GENERIC: hashcode* ( depth obj -- code )
M: object hashcode* 2drop 0 ;
@@ -130,6 +124,10 @@ GENERIC: equal? ( obj1 obj2 -- ? )
M: object equal? 2drop f ;
+TUPLE: identity-tuple ;
+
+M: identity-tuple equal? 2drop f ;
+
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ equal? ] if ; inline
@@ -142,18 +140,11 @@ M: object clone ;
M: callstack clone (clone) ;
! Tuple construction
-GENERIC# get-slots 1 ( tuple slots -- ... )
+: construct-empty ( class -- tuple )
+ tuple-layout <tuple> ;
-GENERIC# set-slots 1 ( ... tuple slots -- )
-
-GENERIC: construct-empty ( class -- tuple )
-
-GENERIC: construct ( ... slots class -- tuple ) inline
-
-GENERIC: construct-boa ( ... class -- tuple )
-
-: construct-delegate ( delegate class -- tuple )
- >r { set-delegate } r> construct ; inline
+: construct-boa ( ... class -- tuple )
+ tuple-layout <tuple-boa> ;
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )
@@ -201,3 +192,20 @@ GENERIC: construct-boa ( ... class -- tuple )
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
+
+! Deprecated
+GENERIC: delegate ( obj -- delegate )
+
+M: object delegate drop f ;
+
+GENERIC: set-delegate ( delegate tuple -- )
+
+GENERIC# get-slots 1 ( tuple slots -- ... )
+
+GENERIC# set-slots 1 ( ... tuple slots -- )
+
+: construct ( ... slots class -- tuple )
+ construct-empty [ swap set-slots ] keep ; inline
+
+: construct-delegate ( delegate class -- tuple )
+ >r { set-delegate } r> construct ; inline
diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor
index c108e3b1a7..11228c879a 100755
--- a/core/optimizer/control/control.factor
+++ b/core/optimizer/control/control.factor
@@ -154,7 +154,7 @@ SYMBOL: potential-loops
] [
node-class {
{ [ dup null class< ] [ drop f f ] }
- { [ dup general-t class< ] [ drop t t ] }
+ { [ dup \ f class-not class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
{ [ t ] [ drop f f ] }
} cond
diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
index 1f3df92421..81f53b5ace 100755
--- a/core/optimizer/inlining/inlining.factor
+++ b/core/optimizer/inlining/inlining.factor
@@ -70,12 +70,20 @@ DEFER: (flat-length)
] if ;
! Partial dispatch of math-generic words
+: normalize-math-class ( class -- class' )
+ { fixnum bignum ratio float complex }
+ [ class< ] with find nip object or ;
+
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: inline-math-method ( #call word -- node )
- over node-input-classes first2 3dup math-both-known?
- [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
+ over node-input-classes
+ [ first normalize-math-class ]
+ [ second normalize-math-class ] bi
+ 3dup math-both-known?
+ [ math-method f splice-quot ]
+ [ 2drop 2drop t ] if ;
: inline-method ( #call -- node )
dup node-param {
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index a4782078ee..2bce2dc94c 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -75,7 +75,7 @@ sequences.private combinators ;
dup node-in-d second dup value? [
swap [
value-literal 0 `input literal,
- general-t 0 `output class,
+ \ f class-not 0 `output class,
] set-constraints
] [
2drop
diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor
index abe48ec272..4ec4bfeb36 100755
--- a/core/optimizer/math/math.factor
+++ b/core/optimizer/math/math.factor
@@ -269,7 +269,7 @@ generic.standard system ;
: comparison-constraints ( node true false -- )
>r >r dup node set intervals dup [
2dup
- r> general-t (comparison-constraints)
+ r> \ f class-not (comparison-constraints)
r> \ f (comparison-constraints)
] [
r> r> 2drop 2drop
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 58c68a3614..2a481d413d 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -365,7 +365,17 @@ ERROR: bad-number ;
: (:) CREATE-WORD parse-definition ;
-: (M:) CREATE-METHOD parse-definition ;
+SYMBOL: current-class
+SYMBOL: current-generic
+
+: (M:)
+ CREATE-METHOD
+ [
+ [ "method-class" word-prop current-class set ]
+ [ "method-generic" word-prop current-generic set ]
+ [ ] tri
+ parse-definition
+ ] with-scope ;
: scan-object ( -- object )
scan-word dup parsing?
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index 27b63ec26f..0f384b159d 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -57,8 +57,6 @@ unit-test
[ ] [ \ integer see ] unit-test
-[ ] [ \ general-t see ] unit-test
-
[ ] [ \ generic see ] unit-test
[ ] [ \ duplex-stream see ] unit-test
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index ca46066861..01a1cb9b6a 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -416,6 +416,9 @@ PRIVATE>
swap >r [ push ] curry compose r> while
] keep { } like ; inline
+: follow ( obj quot -- seq )
+ >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
+
: index ( obj seq -- n )
[ = ] with find drop ;
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index bd349953df..b242e65de5 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -243,7 +243,7 @@ HELP: flushable
HELP: t
{ $syntax "t" }
{ $values { "t" "the canonical truth value" } }
-{ $description "The canonical instance of " { $link general-t } ". It is just a symbol." } ;
+{ $class-description "The canonical truth value, which is an instance of itself." } ;
HELP: f
{ $syntax "f" }
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 19fdf0e45f..df135d0c1c 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -185,4 +185,10 @@ IN: bootstrap.syntax
[ \ >> parse-until >quotation ] with-compilation-unit
call
] define-syntax
+
+ "call-next-method" [
+ current-class get literalize parsed
+ current-generic get literalize parsed
+ \ (call-next-method) parsed
+ ] define-syntax
] with-compilation-unit
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index a6a5a014a7..8ef5f6f508 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -6,13 +6,11 @@ IN: vocabs
SYMBOL: dictionary
-TUPLE: vocab
+TUPLE: vocab < identity-tuple
name words
main help
source-loaded? docs-loaded? ;
-M: vocab equal? 2drop f ;
-
: <vocab> ( name -- vocab )
H{ } clone
{ set-vocab-name set-vocab-words }
@@ -92,10 +90,6 @@ TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link )
vocab-link construct-boa ;
-M: vocab-link equal?
- over vocab-link?
- [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ;
-
M: vocab-link hashcode*
vocab-link-name hashcode* ;
diff --git a/core/words/words.factor b/core/words/words.factor
index a45e1627e9..1232a97ddc 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -173,7 +173,7 @@ GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
: reset-generic ( word -- )
- dup subwords [ forget ] each
+ dup subwords forget-all
dup reset-word
{ "methods" "combination" "default-method" } reset-props ;
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 79382091ab..20c5bb92c9 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -6,7 +6,7 @@ init threads continuations math io.encodings io.streams.duplex
io.nonblocking accessors ;
IN: io.launcher
-TUPLE: process
+TUPLE: process < identity-tuple
command
detached
@@ -65,8 +65,6 @@ M: object register-process drop ;
V{ } clone over processes get set-at
register-process ;
-M: process equal? 2drop f ;
-
M: process hashcode* process-handle hashcode* ;
: pass-environment? ( process -- ? )
diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor
index 8480fcd856..74a84c48ff 100755
--- a/extra/io/sockets/impl/impl.factor
+++ b/extra/io/sockets/impl/impl.factor
@@ -96,14 +96,13 @@ M: inet6 parse-sockaddr
M: f parse-sockaddr nip ;
: addrinfo>addrspec ( addrinfo -- addrspec )
- dup addrinfo-addr
- swap addrinfo-family addrspec-of-family
+ [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
parse-sockaddr ;
: parse-addrinfo-list ( addrinfo -- seq )
- [ dup ]
- [ dup addrinfo-next swap addrinfo>addrspec ]
- [ ] unfold nip [ ] subset ;
+ [ addrinfo-next ] follow
+ [ addrinfo>addrspec ] map
+ [ ] subset ;
: prepare-resolve-host ( host serv passive? -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
diff --git a/extra/models/models.factor b/extra/models/models.factor
index fd84dd248f..ffb9b1127a 100755
--- a/extra/models/models.factor
+++ b/extra/models/models.factor
@@ -4,13 +4,12 @@ USING: generic kernel math sequences arrays assocs alarms
calendar ;
IN: models
-TUPLE: model value connections dependencies ref locked? ;
+TUPLE: model < identity-tuple
+value connections dependencies ref locked? ;
: <model> ( value -- model )
V{ } clone V{ } clone 0 f model construct-boa ;
-M: model equal? 2drop f ;
-
M: model hashcode* drop model hashcode* ;
: add-dependency ( dep model -- )
diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor
index 1963f5670a..1c83bc9713 100755
--- a/extra/ui/freetype/freetype.factor
+++ b/extra/ui/freetype/freetype.factor
@@ -27,9 +27,8 @@ DEFER: freetype
\ freetype get-global expired? [ init-freetype ] when
\ freetype get-global ;
-TUPLE: font ascent descent height handle widths ;
-
-M: font equal? 2drop f ;
+TUPLE: font < identity-tuple
+ascent descent height handle widths ;
M: font hashcode* drop font hashcode* ;
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index ddcaa4b979..c4f11f2e87 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -44,14 +44,12 @@ M: array rect-dim drop { 0 0 } ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;
-TUPLE: gadget
+TUPLE: gadget < identity-tuple
pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state graft-node
interior boundary
model ;
-M: gadget equal? 2drop f ;
-
M: gadget hashcode* drop gadget hashcode* ;
M: gadget model-changed 2drop ;
@@ -354,7 +352,7 @@ SYMBOL: in-layout?
swap [ over (add-gadget) ] each relayout ;
: parents ( gadget -- seq )
- [ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ;
+ [ gadget-parent ] follow ;
: each-parent ( gadget quot -- ? )
>r parents r> all? ; inline
@@ -401,7 +399,7 @@ M: f request-focus-on 2drop ;
dup focusable-child swap request-focus-on ;
: focus-path ( world -- seq )
- [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ;
+ [ gadget-parent ] follow ;
: make-gadget ( quot gadget -- gadget )
[ \ make-gadget rot with-variable ] keep ; inline
diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor
index a44b553858..8ee64b58be 100755
--- a/extra/ui/gadgets/worlds/worlds.factor
+++ b/extra/ui/gadgets/worlds/worlds.factor
@@ -5,7 +5,7 @@ namespaces opengl sequences io combinators math.vectors
ui.gadgets ui.gestures ui.render ui.backend inspector ;
IN: ui.gadgets.worlds
-TUPLE: world
+TUPLE: world < identity-tuple
active? focused?
glass
title status
@@ -46,8 +46,6 @@ M: world request-focus-on ( child gadget -- )
t over set-gadget-root?
dup request-focus ;
-M: world equal? 2drop f ;
-
M: world hashcode* drop world hashcode* ;
M: world pref-dim*
From 337d582a811ee6c3276942acf668eb0c5be15733 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 21:31:41 -0500
Subject: [PATCH 070/288] Fix call-next-method
---
core/generic/standard/standard.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 2b2dbd2b2d..c36e5f1921 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -135,6 +135,7 @@ M: standard-generic next-method-quot
]
[ [ inconsistent-next-method ] 2curry , ]
2tri
+ \ if ,
] [ ] make ;
TUPLE: hook-combination var ;
From a27fa2909875b302191d8c48a073b1ead0875ccc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 21:37:26 -0500
Subject: [PATCH 071/288] Remove type, class-hash primitives
---
core/bootstrap/primitives.factor | 2 --
core/inference/known-words/known-words.factor | 3 ---
vm/primitives.c | 2 --
vm/run.c | 21 -------------------
vm/run.h | 2 --
5 files changed, 30 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index f3846de5b1..6c87730278 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -656,7 +656,6 @@ define-builtin
{ "code-room" "memory" }
{ "os-env" "system" }
{ "millis" "system" }
- { "type" "kernel.private" }
{ "tag" "kernel.private" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
@@ -728,7 +727,6 @@ define-builtin
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
{ "<tuple-boa>" "classes.tuple.private" }
- { "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" }
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 3cc78831a3..5092b86a4d 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -386,9 +386,6 @@ set-primitive-effect
\ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable
-\ class-hash { object } { fixnum } <effect> set-primitive-effect
-\ class-hash make-foldable
-
\ cwd { } { string } <effect> set-primitive-effect
\ cd { string } { } <effect> set-primitive-effect
diff --git a/vm/primitives.c b/vm/primitives.c
index 203ebb7f6b..6a6aeb9d46 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -106,7 +106,6 @@ void *primitives[] = {
primitive_code_room,
primitive_os_env,
primitive_millis,
- primitive_type,
primitive_tag,
primitive_modify_code_heap,
primitive_dlopen,
@@ -178,7 +177,6 @@ void *primitives[] = {
primitive_sleep,
primitive_float_array,
primitive_tuple_boa,
- primitive_class_hash,
primitive_callstack_to_array,
primitive_innermost_stack_frame_quot,
primitive_innermost_stack_frame_scan,
diff --git a/vm/run.c b/vm/run.c
index cec19b5445..282be0a447 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -307,32 +307,11 @@ DEFINE_PRIMITIVE(sleep)
sleep_millis(to_cell(dpop()));
}
-DEFINE_PRIMITIVE(type)
-{
- drepl(tag_fixnum(type_of(dpeek())));
-}
-
DEFINE_PRIMITIVE(tag)
{
drepl(tag_fixnum(TAG(dpeek())));
}
-DEFINE_PRIMITIVE(class_hash)
-{
- CELL obj = dpeek();
- CELL tag = TAG(obj);
- if(tag == TUPLE_TYPE)
- {
- F_TUPLE *tuple = untag_object(obj);
- F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
- drepl(layout->hashcode);
- }
- else if(tag == OBJECT_TYPE)
- drepl(get(UNTAG(obj)));
- else
- drepl(tag_fixnum(tag));
-}
-
DEFINE_PRIMITIVE(slot)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
diff --git a/vm/run.h b/vm/run.h
index 216a00b27d..c112c5f587 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -253,9 +253,7 @@ DECLARE_PRIMITIVE(set_os_envs);
DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
DECLARE_PRIMITIVE(sleep);
-DECLARE_PRIMITIVE(type);
DECLARE_PRIMITIVE(tag);
-DECLARE_PRIMITIVE(class_hash);
DECLARE_PRIMITIVE(slot);
DECLARE_PRIMITIVE(set_slot);
From 50d8b351de04895ed22b5b2ff4720b9f5bfe28b0 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Wed, 2 Apr 2008 21:43:17 -0500
Subject: [PATCH 072/288] fix using
---
extra/openal/macosx/macosx.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor
index c03ad5693c..d2a0422d8d 100644
--- a/extra/openal/macosx/macosx.factor
+++ b/extra/openal/macosx/macosx.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel alien alien.syntax shuffle
-combinators.lib openal.backend namespaces ;
+combinators.lib openal.backend namespaces system ;
IN: openal.macosx
LIBRARY: alut
From 27f2992dc5eca644fb077017746243b5f34e4cf2 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 3 Apr 2008 16:09:03 +1300
Subject: [PATCH 073/288] Add failing ebnf test
---
extra/peg/ebnf/ebnf-tests.factor | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 84c492c55a..0879ecda49 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.ebnf words math math.parser ;
+USING: kernel tools.test peg peg.ebnf words math math.parser sequences ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -247,6 +247,10 @@ IN: peg.ebnf.tests
"1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
] unit-test
+{ t } [
+ "abcd='9' | ('8'):x => [[ drop x ]]" 'ebnf' parse parse-result-remaining empty?
+] unit-test
+
EBNF: primary
Primary = PrimaryNoNewArray
PrimaryNoNewArray = ClassInstanceCreationExpression
From cc7d945a80273d4ce966d307424a4f66e72e32ae Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 3 Apr 2008 17:28:09 +1300
Subject: [PATCH 074/288] Change ebnf variables to not use namespaces
---
extra/peg/ebnf/ebnf.factor | 55 +++++++++++++++++++++++++-------------
1 file changed, 37 insertions(+), 18 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index b0dfaad5b3..49c2d5a8dd 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -237,17 +237,16 @@ GENERIC: (transform) ( ast -- parser )
SYMBOL: parser
SYMBOL: main
-SYMBOL: vars
: transform ( ast -- object )
- H{ } clone dup dup [ parser set V{ } vars set swap (transform) main set ] bind ;
+ H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
M: ebnf (transform) ( ast -- parser )
rules>> [ (transform) ] map peek ;
M: ebnf-rule (transform) ( ast -- parser )
dup elements>>
- vars get clone vars [ (transform) ] with-variable [
+ (transform) [
swap symbol>> set
] keep ;
@@ -282,30 +281,50 @@ M: ebnf-repeat1 (transform) ( ast -- parser )
M: ebnf-optional (transform) ( ast -- parser )
transform-group optional ;
-: build-locals ( string vars -- string )
- dup empty? [
- drop
- ] [
+GENERIC: build-locals ( code ast -- code )
+
+M: ebnf-sequence build-locals ( code ast -- code )
+ elements>> dup [ ebnf-var? ] subset empty? [
+ drop
+ ] [
[
- "USING: locals namespaces ; [let* | " %
- [ dup % " [ \"" % % "\" get ] " % ] each
- " | " %
- %
- " ] with-locals" %
+ "USING: locals sequences ; [let* | " %
+ dup length swap [
+ dup ebnf-var? [
+ name>> %
+ " [ " % # " over nth ] " %
+ ] [
+ 2drop
+ ] if
+ ] 2each
+ " | " %
+ %
+ " ] with-locals" %
] "" make
] if ;
+M: ebnf-var build-locals ( code ast -- )
+ [
+ "USING: locals kernel ; [let* | " %
+ name>> % " [ dup ] " %
+ " | " %
+ %
+ " ] with-locals" %
+ ] "" make ;
+
+M: object build-locals ( code ast -- )
+ drop ;
+
M: ebnf-action (transform) ( ast -- parser )
- [ parser>> (transform) ] keep
- code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ;
+ [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
+ string-lines [ parse-lines ] with-compilation-unit action ;
M: ebnf-semantic (transform) ( ast -- parser )
- [ parser>> (transform) ] keep
- code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ;
+ [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
+ string-lines [ parse-lines ] with-compilation-unit semantic ;
M: ebnf-var (transform) ( ast -- parser )
- [ parser>> (transform) ] [ name>> ] bi
- dup vars get push [ dupd set ] curry action ;
+ parser>> (transform) ;
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> token ;
From 970f0055c266ab813c177b4c4f545e51ea203479 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 3 Apr 2008 17:33:37 +1300
Subject: [PATCH 075/288] Fix failing ebnf unit test
---
extra/peg/ebnf/ebnf.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 49c2d5a8dd..e5787e6cf8 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -213,6 +213,7 @@ DEFER: 'choice'
: 'actioned-sequence' ( -- parser )
[
[ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
+ [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , "=>" syntax , 'action' , ] seq* [ first3 >r <ebnf-var> r> <ebnf-action> ] action ,
[ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
'sequence' ,
] choice* ;
From 93d9722a6bb3bc9c956f10475febcbe85ddf61fd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 00:21:53 -0500
Subject: [PATCH 076/288] Fix class resetting
---
core/classes/mixin/mixin.factor | 2 +-
core/classes/predicate/predicate.factor | 5 ++++-
core/classes/tuple/tuple.factor | 1 +
core/classes/union/union.factor | 2 +-
core/parser/parser.factor | 13 ++++++++-----
5 files changed, 15 insertions(+), 8 deletions(-)
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index b771aa8920..aefd522269 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -7,7 +7,7 @@ IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
- { "metaclass" "members" "mixin" } reset-props ;
+ { "class" "metaclass" "members" "mixin" } reset-props ;
: redefine-mixin-class ( class members -- )
dupd define-union-class
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 0f98f1f5c4..4729a6dd5e 100755
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -25,5 +25,8 @@ PREDICATE: predicate-class < class
M: predicate-class reset-class
{
- "metaclass" "predicate-definition" "superclass"
+ "class"
+ "metaclass"
+ "predicate-definition"
+ "superclass"
} reset-props ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index ac1a7b8849..58c6f2c581 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -212,6 +212,7 @@ M: tuple-class reset-class
] with each
] [
{
+ "class"
"metaclass"
"superclass"
"layout"
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 9079974a60..09f8f88ced 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -29,4 +29,4 @@ M: union-class update-class define-union-predicate ;
2bi ;
M: union-class reset-class
- { "metaclass" "members" } reset-props ;
+ { "class" "metaclass" "members" } reset-props ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 2a481d413d..5551ac8af0 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -505,8 +505,10 @@ SYMBOL: interactive-vocabs
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
- new-definitions get first2 diff
- [ nip dup reset-generic define-symbol ] assoc-each ;
+ new-definitions get first2
+ [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ]
+ [ swap diff values [ class? ] subset [ reset-class ] each ]
+ 2bi ;
: forget-smudged ( -- )
smudged-usage forget-all
@@ -515,9 +517,10 @@ SYMBOL: interactive-vocabs
: finish-parsing ( lines quot -- )
file get
- [ record-form ] keep
- [ record-definitions ] keep
- record-checksum ;
+ [ record-form ]
+ [ record-definitions ]
+ [ record-checksum ]
+ tri ;
: parse-stream ( stream name -- quot )
[
From cfe1c5d39e95f111f98a72faa2936fa577219fda Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 00:22:10 -0500
Subject: [PATCH 077/288] Update unit test for word removal
---
core/compiler/tests/templates.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index a82208e9b9..565c045e2a 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -172,14 +172,14 @@ TUPLE: my-tuple ;
[ 1 t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
- [ 0 alien-unsigned-1 ] keep type
+ [ 0 alien-unsigned-1 ] keep hi-tag
] compile-call byte-array type-number =
] unit-test
[ t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
- 0 alien-cell type
+ 0 alien-cell hi-tag
] compile-call alien type-number =
] unit-test
From 0cf667859af5a6cb823127539303d3e56e5c371c Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.gateway.2wire.net>
Date: Thu, 3 Apr 2008 00:59:20 -0500
Subject: [PATCH 078/288] fix random on openbsd
---
extra/random/unix/unix.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor
index 3be2697bdf..6a72baa21b 100644
--- a/extra/random/unix/unix.factor
+++ b/extra/random/unix/unix.factor
@@ -15,7 +15,7 @@ C: <unix-random> unix-random
M: unix-random random-bytes* ( n tuple -- byte-array )
path>> file-read-unbuffered ;
-os "openbsd" = [
+os openbsd? [
[
"/dev/srandom" <unix-random> secure-random-generator set-global
"/dev/prandom" <unix-random> insecure-random-generator set-global
From e490e9b636dc045d53935c1ac86346af68650ae8 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.gateway.2wire.net>
Date: Thu, 3 Apr 2008 01:48:29 -0500
Subject: [PATCH 079/288] refactor hardware-info a bit
---
extra/hardware-info/backend/backend.factor | 3 +--
extra/hardware-info/hardware-info.factor | 15 ++++++++----
extra/hardware-info/macosx/macosx.factor | 28 ++++++++++++----------
extra/hardware-info/windows/ce/ce.factor | 19 +++++++--------
extra/hardware-info/windows/nt/nt.factor | 21 +++++++---------
5 files changed, 44 insertions(+), 42 deletions(-)
diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor
index 17794c196d..95a56da2d2 100644
--- a/extra/hardware-info/backend/backend.factor
+++ b/extra/hardware-info/backend/backend.factor
@@ -1,8 +1,7 @@
+USING: system ;
IN: hardware-info.backend
-SYMBOL: os
HOOK: cpus os ( -- n )
-
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor
index ecdcc42cb5..6d27cf5252 100755
--- a/extra/hardware-info/hardware-info.factor
+++ b/extra/hardware-info/hardware-info.factor
@@ -1,10 +1,13 @@
-USING: alien.syntax kernel math prettyprint
+USING: alien.syntax kernel math prettyprint io math.parser
combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info
-: kb. ( x -- ) 10 2^ /f . ;
-: megs. ( x -- ) 20 2^ /f . ;
-: gigs. ( x -- ) 30 2^ /f . ;
+: write-unit ( x n str -- )
+ [ 2^ /i number>string write bl ] [ write ] bi* ;
+
+: kb ( x -- ) 10 "kB" write-unit ;
+: megs ( x -- ) 20 "MB" write-unit ;
+: gigs ( x -- ) 30 "GB" write-unit ;
<< {
{ [ os windows? ] [ "hardware-info.windows" ] }
@@ -12,3 +15,7 @@ IN: hardware-info
{ [ os macosx? ] [ "hardware-info.macosx" ] }
{ [ t ] [ f ] }
} cond [ require ] when* >>
+
+: hardware-report. ( -- )
+ "CPUs: " write cpus number>string write nl
+ "Physical RAM: " write physical-mem megs nl ;
diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor
index c246a95186..dac052a1de 100644
--- a/extra/hardware-info/macosx/macosx.factor
+++ b/extra/hardware-info/macosx/macosx.factor
@@ -1,10 +1,8 @@
USING: alien alien.c-types alien.syntax byte-arrays kernel
-namespaces sequences unix hardware-info.backend ;
+namespaces sequences unix hardware-info.backend system
+io.unix.backend ;
IN: hardware-info.macosx
-TUPLE: macosx ;
-T{ macosx } os set-global
-
! See /usr/include/sys/sysctl.h for constants
LIBRARY: libc
@@ -14,14 +12,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
[ <int> ] map concat ;
: (sysctl-query) ( name namelen oldp oldlenp -- oldp error/f )
- over >r
- f 0 sysctl -1 = [ err_no strerror ] [ f ] if
- r> swap ;
+ over >r f 0 sysctl io-error r> ;
: sysctl-query ( seq n -- byte-array )
- >r [ make-int-array ] keep length r>
- [ <byte-array> ] keep <uint>
- (sysctl-query) [ throw ] when* ;
+ >r [ make-int-array ] [ length ] bi r>
+ [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
4096 sysctl-query alien>char-string ;
@@ -36,8 +31,15 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
: model ( -- str ) { 6 2 } sysctl-query-string ;
M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
-: user-mem ( -- n ) { 6 4 } sysctl-query-uint ;
+M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
+: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
+: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
+: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
+: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
+: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
+: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
+: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ;
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
@@ -47,7 +49,7 @@ M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
-: bus-frequency2 ( -- n ) { 6 23 } sysctl-query-uint ;
-M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ;
+: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
+: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor
index f671ea9426..55c2ac6c0d 100755
--- a/extra/hardware-info/windows/ce/ce.factor
+++ b/extra/hardware-info/windows/ce/ce.factor
@@ -2,33 +2,30 @@ USING: alien.c-types hardware-info kernel math namespaces
windows windows.kernel32 hardware-info.backend ;
IN: hardware-info.windows.ce
-TUPLE: wince-os ;
-T{ wince-os } os set-global
-
: memory-status ( -- MEMORYSTATUS )
"MEMORYSTATUS" <c-object>
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
[ GlobalMemoryStatus ] keep ;
-M: wince-os cpus ( -- n ) 1 ;
+M: wince cpus ( -- n ) 1 ;
-M: wince-os memory-load ( -- n )
+M: wince memory-load ( -- n )
memory-status MEMORYSTATUS-dwMemoryLoad ;
-M: wince-os physical-mem ( -- n )
+M: wince physical-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalPhys ;
-M: wince-os available-mem ( -- n )
+M: wince available-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailPhys ;
-M: wince-os total-page-file ( -- n )
+M: wince total-page-file ( -- n )
memory-status MEMORYSTATUS-dwTotalPageFile ;
-M: wince-os available-page-file ( -- n )
+M: wince available-page-file ( -- n )
memory-status MEMORYSTATUS-dwAvailPageFile ;
-M: wince-os total-virtual-mem ( -- n )
+M: wince total-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalVirtual ;
-M: wince-os available-virtual-mem ( -- n )
+M: wince available-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailVirtual ;
diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor
index 8bdb75fe6a..ba9c1d74b5 100755
--- a/extra/hardware-info/windows/nt/nt.factor
+++ b/extra/hardware-info/windows/nt/nt.factor
@@ -1,15 +1,12 @@
USING: alien alien.c-types
kernel libc math namespaces hardware-info.backend
-windows windows.advapi32 windows.kernel32 ;
+windows windows.advapi32 windows.kernel32 system ;
IN: hardware-info.windows.nt
-TUPLE: winnt-os ;
-T{ winnt-os } os set-global
-
: system-info ( -- SYSTEM_INFO )
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
-M: winnt-os cpus ( -- n )
+M: winnt cpus ( -- n )
system-info SYSTEM_INFO-dwNumberOfProcessors ;
: memory-status ( -- MEMORYSTATUSEX )
@@ -17,25 +14,25 @@ M: winnt-os cpus ( -- n )
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
[ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ;
-M: winnt-os memory-load ( -- n )
+M: winnt memory-load ( -- n )
memory-status MEMORYSTATUSEX-dwMemoryLoad ;
-M: winnt-os physical-mem ( -- n )
+M: winnt physical-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPhys ;
-M: winnt-os available-mem ( -- n )
+M: winnt available-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPhys ;
-M: winnt-os total-page-file ( -- n )
+M: winnt total-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPageFile ;
-M: winnt-os available-page-file ( -- n )
+M: winnt available-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPageFile ;
-M: winnt-os total-virtual-mem ( -- n )
+M: winnt total-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalVirtual ;
-M: winnt-os available-virtual-mem ( -- n )
+M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
: computer-name ( -- string )
From 54265a9f4c33d2f60cf87320fe4ec530dc9a0255 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 04:58:37 -0500
Subject: [PATCH 080/288] Final inheritance fixes
---
core/classes/tuple/tuple-tests.factor | 11 +++
core/generic/standard/standard-tests.factor | 98 ++++++++++++++++++++-
core/inference/class/class-tests.factor | 14 +++
core/inference/class/class.factor | 31 ++++---
core/optimizer/inlining/inlining.factor | 9 +-
core/parser/parser.factor | 22 +++--
6 files changed, 159 insertions(+), 26 deletions(-)
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 735f328a67..a8e9066f56 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -542,3 +542,14 @@ USE: vocabs
[ f ] [ "x" accessor-exists? ] unit-test
[ f ] [ "y" accessor-exists? ] unit-test
[ f ] [ "z" accessor-exists? ] unit-test
+
+TUPLE: another-forget-accessors-test ;
+
+
+[ [ ] ] [
+ "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
+ <string-reader>
+ "another-forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ \ another-forget-accessors-test class? ] unit-test
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index fbca22471c..2f58770b1a 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -1,7 +1,7 @@
IN: generic.standard.tests
USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
-words float-arrays byte-arrays bit-arrays parser ;
+words float-arrays byte-arrays bit-arrays parser namespaces ;
GENERIC: lo-tag-test
@@ -137,3 +137,99 @@ M: byte-array small-lo-tag drop "byte-array" ;
[ "fixnum" ] [ 3 small-lo-tag ] unit-test
[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
+
+! Testing next-method
+TUPLE: person ;
+
+TUPLE: intern < person ;
+
+TUPLE: employee < person ;
+
+TUPLE: tape-monkey < employee ;
+
+TUPLE: manager < employee ;
+
+TUPLE: junior-manager < manager ;
+
+TUPLE: middle-manager < manager ;
+
+TUPLE: senior-manager < manager ;
+
+TUPLE: executive < senior-manager ;
+
+TUPLE: ceo < executive ;
+
+GENERIC: salary ( person -- n )
+
+M: intern salary
+ #! Intentional mistake.
+ call-next-method ;
+
+M: employee salary drop 24000 ;
+
+M: manager salary call-next-method 12000 + ;
+
+M: middle-manager salary call-next-method 5000 + ;
+
+M: senior-manager salary call-next-method 15000 + ;
+
+M: executive salary call-next-method 2 * ;
+
+M: ceo salary
+ #! Intentional error.
+ drop 5 call-next-method 3 * ;
+
+[ salary ] must-infer
+
+[ 24000 ] [ employee construct-boa salary ] unit-test
+
+[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
+
+[ 36000 ] [ junior-manager construct-boa salary ] unit-test
+
+[ 41000 ] [ middle-manager construct-boa salary ] unit-test
+
+[ 51000 ] [ senior-manager construct-boa salary ] unit-test
+
+[ 102000 ] [ executive construct-boa salary ] unit-test
+
+[ ceo construct-boa salary ]
+[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with
+
+[ intern construct-boa salary ]
+[ T{ no-next-method f intern salary } = ] must-fail-with
+
+! Weird shit
+TUPLE: a ;
+TUPLE: b ;
+TUPLE: c ;
+
+UNION: x a b ;
+UNION: y a c ;
+
+UNION: z x y ;
+
+GENERIC: funky* ( obj -- )
+
+M: z funky* "z" , drop ;
+
+M: x funky* "x" , call-next-method ;
+
+M: y funky* "y" , call-next-method ;
+
+M: a funky* "a" , call-next-method ;
+
+M: b funky* "b" , call-next-method ;
+
+M: c funky* "c" , call-next-method ;
+
+: funky [ funky* ] { } make ;
+
+[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
+
+[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
+
+[ t ] [
+ T{ a } funky
+ { { "a" "x" "z" } { "a" "y" "z" } } member?
+] unit-test
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index b54dbe256a..038ab1d230 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ;
\ >float inlined?
] unit-test
+GENERIC: detect-float ( a -- b )
+
+M: float detect-float ;
+
+[ t ] [
+ [ { real float } declare + detect-float ]
+ \ detect-float inlined?
+] unit-test
+
+[ t ] [
+ [ { float real } declare + detect-float ]
+ \ detect-float inlined?
+] unit-test
+
[ t ] [
[ 3 + = ] \ equal? inlined?
] unit-test
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index 8269952409..033d2cce7a 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -274,7 +274,7 @@ DEFER: (infer-classes)
(merge-intervals) r> set-intervals ;
: annotate-merge ( nodes #merge/#entry -- )
- 2dup merge-classes merge-intervals ;
+ [ merge-classes ] [ merge-intervals ] 2bi ;
: merge-children ( node -- )
dup node-successor dup #merge? [
@@ -290,28 +290,31 @@ DEFER: (infer-classes)
M: #label infer-classes-before ( #label -- )
#! First, infer types under the hypothesis which hold on
#! entry to the recursive label.
- dup 1array swap annotate-entry ;
+ [ 1array ] keep annotate-entry ;
M: #label infer-classes-around ( #label -- )
#! Now merge the types at every recursion point with the
#! entry types.
- dup annotate-node
- dup infer-classes-before
- dup infer-children
- dup collect-recursion over suffix
- pick annotate-entry
- node-child (infer-classes) ;
+ {
+ [ annotate-node ]
+ [ infer-classes-before ]
+ [ infer-children ]
+ [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
+ [ node-child (infer-classes) ]
+ } cleave ;
M: object infer-classes-around
- dup infer-classes-before
- dup annotate-node
- dup infer-children
- merge-children ;
+ {
+ [ infer-classes-before ]
+ [ annotate-node ]
+ [ infer-children ]
+ [ merge-children ]
+ } cleave ;
: (infer-classes) ( node -- )
[
- dup infer-classes-around
- node-successor (infer-classes)
+ [ infer-classes-around ]
+ [ node-successor (infer-classes) ] bi
] when* ;
: infer-classes-with ( node classes literals intervals -- )
diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
index 81f53b5ace..9d41d6eae1 100755
--- a/core/optimizer/inlining/inlining.factor
+++ b/core/optimizer/inlining/inlining.factor
@@ -71,8 +71,13 @@ DEFER: (flat-length)
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
- { fixnum bignum ratio float complex }
- [ class< ] with find nip object or ;
+ {
+ fixnum bignum integer
+ ratio rational
+ float real
+ complex number
+ object
+ } [ class< ] with find nip ;
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 5551ac8af0..902bae29b5 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -477,18 +477,22 @@ SYMBOL: interactive-vocabs
nl
] when 2drop ;
-: filter-moved ( assoc -- newassoc )
- [
+: filter-moved ( assoc1 assoc2 -- seq )
+ diff [
drop where dup [ first ] when
file get source-file-path =
- ] assoc-subset ;
+ ] assoc-subset keys ;
-: removed-definitions ( -- definitions )
+: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
- [ get first2 union ] bi@ diff ;
+ [ get first2 union ] bi@ ;
+
+: removed-classes ( -- assoc1 assoc2 )
+ new-definitions old-definitions
+ [ get second ] bi@ ;
: smudged-usage ( -- usages referenced removed )
- removed-definitions filter-moved keys [
+ removed-definitions filter-moved [
outside-usages
[
empty? [ drop f ] [
@@ -506,9 +510,9 @@ SYMBOL: interactive-vocabs
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2
- [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ]
- [ swap diff values [ class? ] subset [ reset-class ] each ]
- 2bi ;
+ filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each
+ removed-classes
+ filter-moved [ class? ] subset [ reset-class ] each ;
: forget-smudged ( -- )
smudged-usage forget-all
From 45cf030cbd6ed1075e626028849457969c955ef7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 05:21:45 -0500
Subject: [PATCH 081/288] Use call-next-method
---
extra/smtp/smtp-tests.factor | 6 ++++++
extra/smtp/smtp.factor | 2 +-
2 files changed, 7 insertions(+), 1 deletion(-)
diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor
index a705a9609e..1d22ed731a 100755
--- a/extra/smtp/smtp-tests.factor
+++ b/extra/smtp/smtp-tests.factor
@@ -3,6 +3,12 @@ smtp.server kernel sequences namespaces logging accessors
assocs sorting ;
IN: smtp.tests
+[ t ] [
+ <email>
+ dup clone "a" "b" set-header drop
+ headers>> assoc-empty?
+] unit-test
+
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ "hello\nworld" validate-address ] must-fail
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index 13db422621..ee2b021329 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -106,7 +106,7 @@ LOG: smtp-response DEBUG
TUPLE: email from to subject headers body ;
M: email clone
- (clone) [ clone ] change-headers ;
+ call-next-method [ clone ] change-headers ;
: (send) ( email -- )
[
From 1ff2eaf09c9da714cd4699cddf07fba863934abf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 05:24:04 -0500
Subject: [PATCH 082/288] Move enum docs
---
core/assocs/assocs-docs.factor | 14 ++++++++++++++
core/mirrors/mirrors-docs.factor | 8 --------
extra/help/handbook/handbook.factor | 1 +
3 files changed, 15 insertions(+), 8 deletions(-)
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index b6326e1c10..9b0922d096 100755
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -16,6 +16,20 @@ $nl
"To make an assoc into an alist:"
{ $subsection >alist } ;
+ARTICLE: "enums" "Enumerations"
+"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:"
+{ $subsection enum }
+{ $subsection <enum> } ;
+
+HELP: enum
+{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
+$nl
+"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
+
+HELP: <enum>
+{ $values { "seq" sequence } { "enum" enum } }
+{ $description "Creates a new enumeration." } ;
+
ARTICLE: "assocs-protocol" "Associative mapping protocol"
"All associative mappings must be instances of a mixin class:"
{ $subsection assoc }
diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor
index 725a757e61..dc4315fb39 100755
--- a/core/mirrors/mirrors-docs.factor
+++ b/core/mirrors/mirrors-docs.factor
@@ -7,9 +7,6 @@ $nl
"A mirror provides such a view of a tuple:"
{ $subsection mirror }
{ $subsection <mirror> }
-"An enum provides such a view of a sequence:"
-{ $subsection enum }
-{ $subsection <enum> }
"Utility word used by developer tools which inspect objects:"
{ $subsection make-mirror }
{ $see-also "slots" } ;
@@ -44,11 +41,6 @@ HELP: >mirror<
{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
-HELP: enum
-{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
-$nl
-"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
-
HELP: make-mirror
{ $values { "obj" object } { "assoc" assoc } }
{ $description "Creates an assoc which reflects the internal structure of the object." } ;
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index e45c49aa25..847a5952af 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -152,6 +152,7 @@ ARTICLE: "collections" "Collections"
"Implementations:"
{ $subsection "hashtables" }
{ $subsection "alists" }
+{ $subsection "enums" }
{ $heading "Other collections" }
{ $subsection "boxes" }
{ $subsection "dlists" }
From 88092f2c2ae7c86c3c831f8aaaea98e31933fa8a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 05:27:38 -0500
Subject: [PATCH 083/288] Documentation update
---
core/assocs/assocs-docs.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 9b0922d096..e85789a4f2 100755
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -19,7 +19,9 @@ $nl
ARTICLE: "enums" "Enumerations"
"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:"
{ $subsection enum }
-{ $subsection <enum> } ;
+{ $subsection <enum> }
+"Inverting a permutation using enumerations:"
+{ $example "USING: assocs sorting prettyprint ;" ": invert <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
HELP: enum
{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
From 16377be935bcfb1a9346d8d78c22f486baeac2a1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 05:57:20 -0500
Subject: [PATCH 084/288] Use call-next-method
---
core/classes/tuple/tuple.factor | 4 ++--
core/generic/generic.factor | 21 ++++++++-------------
core/words/words-docs.factor | 6 +-----
core/words/words.factor | 8 +-------
4 files changed, 12 insertions(+), 27 deletions(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 58c6f2c581..b1cb3f8a66 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -207,8 +207,8 @@ M: tuple-class define-tuple-class
M: tuple-class reset-class
[
dup "slot-names" word-prop [
- [ reader-word forget-method ]
- [ writer-word forget-method ] 2bi
+ [ reader-word method forget ]
+ [ writer-word method forget ] 2bi
] with each
] [
{
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index b0099f770c..72948c5473 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -106,14 +106,6 @@ M: method-spec definer
M: method-spec definition
first2 method definition ;
-: forget-method ( class generic -- )
- dup generic? [
- [ delete-at* ] with-methods
- [ forget-word ] [ drop ] if
- ] [
- 2drop
- ] if ;
-
M: method-spec forget*
first2 method forget* ;
@@ -123,9 +115,12 @@ M: method-body definer
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
[
- [ "method-class" word-prop ]
+ [ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
- forget-method
+ dup generic? [
+ [ delete-at* ] with-methods
+ [ call-next-method ] [ drop ] if
+ ] [ 2drop ] if
]
[ t "forgotten" set-word-prop ] bi
] if ;
@@ -145,7 +140,7 @@ M: method-body forget*
M: class forget* ( class -- )
[ forget-methods ]
[ update-map- ]
- [ forget-word ]
+ [ call-next-method ]
tri ;
M: assoc update-methods ( assoc -- )
@@ -169,8 +164,8 @@ M: generic subwords
tri
] { } make ;
-M: generic forget-word
- [ subwords forget-all ] [ (forget-word) ] bi ;
+M: generic forget*
+ [ subwords forget-all ] [ call-next-method ] bi ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;
diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index eb1bd0908a..a715aab64f 100755
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -324,11 +324,7 @@ HELP: constructor-word
{ $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." }
{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ;
-HELP: forget-word
-{ $values { "word" word } }
-{ $description "Removes a word from its vocabulary. User code should call " { $link forget } " instead, since it also does the right thing when forgetting class words." } ;
-
-{ POSTPONE: FORGET: forget forget-word forget-vocab } related-words
+{ POSTPONE: FORGET: forget forget* forget-vocab } related-words
HELP: target-word
{ $values { "word" word } { "target" word } }
diff --git a/core/words/words.factor b/core/words/words.factor
index 1232a97ddc..059815e952 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -212,9 +212,7 @@ M: word where "loc" word-prop ;
M: word set-where swap "loc" set-word-prop ;
-GENERIC: forget-word ( word -- )
-
-: (forget-word) ( word -- )
+M: word forget*
dup "forgotten" word-prop [
dup delete-xref
dup delete-compiled-xref
@@ -222,10 +220,6 @@ GENERIC: forget-word ( word -- )
dup t "forgotten" set-word-prop
] unless drop ;
-M: word forget-word (forget-word) ;
-
-M: word forget* forget-word ;
-
M: word hashcode*
nip 1 slot { fixnum } declare ;
From b096395e6c1486a8de01b2d9f8a92dca32e00501 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 06:11:18 -0500
Subject: [PATCH 085/288] Fix reports.noise load error
---
extra/reports/noise/noise.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 7e9496c90d..6921d1223a 100755
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -136,7 +136,7 @@ M: lambda-word word-noise-factor
: flatten-generics ( words -- words' )
[
- dup generic? [ methods values ] [ 1array ] if
+ dup generic? [ "methods" word-prop values ] [ 1array ] if
] map concat ;
: noisy-words ( -- alist )
From d642347f341e3820a3167e1c9c7e489d42928858 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 11:55:08 -0500
Subject: [PATCH 086/288] move bit twiddling words to math.bitfields.lib use
32-bit in mersenne-twister
---
extra/crypto/common/common-docs.factor | 17 -------------
extra/crypto/common/common.factor | 24 ++-----------------
extra/crypto/sha1/sha1.factor | 4 ++--
extra/crypto/sha2/sha2.factor | 20 ++++++++--------
extra/math/functions/functions.factor | 9 -------
.../mersenne-twister/mersenne-twister.factor | 13 ++++------
6 files changed, 19 insertions(+), 68 deletions(-)
diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor
index b53ecaac3c..559c7934d0 100644
--- a/extra/crypto/common/common-docs.factor
+++ b/extra/crypto/common/common-docs.factor
@@ -2,23 +2,6 @@ USING: help.markup help.syntax kernel math sequences quotations
math.private ;
IN: crypto.common
-HELP: >32-bit
-{ $values { "x" integer } { "y" integer } }
-{ $description "Used to implement 32-bit integer overflow." } ;
-
-HELP: >64-bit
-{ $values { "x" integer } { "y" integer } }
-{ $description "Used to implement 64-bit integer overflow." } ;
-
-HELP: bitroll
-{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
-{ $description "Roll n by s bits to the left, wrapping around after w bits." }
-{ $examples
- { $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
- { $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
-} ;
-
-
HELP: hex-string
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor
index 3ac551d114..f0129772b0 100644
--- a/extra/crypto/common/common.factor
+++ b/extra/crypto/common/common.factor
@@ -1,11 +1,8 @@
USING: arrays kernel io io.binary sbufs splitting strings sequences
-namespaces math math.parser parser hints ;
+namespaces math math.parser parser hints math.bitfields.lib ;
IN: crypto.common
-: >32-bit ( x -- y ) HEX: ffffffff bitand ; inline
-: >64-bit ( x -- y ) HEX: ffffffffffffffff bitand ; inline
-
-: w+ ( int int -- int ) + >32-bit ; inline
+: w+ ( int int -- int ) + 32-bit ; inline
: (nth-int) ( string n -- int )
2 shift dup 4 + rot <slice> ; inline
@@ -39,26 +36,9 @@ SYMBOL: big-endian?
3 shift 8 rot [ >be ] [ >le ] if %
] "" make 64 group ;
-: shift-mod ( n s w -- n )
- >r shift r> 2^ 1- bitand ; inline
-
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
-: bitroll ( x s w -- y )
- [ 1 - bitand ] keep
- over 0 < [ [ + ] keep ] when
- [ shift-mod ] 3keep
- [ - ] keep shift-mod bitor ; inline
-
-: bitroll-32 ( n s -- n' ) 32 bitroll ;
-
-HINTS: bitroll-32 bignum fixnum ;
-
-: bitroll-64 ( n s -- n' ) 64 bitroll ;
-
-HINTS: bitroll-64 bignum fixnum ;
-
: hex-string ( seq -- str )
[ [ >hex 2 48 pad-left % ] each ] "" make ;
diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor
index 8f3d3e6ecc..7e8677a117 100755
--- a/extra/crypto/sha1/sha1.factor
+++ b/extra/crypto/sha1/sha1.factor
@@ -1,7 +1,7 @@
USING: arrays combinators crypto.common kernel io
io.encodings.binary io.files io.streams.byte-array math.vectors
strings sequences namespaces math parser sequences vectors
-io.binary hashtables symbols ;
+io.binary hashtables symbols math.bitfields.lib ;
IN: crypto.sha1
! Implemented according to RFC 3174.
@@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
K get nth ,
A get 5 bitroll-32 ,
E get ,
- ] { } make sum >32-bit ; inline
+ ] { } make sum 32-bit ; inline
: set-vars ( temp -- )
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor
index daba6d29ff..f555de8b08 100755
--- a/extra/crypto/sha2/sha2.factor
+++ b/extra/crypto/sha2/sha2.factor
@@ -1,19 +1,19 @@
USING: crypto.common kernel splitting math sequences namespaces
-io.binary symbols ;
+io.binary symbols math.bitfields.lib ;
IN: crypto.sha2
<PRIVATE
SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
-: a 0 ;
-: b 1 ;
-: c 2 ;
-: d 3 ;
-: e 4 ;
-: f 5 ;
-: g 6 ;
-: h 7 ;
+: a 0 ; inline
+: b 1 ; inline
+: c 2 ; inline
+: d 3 ; inline
+: e 4 ; inline
+: f 5 ; inline
+: g 6 ; inline
+: h 7 ; inline
: initial-H-256 ( -- seq )
{
@@ -124,7 +124,7 @@ PRIVATE>
initial-H-256 H set
4 word-size set
64 block-size set
- \ >32-bit >word set
+ \ 32-bit >word set
byte-array>sha2
] with-scope ;
diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor
index dcbccb4316..77c7d9247d 100755
--- a/extra/math/functions/functions.factor
+++ b/extra/math/functions/functions.factor
@@ -30,15 +30,6 @@ M: real sqrt
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline
-: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
-: set-bit ( x n -- y ) 2^ bitor ; foldable
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
-: bit-set? ( x n -- ? ) bit-clear? not ; foldable
-: unmask ( x n -- ? ) bitnot bitand ; foldable
-: unmask? ( x n -- ? ) unmask 0 > ; foldable
-: mask ( x n -- ? ) bitand ; foldable
-: mask? ( x n -- ? ) mask 0 > ; foldable
-
GENERIC: (^) ( x y -- z ) foldable
: ^n ( z w -- z^w )
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index 77054ea377..2aa6f45897 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -4,7 +4,7 @@
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
-accessors math.ranges random circular ;
+accessors math.ranges random circular math.bitfields.lib ;
IN: random.mersenne-twister
<PRIVATE
@@ -33,21 +33,18 @@ TUPLE: mersenne-twister seq i ;
[ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ]
[ 0 >>i drop ] bi ;
-: init-mt-first ( seed -- seq )
- >r mt-n 0 <array> <circular> r>
- HEX: ffffffff bitand 0 pick set-nth ;
-
: init-mt-formula ( seq i -- f(seq[i]) )
tuck swap nth dup -30 shift bitxor 1812433253 * +
- 1+ HEX: ffffffff bitand ;
+ 1+ 32-bit ;
: init-mt-rest ( seq -- )
- mt-n 1- [0,b) [
+ mt-n 1- [
dupd [ init-mt-formula ] keep 1+ rot set-nth
] with each ;
: init-mt-seq ( seed -- seq )
- init-mt-first dup init-mt-rest ;
+ 32-bit mt-n 0 <array> <circular>
+ [ set-first ] [ init-mt-rest ] [ ] tri ;
: mt-temper ( y -- yt )
dup -11 shift bitxor
From 5c2b2b024e1c0b6a4332d752d68f119048b56d4a Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 13:04:24 -0500
Subject: [PATCH 087/288] more cleanup of mersenne-twister -- you can actually
understand it now :)
---
.../mersenne-twister/mersenne-twister.factor | 55 ++++++++++---------
1 file changed, 29 insertions(+), 26 deletions(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index 2aa6f45897..d3a5fad4ca 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
! mersenne twister based on
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-
USING: arrays kernel math namespaces sequences system init
-accessors math.ranges random circular math.bitfields.lib ;
+accessors math.ranges random circular math.bitfields.lib
+combinators ;
IN: random.mersenne-twister
<PRIVATE
@@ -14,36 +14,37 @@ TUPLE: mersenne-twister seq i ;
: mt-n 624 ; inline
: mt-m 397 ; inline
: mt-a HEX: 9908b0df ; inline
-: mt-hi HEX: 80000000 bitand ; inline
-: mt-lo HEX: 7fffffff bitand ; inline
-
-: set-generated ( y from-elt to seq -- )
- >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
- r> bitxor bitxor r> r> set-nth ; inline
: calculate-y ( y1 y2 mt -- y )
- tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline
+ tuck
+ [ nth 32 mask-bit ]
+ [ nth 31 bits ] 2bi* bitor ; inline
-: (mt-generate) ( n mt-seq -- y to from-elt )
- [ >r dup 1+ r> calculate-y ]
- [ >r mt-m + r> nth ]
- [ drop ] 2tri ;
+: (mt-generate) ( n mt-seq -- next-mt )
+ [
+ [ dup 1+ ] [ calculate-y ] bi*
+ [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
+ ] [
+ [ mt-m + ] [ nth ] bi*
+ ] 2bi bitxor ;
: mt-generate ( mt -- )
- [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ]
- [ 0 >>i drop ] bi ;
+ [
+ mt-n swap seq>> [
+ [ (mt-generate) ] [ set-nth ] 2bi
+ ] curry each
+ ] [ 0 >>i drop ] bi ;
-: init-mt-formula ( seq i -- f(seq[i]) )
- tuck swap nth dup -30 shift bitxor 1812433253 * +
- 1+ 32-bit ;
+: init-mt-formula ( i seq -- f(seq[i]) )
+ dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ;
: init-mt-rest ( seq -- )
- mt-n 1- [
- dupd [ init-mt-formula ] keep 1+ rot set-nth
- ] with each ;
+ mt-n 1- swap [
+ [ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi
+ ] curry each ;
: init-mt-seq ( seed -- seq )
- 32-bit mt-n 0 <array> <circular>
+ 32 bits mt-n 0 <array> <circular>
[ set-first ] [ init-mt-rest ] [ ] tri ;
: mt-temper ( y -- yt )
@@ -52,6 +53,9 @@ TUPLE: mersenne-twister seq i ;
dup 15 shift HEX: efc60000 bitand bitxor
dup -18 shift bitxor ; inline
+: next-index ( mt -- i )
+ dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ;
+
PRIVATE>
: <mersenne-twister> ( seed -- obj )
@@ -62,7 +66,6 @@ M: mersenne-twister seed-random ( mt seed -- )
init-mt-seq >>seq drop ;
M: mersenne-twister random-32* ( mt -- r )
- dup [ i>> ] [ seq>> ] bi
- over mt-n < [ nip >r dup mt-generate 0 r> ] unless
- nth mt-temper
- swap [ 1+ ] change-i drop ;
+ [ next-index ]
+ [ seq>> nth mt-temper ]
+ [ [ 1+ ] change-i drop ] tri ;
From 0b90458cca9e82e2e1174edc81324f6e6e29c519 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 13:27:10 -0500
Subject: [PATCH 088/288] simplify bitroll
---
extra/crypto/common/common.factor | 2 +-
extra/crypto/sha1/sha1.factor | 2 +-
extra/crypto/sha2/sha2.factor | 3 +--
extra/math/bitfields/lib/lib-docs.factor | 16 ++++++++++++
extra/math/bitfields/lib/lib-tests.factor | 14 ++++++++++
extra/math/bitfields/lib/lib.factor | 31 +++++++++++++++++++++++
6 files changed, 64 insertions(+), 4 deletions(-)
create mode 100644 extra/math/bitfields/lib/lib-docs.factor
create mode 100644 extra/math/bitfields/lib/lib-tests.factor
create mode 100644 extra/math/bitfields/lib/lib.factor
diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor
index f0129772b0..b9f1d43784 100644
--- a/extra/crypto/common/common.factor
+++ b/extra/crypto/common/common.factor
@@ -2,7 +2,7 @@ USING: arrays kernel io io.binary sbufs splitting strings sequences
namespaces math math.parser parser hints math.bitfields.lib ;
IN: crypto.common
-: w+ ( int int -- int ) + 32-bit ; inline
+: w+ ( int int -- int ) + 32 bits ; inline
: (nth-int) ( string n -- int )
2 shift dup 4 + rot <slice> ; inline
diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor
index 7e8677a117..d054eda31b 100755
--- a/extra/crypto/sha1/sha1.factor
+++ b/extra/crypto/sha1/sha1.factor
@@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
K get nth ,
A get 5 bitroll-32 ,
E get ,
- ] { } make sum 32-bit ; inline
+ ] { } make sum 32 bits ; inline
: set-vars ( temp -- )
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor
index f555de8b08..0acc5c1388 100755
--- a/extra/crypto/sha2/sha2.factor
+++ b/extra/crypto/sha2/sha2.factor
@@ -4,7 +4,7 @@ IN: crypto.sha2
<PRIVATE
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
+SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
: a 0 ; inline
: b 1 ; inline
@@ -124,7 +124,6 @@ PRIVATE>
initial-H-256 H set
4 word-size set
64 block-size set
- \ 32-bit >word set
byte-array>sha2
] with-scope ;
diff --git a/extra/math/bitfields/lib/lib-docs.factor b/extra/math/bitfields/lib/lib-docs.factor
new file mode 100644
index 0000000000..bfbe9eaded
--- /dev/null
+++ b/extra/math/bitfields/lib/lib-docs.factor
@@ -0,0 +1,16 @@
+USING: help.markup help.syntax kernel math sequences ;
+IN: math.bitfields.lib
+
+HELP: bits
+{ $values { "m" integer } { "n" integer } { "m'" integer } }
+{ $description "Keep only n bits from the integer m." }
+{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
+
+HELP: bitroll
+{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
+{ $description "Roll n by s bits to the left, wrapping around after w bits." }
+{ $examples
+ { $example "USING: math.bitfields.lib prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
+ { $example "USING: math.bitfields.lib prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
+} ;
+
diff --git a/extra/math/bitfields/lib/lib-tests.factor b/extra/math/bitfields/lib/lib-tests.factor
new file mode 100644
index 0000000000..c002240e69
--- /dev/null
+++ b/extra/math/bitfields/lib/lib-tests.factor
@@ -0,0 +1,14 @@
+USING: math.bitfields.lib tools.test ;
+IN: math.bitfields.lib.test
+
+[ 0 ] [ 1 0 0 bitroll ] unit-test
+[ 1 ] [ 1 0 1 bitroll ] unit-test
+[ 1 ] [ 1 1 1 bitroll ] unit-test
+[ 1 ] [ 1 0 2 bitroll ] unit-test
+[ 1 ] [ 1 0 1 bitroll ] unit-test
+[ 1 ] [ 1 20 2 bitroll ] unit-test
+[ 1 ] [ 1 8 8 bitroll ] unit-test
+[ 1 ] [ 1 -8 8 bitroll ] unit-test
+[ 1 ] [ 1 -32 8 bitroll ] unit-test
+[ 128 ] [ 1 -1 8 bitroll ] unit-test
+[ 8 ] [ 1 3 32 bitroll ] unit-test
diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor
new file mode 100644
index 0000000000..4a8f3835ca
--- /dev/null
+++ b/extra/math/bitfields/lib/lib.factor
@@ -0,0 +1,31 @@
+USING: hints kernel math ;
+IN: math.bitfields.lib
+
+: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
+: set-bit ( x n -- y ) 2^ bitor ; foldable
+: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
+: bit-set? ( x n -- ? ) bit-clear? not ; foldable
+: unmask ( x n -- ? ) bitnot bitand ; foldable
+: unmask? ( x n -- ? ) unmask 0 > ; foldable
+: mask ( x n -- ? ) bitand ; foldable
+: mask? ( x n -- ? ) mask 0 > ; foldable
+: wrap ( m n -- m' ) 1- bitand ; foldable
+: bits ( m n -- m' ) 2^ wrap ; inline
+: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
+
+: shift-mod ( n s w -- n )
+ >r shift r> 2^ wrap ; inline
+
+: bitroll ( x s w -- y )
+ [ wrap ] keep
+ [ shift-mod ] 3keep
+ [ - ] keep shift-mod bitor ; inline
+
+: bitroll-32 ( n s -- n' ) 32 bitroll ;
+
+HINTS: bitroll-32 bignum fixnum ;
+
+: bitroll-64 ( n s -- n' ) 64 bitroll ;
+
+HINTS: bitroll-64 bignum fixnum ;
+
From 53d21c6c7a8c69351147b4ce73ba4a869b086ed0 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 13:57:33 -0500
Subject: [PATCH 089/288] cleanup in aisle crypto
---
extra/crypto/barrett/barrett.factor | 8 +++++++-
extra/crypto/common/common.factor | 3 +--
extra/crypto/hmac/hmac-tests.factor | 1 -
extra/crypto/hmac/hmac.factor | 1 -
extra/crypto/md5/md5.factor | 6 +++---
extra/crypto/rsa/rsa.factor | 6 +++---
extra/crypto/test/common.factor | 15 ---------------
extra/crypto/timing/timing.factor | 5 ++---
extra/crypto/xor/xor.factor | 6 +++---
9 files changed, 19 insertions(+), 32 deletions(-)
delete mode 100644 extra/crypto/test/common.factor
diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor
index 55da97202f..4a070190e3 100644
--- a/extra/crypto/barrett/barrett.factor
+++ b/extra/crypto/barrett/barrett.factor
@@ -4,5 +4,11 @@ IN: crypto.barrett
: barrett-mu ( n size -- mu )
#! Calculates Barrett's reduction parameter mu
#! size = word size in bits (8, 16, 32, 64, ...)
- over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
+ ! over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
+ [
+ [ log2 1+ ] [ / 2 * ] bi*
+ ] [
+ 2^ rot ^ swap /i
+ ] 2bi ;
+
diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor
index b9f1d43784..a714727ad9 100644
--- a/extra/crypto/common/common.factor
+++ b/extra/crypto/common/common.factor
@@ -50,9 +50,8 @@ SYMBOL: big-endian?
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
- swap ! error?
[ 2array flip concat ] keep like ;
: mod-nth ( n seq -- elt )
#! 5 "abcd" -> b
- [ length mod ] keep nth ;
+ [ length mod ] [ nth ] bi ;
diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor
index fa0cbef4c7..eff95bbcd6 100755
--- a/extra/crypto/hmac/hmac-tests.factor
+++ b/extra/crypto/hmac/hmac-tests.factor
@@ -9,4 +9,3 @@ IN: crypto.hmac.tests
[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test
-
diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor
index 3dad01fe3a..91d404aead 100755
--- a/extra/crypto/hmac/hmac.factor
+++ b/extra/crypto/hmac/hmac.factor
@@ -37,7 +37,6 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: byte-array>sha1-hmac ( K string -- hmac )
binary <byte-reader> stream>sha1-hmac ;
-
: stream>md5-hmac ( K stream -- hmac )
[ init-hmac md5-hmac ] with-stream ;
diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor
index 7ecbd767b9..45e10da74d 100755
--- a/extra/crypto/md5/md5.factor
+++ b/extra/crypto/md5/md5.factor
@@ -3,7 +3,7 @@
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting strings
sequences crypto.common byte-arrays locals sequences.private
-io.encodings.binary symbols ;
+io.encodings.binary symbols math.bitfields.lib ;
IN: crypto.md5
<PRIVATE
@@ -43,11 +43,11 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
- pick bitnot bitand >r bitand r> bitor ;
+ pick bitnot bitand [ bitand ] [ bitor ] bi* ;
: G ( X Y Z -- GXYZ )
#! G(X,Y,Z) = XZ v Y not(Z)
- dup bitnot rot bitand >r bitand r> bitor ;
+ dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
: H ( X Y Z -- HXYZ )
#! H(X,Y,Z) = X xor Y xor Z
diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor
index ccf17da4e8..5d3228db10 100644
--- a/extra/crypto/rsa/rsa.factor
+++ b/extra/crypto/rsa/rsa.factor
@@ -1,5 +1,5 @@
USING: math.miller-rabin kernel math math.functions namespaces
-sequences ;
+sequences accessors ;
IN: crypto.rsa
! The private key is the only secret.
@@ -39,7 +39,7 @@ PRIVATE>
public-key <rsa> ;
: rsa-encrypt ( message rsa -- encrypted )
- [ rsa-public-key ] keep rsa-modulus ^mod ;
+ [ public-key>> ] [ modulus>> ] bi ^mod ;
: rsa-decrypt ( encrypted rsa -- message )
- [ rsa-private-key ] keep rsa-modulus ^mod ;
\ No newline at end of file
+ [ private-key>> ] [ modulus>> ] bi ^mod ;
diff --git a/extra/crypto/test/common.factor b/extra/crypto/test/common.factor
deleted file mode 100644
index 6050454402..0000000000
--- a/extra/crypto/test/common.factor
+++ /dev/null
@@ -1,15 +0,0 @@
-USING: kernel math test namespaces crypto ;
-
-[ 0 ] [ 1 0 0 bitroll ] unit-test
-[ 1 ] [ 1 0 1 bitroll ] unit-test
-[ 1 ] [ 1 1 1 bitroll ] unit-test
-[ 1 ] [ 1 0 2 bitroll ] unit-test
-[ 1 ] [ 1 0 1 bitroll ] unit-test
-[ 1 ] [ 1 20 2 bitroll ] unit-test
-[ 1 ] [ 1 8 8 bitroll ] unit-test
-[ 1 ] [ 1 -8 8 bitroll ] unit-test
-[ 1 ] [ 1 -32 8 bitroll ] unit-test
-[ 128 ] [ 1 -1 8 bitroll ] unit-test
-[ 8 ] [ 1 3 32 bitroll ] unit-test
-
-
diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor
index da2603d92c..a17d65d90b 100644
--- a/extra/crypto/timing/timing.factor
+++ b/extra/crypto/timing/timing.factor
@@ -1,7 +1,6 @@
USING: kernel math threads system ;
IN: crypto.timing
-: with-timing ( ... quot n -- )
+: with-timing ( quot n -- )
#! force the quotation to execute in, at minimum, n milliseconds
- millis 2slip millis - + sleep ;
-
+ millis 2slip millis - + sleep ; inline
diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor
index 0713e19843..247387ebdf 100644
--- a/extra/crypto/xor/xor.factor
+++ b/extra/crypto/xor/xor.factor
@@ -1,8 +1,8 @@
USING: crypto.common kernel math sequences ;
IN: crypto.xor
-TUPLE: no-xor-key ;
+ERROR: no-xor-key ;
-: xor-crypt ( key seq -- seq )
- over empty? [ no-xor-key construct-empty throw ] when
+: xor-crypt ( key seq -- seq' )
+ over empty? [ no-xor-key ] when
dup length rot [ mod-nth bitxor ] curry 2map ;
From d27252e2321e2ef3f9d218df773592caa32c6b09 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 16:02:37 -0500
Subject: [PATCH 090/288] minor cleanup
---
extra/random/mersenne-twister/mersenne-twister.factor | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index d3a5fad4ca..46f2088440 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -15,14 +15,13 @@ TUPLE: mersenne-twister seq i ;
: mt-m 397 ; inline
: mt-a HEX: 9908b0df ; inline
-: calculate-y ( y1 y2 mt -- y )
- tuck
+: calculate-y ( n seq -- y )
[ nth 32 mask-bit ]
- [ nth 31 bits ] 2bi* bitor ; inline
+ [ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline
-: (mt-generate) ( n mt-seq -- next-mt )
+: (mt-generate) ( n seq -- next-mt )
[
- [ dup 1+ ] [ calculate-y ] bi*
+ calculate-y
[ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
] [
[ mt-m + ] [ nth ] bi*
From d2fc408c1b63a375696b94e87d4d42e3bc8fea67 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 17:04:23 -0500
Subject: [PATCH 091/288] Fix Windows launcher
---
extra/io/windows/launcher/launcher.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 2724966a8f..f9b2742cda 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -27,8 +27,7 @@ TUPLE: CreateProcess-args
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles
- 0 >>dwCreateFlags
- current-directory get (normalize-path) >>lpCurrentDirectory ;
+ 0 >>dwCreateFlags ;
: call-CreateProcess ( CreateProcess-args -- )
{
@@ -118,6 +117,7 @@ M: windows run-process* ( process -- handle )
[
dup make-CreateProcess-args
tuck fill-redirection
+ current-directory get (normalize-path) cd
dup call-CreateProcess
lpProcessInformation>>
] with-destructors ;
From e006aca54125cd61fd8f7ba4dafd68f2aef81f94 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 17:33:06 -0500
Subject: [PATCH 092/288] Walker: step directly into the effective method
---
core/generic/generic.factor | 2 ++
core/generic/standard/standard.factor | 4 ++++
extra/tools/walker/walker.factor | 18 ++++++++----------
3 files changed, 14 insertions(+), 10 deletions(-)
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 72948c5473..f41f3ebcd0 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -29,6 +29,8 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
+GENERIC: effective-method ( ... generic -- method )
+
: next-method-class ( class generic -- class/f )
order [ class< ] with subset reverse dup length 1 =
[ drop f ] [ second ] if ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index c36e5f1921..9f9a892fd4 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -118,6 +118,10 @@ M: standard-combination perform-combination
M: standard-combination dispatch# #>> ;
+M: standard-generic effective-method
+ [ dispatch# (picker) call ] keep
+ [ order [ instance? ] with find-last nip ] keep method ;
+
ERROR: inconsistent-next-method object class generic ;
ERROR: no-next-method class generic ;
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index 6bd8ace877..4d1a4da6b1 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -3,7 +3,8 @@
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models arrays accessors ;
+sequences.private assocs models arrays accessors
+generic generic.standard ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -68,15 +69,12 @@ M: object add-breakpoint ;
: (step-into-dispatch) nth (step-into-quot) ;
: (step-into-execute) ( word -- )
- dup "step-into" word-prop [
- call
- ] [
- dup primitive? [
- execute break
- ] [
- word-def (step-into-quot)
- ] if
- ] ?if ;
+ {
+ { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
+ { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup primitive? ] [ execute break ] }
+ { [ t ] [ word-def (step-into-quot) ] }
+ } cond ;
\ (step-into-execute) t "step-into?" set-word-prop
From 9f085cc10a76febc7b77c314b42f7dcad49dfa4a Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:11:22 -0500
Subject: [PATCH 093/288] add using
---
extra/io/windows/files/files.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 4f31d2dfce..8bfbff2ba0 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.backend io.files io.windows kernel math
windows windows.kernel32 windows.time calendar combinators
-math.functions sequences namespaces words symbols
-combinators.lib io.nonblocking destructors system ;
+math.functions sequences namespaces words symbols system
+combinators.lib io.nonblocking destructors math.bitfields.lib ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
From 4acd587629093d156fe0c20b2822cc3b59ac889f Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:34:47 -0500
Subject: [PATCH 094/288] move cwd and cd to private vocabs
---
core/debugger/debugger-docs.factor | 3 ++-
core/io/files/files-docs.factor | 11 ++++++-----
core/io/files/files.factor | 9 ++++++---
extra/editors/jedit/jedit.factor | 2 +-
extra/io/unix/files/files.factor | 7 ++++++-
extra/io/unix/sockets/sockets.factor | 2 +-
extra/io/windows/nt/files/files.factor | 4 ++++
7 files changed, 26 insertions(+), 12 deletions(-)
diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor
index f8b53d4abc..ca6aa59cc4 100755
--- a/core/debugger/debugger-docs.factor
+++ b/core/debugger/debugger-docs.factor
@@ -1,6 +1,7 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system debugger.private ;
+help generic.standard continuations system debugger.private
+io.files.private ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index 342967acfc..d1a59f3604 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -197,19 +197,20 @@ HELP: file-contents
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
HELP: cd
{ $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
-{ cd cwd with-directory } related-words
+{ cd cwd current-directory with-directory } related-words
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
-{ $description "Changes the current working directory for the duration of a quotation's execution." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 45bf0602f2..08ec78492a 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -176,15 +176,18 @@ SYMBOL: +unknown+
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
-! Current working directory
+<PRIVATE
+
HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
-SYMBOL: current-directory
-
M: object cwd ( -- path ) "." ;
+PRIVATE>
+
+SYMBOL: current-directory
+
[ cwd current-directory set-global ] "io.files" add-init-hook
: resource-path ( path -- newpath )
diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor
index 92320addef..e4f19781ef 100755
--- a/extra/editors/jedit/jedit.factor
+++ b/extra/editors/jedit/jedit.factor
@@ -4,7 +4,7 @@ USING: arrays definitions io kernel math
namespaces parser prettyprint sequences strings words
editors io.files io.sockets io.streams.byte-array io.binary
math.parser io.encodings.ascii io.encodings.binary
-io.encodings.utf8 ;
+io.encodings.utf8 io.files.private ;
IN: editors.jedit
: jedit-server-info ( -- port auth )
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index f6bb3edcde..3085827483 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -3,10 +3,13 @@
USING: io.backend io.nonblocking io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar
-io.encodings.binary accessors sequences strings system ;
+io.encodings.binary accessors sequences strings system
+io.files.private ;
IN: io.unix.files
+<PRIVATE
+
M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
@@ -14,6 +17,8 @@ M: unix cwd ( -- path )
M: unix cd ( path -- )
chdir io-error ;
+PRIVATE>
+
: read-flags O_RDONLY ; inline
: open-read ( path -- fd )
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index 477757e0ed..a54205a878 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend io.files system ;
+combinators io.backend io.files io.files.private system ;
IN: io.unix.sockets
: pending-init-error ( port -- )
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 7bac540ddc..590bc59023 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -5,6 +5,8 @@ alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs namespaces ;
IN: io.windows.nt.files
+<PRIVATE
+
M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
@@ -13,6 +15,8 @@ M: winnt cwd
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
+PRIVATE>
+
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
From 344a98802ff651d5e078636ed0983eaecb4e18cb Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:36:53 -0500
Subject: [PATCH 095/288] tweak word
---
extra/math/bitfields/lib/lib.factor | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor
index 4a8f3835ca..72b33b9ae7 100644
--- a/extra/math/bitfields/lib/lib.factor
+++ b/extra/math/bitfields/lib/lib.factor
@@ -4,7 +4,6 @@ IN: math.bitfields.lib
: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
: set-bit ( x n -- y ) 2^ bitor ; foldable
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
-: bit-set? ( x n -- ? ) bit-clear? not ; foldable
: unmask ( x n -- ? ) bitnot bitand ; foldable
: unmask? ( x n -- ? ) unmask 0 > ; foldable
: mask ( x n -- ? ) bitand ; foldable
@@ -18,8 +17,8 @@ IN: math.bitfields.lib
: bitroll ( x s w -- y )
[ wrap ] keep
- [ shift-mod ] 3keep
- [ - ] keep shift-mod bitor ; inline
+ [ shift-mod ]
+ [ [ - ] keep shift-mod ] 3bi bitor ; inline
: bitroll-32 ( n s -- n' ) 32 bitroll ;
From 82f3239012690afbc3f884cb5b6777d63948e976 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:40:51 -0500
Subject: [PATCH 096/288] remove private stuff
---
extra/io/unix/files/files.factor | 4 ----
extra/io/windows/nt/files/files.factor | 4 ----
2 files changed, 8 deletions(-)
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index 3085827483..39c18b4601 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -8,8 +8,6 @@ io.files.private ;
IN: io.unix.files
-<PRIVATE
-
M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
@@ -17,8 +15,6 @@ M: unix cwd ( -- path )
M: unix cd ( path -- )
chdir io-error ;
-PRIVATE>
-
: read-flags O_RDONLY ; inline
: open-read ( path -- fd )
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 590bc59023..7bac540ddc 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -5,8 +5,6 @@ alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs namespaces ;
IN: io.windows.nt.files
-<PRIVATE
-
M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
@@ -15,8 +13,6 @@ M: winnt cwd
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
-PRIVATE>
-
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
From 45b0dd9042625584bcd936027cd194c67721f8f7 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:41:12 -0500
Subject: [PATCH 097/288] add using
---
extra/io/windows/nt/files/files.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 7bac540ddc..3232ab6ff3 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -2,7 +2,8 @@ USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend
kernel libc math threads windows windows.kernel32 system
alien.c-types alien.arrays sequences combinators combinators.lib
-sequences.lib ascii splitting alien strings assocs namespaces ;
+sequences.lib ascii splitting alien strings assocs namespaces
+io.files.private ;
IN: io.windows.nt.files
M: winnt cwd
From 36fc0b26ac9078241223853ae6c50cc002eaaa14 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:51:53 -0500
Subject: [PATCH 098/288] fix load error
---
extra/io/unix/launcher/launcher.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 8e5531a40c..5f0a9b96cb 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend
io.unix.files io.nonblocking sequences kernel namespaces math
system alien.c-types debugger continuations arrays assocs
combinators unix.process strings threads unix
-io.unix.launcher.parser accessors io.files ;
+io.unix.launcher.parser accessors io.files io.files.private ;
IN: io.unix.launcher
! Search unix first
From 653bc1cd80819cbfb81f2082a8240cfda7a54ab7 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:59:04 -0500
Subject: [PATCH 099/288] update docs
---
core/io/files/files-docs.factor | 9 ++++++---
1 file changed, 6 insertions(+), 3 deletions(-)
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index d1a59f3604..85e17ded46 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -28,11 +28,14 @@ ARTICLE: "pathnames" "Pathname manipulation"
{ $subsection <pathname> } ;
ARTICLE: "directories" "Directories"
-"Current and home directories:"
+"Current directory:"
+{ $subsection with-directory }
+{ $subsection current-directory }
+"Home directory:"
+{ $subsection home }
+"Current system directory:"
{ $subsection cwd }
{ $subsection cd }
-{ $subsection with-directory }
-{ $subsection home }
"Directory listing:"
{ $subsection directory }
{ $subsection directory* }
From 8245d65a6c1b3ee0f41faa5f86676127fbd559d0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 19:08:34 -0500
Subject: [PATCH 100/288] Documentation updates
---
core/classes/classes-docs.factor | 8 +-
core/classes/mixin/mixin-docs.factor | 2 +-
core/classes/tuple/tuple-docs.factor | 150 ++++++++++++++++++----
core/classes/tuple/tuple.factor | 2 +-
core/generic/generic-docs.factor | 13 ++
core/kernel/kernel-docs.factor | 21 ++-
core/prettyprint/prettyprint-tests.factor | 3 +
7 files changed, 165 insertions(+), 34 deletions(-)
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 3f30b71457..3eaf7243c9 100755
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -38,17 +38,21 @@ $nl
{ $subsection class? }
"You can ask an object for its class:"
{ $subsection class }
+"Testing if an object is an instance of a class:"
+{ $subsection instance? }
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
{ $subsection object }
{ $subsection null }
"Obtaining a list of all defined classes:"
{ $subsection classes }
-"Other sorts of classes:"
+"There are several sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
-{ $subsection "singletons" }
{ $subsection "mixins" }
{ $subsection "predicates" }
+{ $subsection "singletons" }
+{ $link "tuples" } " are documented in their own section."
+$nl
"Classes can be inspected and operated upon:"
{ $subsection "class-operations" }
{ $see-also "class-index" } ;
diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor
index 1fa6f7bd83..a685d70571 100755
--- a/core/classes/mixin/mixin-docs.factor
+++ b/core/classes/mixin/mixin-docs.factor
@@ -3,7 +3,7 @@ classes ;
IN: classes.mixin
ARTICLE: "mixins" "Mixin classes"
-"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, new classes can be made into instances of a mixin class after the original definition of the mixin."
+"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, mixin classes have the additional property that they are " { $emphasis "open" } "; new classes can be added to the mixin after the original definition of the mixin."
{ $subsection POSTPONE: MIXIN: }
{ $subsection POSTPONE: INSTANCE: }
{ $subsection define-mixin-class }
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 664f0545fa..9ba51d433f 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -3,14 +3,63 @@ classes.tuple.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ;
IN: classes.tuple
-ARTICLE: "tuple-constructors" "Constructors"
-"Tuples are created by calling one of two words:"
+ARTICLE: "parametrized-constructors" "Parameterized constructors"
+"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
+$nl
+"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
+{ $code
+ "TUPLE: vehicle max-speed occupants ;"
+ ""
+ ": add-occupant ( person vehicle -- ) occupants>> push ;"
+ ""
+ "TUPLE: car < vehicle engine ;"
+ ": <car> ( max-speed engine -- car )"
+ " car construct-empty"
+ " V{ } clone >>occupants"
+ " swap >>engine"
+ " swap >>max-speed ;"
+ ""
+ "TUPLE: aeroplane < vehicle max-altitude ;"
+ ": <aeroplane> ( max-speed max-altitude -- aeroplane )"
+ " aeroplane construct-empty"
+ " V{ } clone >>occupants"
+ " swap >>max-altitude"
+ " swap >>max-speed ;"
+}
+"The two constructors depend on the implementation of " { $snippet "vehicle" } " because they are responsible for initializing the " { $snippet "occupants" } " slot to an empty vector. If this slot is changed to contain a hashtable instead, there will be two places instead of one. A better approach is to use a parametrized constructor for vehicles:"
+{ $code
+ "TUPLE: vehicle max-speed occupants ;"
+ ""
+ ": add-occupant ( person vehicle -- ) occupants>> push ;"
+ ""
+ ": construct-vehicle ( class -- vehicle )"
+ " construct-empty"
+ " V{ } clone >>occupants ;"
+ ""
+ "TUPLE: car < vehicle engine ;"
+ ": <car> ( max-speed engine -- car )"
+ " car construct-vehicle"
+ " swap >>engine"
+ " swap >>max-speed ;"
+ ""
+ "TUPLE: aeroplane < vehicle max-altitude ;"
+ ": <aeroplane> ( max-speed max-altitude -- aeroplane )"
+ " aeroplane construct-vehicle"
+ " swap >>max-altitude"
+ " swap >>max-speed ;"
+}
+"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ;
+
+ARTICLE: "tuple-constructors" "Tuple constructors"
+"Tuples are created by calling one of two constructor primitives:"
{ $subsection construct-empty }
{ $subsection construct-boa }
-"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
-$nl
"A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: }
+"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
+$nl
+"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
+$nl
"Examples of constructors:"
{ $code
"TUPLE: color red green blue alpha ;"
@@ -22,29 +71,76 @@ $nl
""
": <color> construct-empty ;"
": <color> f f f f <rgba> ; ! identical to above"
+}
+{ $subsection "parametrized-constructors" } ;
+
+ARTICLE: "tuple-inheritance-example" "Tuple subclassing example"
+"Rectangles, parallelograms and circles are all shapes. We support two operations on shapes:"
+{ $list
+ "Computing the area"
+ "Computing the perimiter"
+}
+"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimiter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:"
+{ $code
+ "GENERIC: area ( shape -- n )"
+ "GENERIC: perimiter ( shape -- n )"
+ ""
+ "TUPLE: shape ;"
+ ""
+ "TUPLE: circle < shape radius ;"
+ "M: area circle radius>> sq pi * ;"
+ "M: perimiter circle radius>> 2 * pi * ;"
+ ""
+ "TUPLE: quad < shape width height"
+ "M: area quad [ width>> ] [ height>> ] bi * ;"
+ ""
+ "TUPLE: rectangle < quad ;"
+ "M: rectangle perimiter [ width>> 2 * ] [ height>> 2 * ] bi + ;"
+ ""
+ ": hypot ( a b -- c ) [ sq ] bi@ + sqrt ;"
+ ""
+ "TUPLE: parallelogram < quad skew ;"
+ "M: parallelogram perimiter"
+ " [ width>> 2 * ] [ [ height>> ] [ skew>> ] bi hypot 2 * ] bi + ;"
} ;
-ARTICLE: "tuple-delegation" "Tuple delegation"
-"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
-{ $subsection delegate }
-{ $subsection set-delegate }
-"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution."
+ARTICLE: "tuple-inheritance-anti-example" "When not to use tuple subclassing"
+"Tuple subclassing should only be used for " { $emphasis "is-a" } " relationships; for example, a car " { $emphasis "is a" } " vehicle, and a circle " { $emphasis "is a" } " shape."
+{ $heading "Anti-pattern #1: subclassing for has-a" }
+"Subclassing should not be used for " { $emphasis "has-a" } " relationships. For example, if a shape " { $emphasis "has a" } " color, then " { $snippet "shape" } " should not subclass " { $snippet "color" } ". Using tuple subclassing in inappropriate situations leads to code which is more brittle and less flexible than it should be."
$nl
-"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object."
+"For example, suppose that " { $snippet "shape" } " inherits from " { $snippet "color" } ":"
+{ $code
+ "TUPLE: color r g b ;"
+ "TUPLE: shape < color ... ;"
+}
+"Now, the implementation of " { $snippet "shape" } " depends on a specific representation of colors as RGB colors. If a new generic color protocol is devised which also allows HSB and YUV colors to be used, the shape class will not be able to take advantage of them without changes. A better approach is to store the color in a slot:"
+{ $code
+ "TUPLE: rgb-color r g b ;"
+ "TUPLE: hsv-color h s v ;"
+ "..."
+ "TUPLE: shape color ... ;"
+}
+{ $heading "Anti-pattern #2: subclassing for implementation sharing only" }
+"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used."
$nl
-"A pair of words examine delegation chains:"
-{ $subsection delegates }
-{ $subsection is? }
-"An example:"
-{ $example
- "TUPLE: ellipse center radius ;"
- "TUPLE: colored color ;"
- "{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
- "{ 1 0 0 } <colored> \"my-shape\" set"
- "\"my-ellipse\" get \"my-shape\" get set-delegate"
- "\"my-shape\" get dup color>> swap center>> .s"
- "{ 0 0 }\n{ 1 0 0 }"
-} ;
+"There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "."
+$nl
+"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
+{ $heading "Anti-pattern #3: subclassing to override a method definition" }
+"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link construct-empty } ", " { $link construct-boa } ", or a custom parametrized constructor."
+{ $see-also "parametrized-constructors" } ;
+
+ARTICLE: "tuple-subclassing" "Tuple subclassing"
+"Tuple subclassing can be used to express natural relationships between classes at the language level. For example, every car " { $emphasis "is a" } " vehicle, so if the " { $snippet "car" } " class subclasses the " { $snippet "vehicle" } " class, it can " { $emphasis "inherit" } " the slots and methods of " { $snippet "vehicle" } "."
+$nl
+"To define one tuple class as a subclass of another, use the optional superclass parameter to " { $link POSTPONE: TUPLE: } ":"
+{ $code
+ "TUPLE: subclass < superclass ... ;"
+}
+{ $subsection "tuple-inheritance-example" }
+{ $subsection "tuple-inheritance-anti-example" }
+{ $see-also "call-next-method" "parametrized-constructors" } ;
ARTICLE: "tuple-introspection" "Tuple introspection"
"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
@@ -119,7 +215,8 @@ ARTICLE: "tuple-examples" "Tuple examples"
": promote ( person -- person )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
-} ;
+}
+"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ;
ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots."
@@ -132,8 +229,9 @@ $nl
{ $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" }
-"Further topics:"
-{ $subsection "tuple-delegation" }
+"Expressing relationships through the object system:"
+{ $subsection "tuple-subclassing" }
+"Introspection:"
{ $subsection "tuple-introspection" }
"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index b1cb3f8a66..00178fd73e 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -162,7 +162,7 @@ M: tuple-class update-class
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
- [ nip "slot-names" set-word-prop ]
+ [ nip [ dup array? [ second ] when ] map "slot-names" set-word-prop ]
[ 2drop update-classes ]
3tri ;
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 04252b6b3b..2034bcf76b 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -37,6 +37,8 @@ $nl
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
+"Finding the most specific method for an object:"
+{ $subsection effective-method }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@@ -64,6 +66,16 @@ $nl
"The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
{ $see-also "generic-introspection" } ;
+ARTICLE: "call-next-method" "Calling less-specific methods"
+"If a generic word is called with an object and multiple methods specialize on classes that this object is an instance of, usually the most specific method is called (" { $link "method-order" } ")."
+$nl
+"Less-specific methods can be called directly:"
+{ $subsection POSTPONE: call-next-method }
+"A lower-level word which the above expands into:"
+{ $subsection (call-next-method) }
+"To look up the next applicable method reflectively:"
+{ $subsection next-method } ;
+
ARTICLE: "generic" "Generic words and methods"
"A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition."
$nl
@@ -81,6 +93,7 @@ $nl
{ $subsection POSTPONE: M: }
"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "."
{ $subsection "method-order" }
+{ $subsection "call-next-method" }
{ $subsection "generic-introspection" }
{ $subsection "method-combination" }
"Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ;
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 53618d4628..328a647339 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -276,6 +276,7 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "apply-combinators" }
{ $subsection "slip-keep-combinators" }
{ $subsection "conditionals" }
+{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"Advanced topics:"
{ $subsection "implementing-combinators" }
@@ -846,11 +847,15 @@ HELP: with
{ $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ;
-HELP: compose
-{ $values { "quot1" callable } { "quot2" callable } { "curry" curry } }
+HELP: compose ( quot1 quot2 -- compose )
+{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes
- "The following two lines are equivalent:"
+ "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
+ { $code
+ "[ 3 >r ] [ r> . ] compose"
+ }
+ "Except for this restriction, the following two lines are equivalent:"
{ $code
"compose call"
"append call"
@@ -862,7 +867,15 @@ HELP: 3compose
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
- "The following two lines are equivalent:"
+ "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
+ { $code
+ "[ >r ] swap [ r> ] 3compose"
+ }
+ "The correct way to achieve the effect of the above is the following:"
+ { $code
+ "[ dip ] curry"
+ }
+ "Excepting the retain stack restriction, the following two lines are equivalent:"
{ $code
"3compose call"
"3append call"
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index 0f384b159d..e94670992c 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -333,3 +333,6 @@ PREDICATE: predicate-see-test < integer even? ;
[ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
[ \ predicate-see-test see ] with-string-writer
] unit-test
+
+[ ] [ \ compose see ] unit-test
+[ ] [ \ curry see ] unit-test
From 90d4266867eb6af40590f1b05208b1db29aa763a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Thu, 3 Apr 2008 19:17:58 -0500
Subject: [PATCH 101/288] Part of delegate changes
---
extra/delegate/delegate-tests.factor | 8 +++++++-
extra/delegate/delegate.factor | 18 ++++++++++++++----
2 files changed, 21 insertions(+), 5 deletions(-)
diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor
index d66357daa5..2a0e013c1a 100644
--- a/extra/delegate/delegate-tests.factor
+++ b/extra/delegate/delegate-tests.factor
@@ -1,6 +1,12 @@
-USING: delegate kernel arrays tools.test ;
+USING: delegate kernel arrays tools.test words math ;
IN: delegate.tests
+DEFER: example
+[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
+[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
+[ 2 ] [ \ example "prop" word-prop ] unit-test
+
+
TUPLE: hello this that ;
C: <hello> hello
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 7f24d6258f..8ca99ec565 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: parser generic kernel classes words slots assocs sequences arrays ;
+USING: parser generic kernel classes words slots assocs sequences arrays
+vectors ;
IN: delegate
: define-protocol ( wordlist protocol -- )
@@ -18,7 +19,7 @@ M: protocol group-words
"protocol-words" word-prop ;
M: generic group-words
- 1array ;
+ 1array ;
M: tuple-class group-words
"slots" word-prop 1 tail ! The first slot is the delegate
@@ -27,10 +28,19 @@ M: tuple-class group-words
swap [ slot-spec-writer ] map append ;
: define-consult-method ( word class quot -- )
- pick add >r swap create-method r> define ;
+ pick add >r swap create-method-in r> define ;
+
+: 3bi ( x y z p q -- p(x,y,z) q(x,y,z) )
+ >r 3keep r> call ; inline
+
+: change-word-prop ( word prop quot -- )
+ >r swap word-props r> change-at ; inline
+
+: declare-consult ( class group -- )
+ "protocol-users" [ ?push ] change-word-prop ;
: define-consult ( class group quot -- )
- >r group-words swap r>
+ >r 2dup declare-consult group-words swap r>
[ define-consult-method ] 2curry each ;
: CONSULT:
From cc2f512287127d9f1f1e57178ab8699cf2e6d9e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 21:19:20 -0500
Subject: [PATCH 102/288] New classes.builtin vocab
---
core/bootstrap/image/image.factor | 6 ++--
core/bootstrap/primitives.factor | 8 ++---
core/classes/algebra/algebra.factor | 8 ++---
core/classes/builtin/builtin-docs.factor | 28 +++++++++++++++
core/classes/builtin/builtin.factor | 18 ++++++++++
core/classes/classes-docs.factor | 27 +-------------
core/classes/classes.factor | 13 -------
core/classes/singleton/singleton-docs.factor | 26 ++++++++------
core/classes/tuple/tuple.factor | 7 ++--
core/debugger/debugger.factor | 6 ++--
core/generic/generic-docs.factor | 10 +++++-
core/generic/math/math.factor | 3 +-
core/generic/standard/standard-docs.factor | 38 +++++++++++++++++++-
core/layouts/layouts-docs.factor | 2 +-
core/prettyprint/prettyprint.factor | 6 ++--
core/slots/slots-docs.factor | 4 +--
core/syntax/syntax-docs.factor | 17 ++++++++-
extra/help/handbook/handbook.factor | 3 +-
18 files changed, 153 insertions(+), 77 deletions(-)
create mode 100644 core/classes/builtin/builtin-docs.factor
create mode 100644 core/classes/builtin/builtin.factor
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 6e0f8e2970..05d48af2e8 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -4,9 +4,9 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
-splitting growable classes classes.tuple classes.tuple.private
-words.private io.binary io.files vocabs vocabs.loader
-source-files definitions debugger float-arrays
+splitting growable classes classes.builtin classes.tuple
+classes.tuple.private words.private io.binary io.files vocabs
+vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators
io.encodings.binary ;
IN: bootstrap.image
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 6c87730278..516ff7ed74 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -3,10 +3,10 @@
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes
-classes.tuple classes.tuple.private kernel.private vocabs
-vocabs.loader source-files definitions slots.deprecated
-classes.union compiler.units bootstrap.image.private io.files
-accessors combinators ;
+classes.builtin classes.tuple classes.tuple.private
+kernel.private vocabs vocabs.loader source-files definitions
+slots.deprecated classes.union compiler.units
+bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 97309dbea2..4614e4c4ce 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes combinators accessors sequences arrays
-vectors assocs namespaces words sorting layouts math hashtables
-kernel.private ;
+USING: kernel classes classes.builtin combinators accessors
+sequences arrays vectors assocs namespaces words sorting layouts
+math hashtables kernel.private ;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
@@ -103,7 +103,7 @@ C: <anonymous-complement> anonymous-complement
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
- { [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] }
+ { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
{ [ t ] [ swap classes-intersect? ] }
} cond ;
diff --git a/core/classes/builtin/builtin-docs.factor b/core/classes/builtin/builtin-docs.factor
new file mode 100644
index 0000000000..6c5c262087
--- /dev/null
+++ b/core/classes/builtin/builtin-docs.factor
@@ -0,0 +1,28 @@
+USING: help.syntax help.markup classes layouts ;
+IN: classes.builtin
+
+ARTICLE: "builtin-classes" "Built-in classes"
+"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
+$nl
+"The set of built-in classes is a class:"
+{ $subsection builtin-class }
+{ $subsection builtin-class? }
+"See " { $link "type-index" } " for a list of built-in classes." ;
+
+HELP: builtin-class
+{ $class-description "The class of built-in classes." }
+{ $examples
+ "The class of arrays is a built-in class:"
+ { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
+ "However, an instance of the array class is not a built-in class; it is not even a class:"
+ { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
+} ;
+
+HELP: builtins
+{ $var-description "Vector mapping type numbers to builtin class words." } ;
+
+HELP: type>class
+{ $values { "n" "a non-negative integer" } { "class" class } }
+{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
+{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
+
diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
new file mode 100644
index 0000000000..1c2871b031
--- /dev/null
+++ b/core/classes/builtin/builtin.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes words kernel kernel.private namespaces
+sequences ;
+IN: classes.builtin
+
+SYMBOL: builtins
+
+PREDICATE: builtin-class < class
+ "metaclass" word-prop builtin-class eq? ;
+
+: type>class ( n -- class ) builtins get-global nth ;
+
+: bootstrap-type>class ( n -- class ) builtins get nth ;
+
+M: hi-tag class hi-tag type>class ;
+
+M: object class tag type>class ;
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 3eaf7243c9..dd3782e877 100755
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -4,14 +4,6 @@ layouts classes.private classes.union classes.mixin
classes.predicate quotations ;
IN: classes
-ARTICLE: "builtin-classes" "Built-in classes"
-"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
-$nl
-"The set of built-in classes is a class:"
-{ $subsection builtin-class }
-{ $subsection builtin-class? }
-"See " { $link "type-index" } " for a list of built-in classes." ;
-
ARTICLE: "class-predicates" "Class predicate words"
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
$nl
@@ -62,37 +54,20 @@ ABOUT: "classes"
HELP: class
{ $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
-{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." }
+{ $class-description "The class of all class words." }
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
-HELP: builtin-class
-{ $class-description "The class of built-in classes." }
-{ $examples
- "The class of arrays is a built-in class:"
- { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
- "However, an instance of the array class is not a built-in class; it is not even a class:"
- { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
-} ;
-
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
-HELP: builtins
-{ $var-description "Vector mapping type numbers to builtin class words." } ;
-
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
-HELP: type>class
-{ $values { "n" "a non-negative integer" } { "class" class } }
-{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
-{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
-
HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index c45fd7360b..b22e21eb92 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -30,20 +30,11 @@ SYMBOL: update-map
PREDICATE: class < word
"class" word-prop ;
-SYMBOL: builtins
-
-PREDICATE: builtin-class < class
- "metaclass" word-prop builtin-class eq? ;
-
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] subset ;
-: type>class ( n -- class ) builtins get-global nth ;
-
-: bootstrap-type>class ( n -- class ) builtins get nth ;
-
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
@@ -130,9 +121,5 @@ GENERIC: update-methods ( assoc -- )
GENERIC: class ( object -- class )
-M: hi-tag class hi-tag type>class ;
-
-M: object class tag type>class ;
-
: instance? ( obj class -- ? )
"predicate" word-prop call ;
diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor
index 8548f84a3a..a8dae809ec 100644
--- a/core/classes/singleton/singleton-docs.factor
+++ b/core/classes/singleton/singleton-docs.factor
@@ -2,27 +2,33 @@ USING: help.markup help.syntax kernel words ;
IN: classes.singleton
ARTICLE: "singletons" "Singleton classes"
-"A singleton is a class with only one instance and with no state. Methods may dispatch off of singleton classes."
+"A singleton is a class with only one instance and with no state."
{ $subsection POSTPONE: SINGLETON: }
-{ $subsection define-singleton-class } ;
+{ $subsection define-singleton-class }
+"The set of all singleton classes is itself a class:"
+{ $subsection singleton-class? }
+{ $subsection singleton-class } ;
HELP: SINGLETON:
-{ $syntax "SINGLETON: class"
-} { $values
+{ $syntax "SINGLETON: class" }
+{ $values
{ "class" "a new singleton to define" }
-} { $description
- "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton."
-} { $examples
+}
+{ $description
+ "Defines a new singleton class. The class word itself is the sole instance of the singleton class."
+}
+{ $examples
{ $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
-} { $see-also
- POSTPONE: PREDICATE:
} ;
HELP: define-singleton-class
{ $values { "word" "a new word" } }
{ $description
- "Defines a newly created word to be a singleton class." } ;
+ "Defines a singleton class. This is the run-time equivalent of " { $link POSTPONE: SINGLETON: } "." } ;
{ POSTPONE: SINGLETON: define-singleton-class } related-words
+HELP: singleton-class
+{ $class-description "The class of singleton classes." } ;
+
ABOUT: "singletons"
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 00178fd73e..ef81a0c953 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -56,7 +56,8 @@ PRIVATE>
unclip slots>tuple ;
: slot-names ( class -- seq )
- "slot-names" word-prop ;
+ "slot-names" word-prop
+ [ dup array? [ second ] when ] map ;
<PRIVATE
@@ -107,7 +108,7 @@ PRIVATE>
over superclass-size 2 + simple-slots ;
: define-tuple-slots ( class -- )
- dup dup slot-names generate-tuple-slots
+ dup dup "slot-names" word-prop generate-tuple-slots
[ "slots" set-word-prop ]
[ define-accessors ] ! new
[ define-slots ] ! old
@@ -162,7 +163,7 @@ M: tuple-class update-class
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
- [ nip [ dup array? [ second ] when ] map "slot-names" set-word-prop ]
+ [ nip "slot-names" set-word-prop ]
[ 2drop update-classes ]
3tri ;
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index 033ae0680c..77e8f0ac05 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -4,9 +4,9 @@ USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators
-generic.math io.streams.duplex classes compiler.units
-generic.standard vocabs threads threads.private init
-kernel.private libc io.encodings ;
+generic.math io.streams.duplex classes.builtin classes
+compiler.units generic.standard vocabs threads threads.private
+init kernel.private libc io.encodings ;
IN: debugger
GENERIC: error. ( error -- )
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 2034bcf76b..1024c377a8 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -74,7 +74,10 @@ $nl
"A lower-level word which the above expands into:"
{ $subsection (call-next-method) }
"To look up the next applicable method reflectively:"
-{ $subsection next-method } ;
+{ $subsection next-method }
+"Errors thrown by improper calls to " { $link POSTPONE: call-next-method } ":"
+{ $subsection inconsistent-next-method }
+{ $subsection no-next-method } ;
ARTICLE: "generic" "Generic words and methods"
"A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition."
@@ -160,3 +163,8 @@ HELP: forget-methods
{ $description "Remove all method definitions which specialize on the class." } ;
{ sort-classes order } related-words
+
+HELP: (call-next-method)
+{ $values { "class" class } { "generic" generic } }
+{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
+{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 46208744f0..fce908bdef 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
-sequences.private classes classes.algebra definitions ;
+sequences.private classes classes.builtin classes.algebra
+definitions ;
IN: generic.math
PREDICATE: math-class < class
diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor
index a6a65bb62f..09746d35f5 100644
--- a/core/generic/standard/standard-docs.factor
+++ b/core/generic/standard/standard-docs.factor
@@ -1,4 +1,5 @@
-USING: generic help.markup help.syntax sequences ;
+USING: generic help.markup help.syntax sequences math
+math.parser ;
IN: generic.standard
HELP: no-method
@@ -31,3 +32,38 @@ HELP: define-simple-generic
{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
{ standard-combination hook-combination } related-words
+
+HELP: no-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: number error-test 3 + call-next-method ;"
+ ""
+ "M: integer error-test recip call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
+} ;
+
+HELP: inconsistent-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: string error-test print ;"
+ ""
+ "M: integer error-test number>string call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
+ $nl
+ "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
+ { $code "M: integer error-test number>string error-test ;" }
+} ;
diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor
index 089465177b..a54df30c50 100755
--- a/core/layouts/layouts-docs.factor
+++ b/core/layouts/layouts-docs.factor
@@ -1,6 +1,6 @@
USING: generic help.markup help.syntax kernel math
memory namespaces sequences kernel.private classes
-sequences.private ;
+classes.builtin sequences.private ;
IN: layouts
HELP: tag-bits
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index fd7133053a..03d3e456ca 100755
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -5,9 +5,9 @@ USING: alien arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
-definitions effects classes.tuple io.files classes continuations
-hashtables classes.mixin classes.union classes.predicate
-classes.singleton combinators quotations ;
+definitions effects classes.builtin classes.tuple io.files
+classes continuations hashtables classes.mixin classes.union
+classes.predicate classes.singleton combinators quotations ;
: make-pprint ( obj quot -- block in use )
[
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index 2b0d721f3e..29facb31f2 100755
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -1,7 +1,7 @@
USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
-effects generic.standard classes.tuple slots.private classes
-strings math ;
+effects generic.standard classes.tuple classes.builtin
+slots.private classes strings math ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index b242e65de5..39a4d266e9 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -1,6 +1,7 @@
USING: generic help.syntax help.markup kernel math parser words
effects classes generic.standard classes.tuple generic.math
-arrays io.files vocabs.loader io sequences assocs ;
+generic.standard arrays io.files vocabs.loader io sequences
+assocs ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
@@ -633,4 +634,18 @@ HELP: >>
{ $syntax ">>" }
{ $description "Marks the end of a parse time code block." } ;
+HELP: call-next-method
+{ $description "Calls the next applicable method. Only valid inside a method definition. The values at the top of the stack are passed on to the next method, and they must be compatible with that method's class specializer." }
+{ $notes "This is syntax sugar around " { $link (call-next-method) } ". The following two lines are equivalent:"
+ { $code
+ "M: my-class my-generic ... call-next-method ... ;"
+ "M: my-class my-generic ... \\ my-class \\ my-generic (call-next-method) ... ;"
+ }
+"In most cases, this word should be called with the original input values on the stack. Calling it with other values is usually a sign of poor design." }
+{ $errors
+ "Throws a " { $link no-next-method } " error if this is the least specific method, and throws an " { $link inconsistent-next-method } " error if the values at the top of the stack are not compatible with the current method's specializer."
+} ;
+
+{ POSTPONE: call-next-method (call-next-method) next-method } related-words
+
{ POSTPONE: << POSTPONE: >> } related-words
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index 847a5952af..acdbca82ee 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -2,7 +2,8 @@ USING: help help.markup help.syntax help.definitions help.topics
namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
-quotations io.streams.byte-array io.encodings.string ;
+quotations io.streams.byte-array io.encodings.string
+classes.builtin ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
From f2440381cd45714eff023332128a3a519400df05 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 21:29:49 -0500
Subject: [PATCH 103/288] More documentation updates
---
core/classes/mixin/mixin-docs.factor | 6 ++++--
core/classes/tuple/tuple-docs.factor | 2 +-
core/classes/union/union-docs.factor | 4 +++-
3 files changed, 8 insertions(+), 4 deletions(-)
diff --git a/core/classes/mixin/mixin-docs.factor b/core/classes/mixin/mixin-docs.factor
index a685d70571..82dec5cec0 100755
--- a/core/classes/mixin/mixin-docs.factor
+++ b/core/classes/mixin/mixin-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax help words compiler.units
-classes ;
+classes sequences ;
IN: classes.mixin
ARTICLE: "mixins" "Mixin classes"
@@ -10,7 +10,9 @@ ARTICLE: "mixins" "Mixin classes"
{ $subsection add-mixin-instance }
"The set of mixin classes is a class:"
{ $subsection mixin-class }
-{ $subsection mixin-class? } ;
+{ $subsection mixin-class? }
+"Mixins are used to defines suites of behavior which are generally useful and can be applied to user-defined classes. For example, the " { $link immutable-sequence } " mixin can be used with user-defined sequences to make them immutable."
+{ $see-also "unions" "tuple-subclassing" } ;
HELP: mixin-class
{ $class-description "The class of mixin classes." } ;
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 9ba51d433f..87e035958b 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -140,7 +140,7 @@ $nl
}
{ $subsection "tuple-inheritance-example" }
{ $subsection "tuple-inheritance-anti-example" }
-{ $see-also "call-next-method" "parametrized-constructors" } ;
+{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
ARTICLE: "tuple-introspection" "Tuple introspection"
"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor
index 237f32c3e0..91726b6697 100755
--- a/core/classes/union/union-docs.factor
+++ b/core/classes/union/union-docs.factor
@@ -11,7 +11,9 @@ ARTICLE: "unions" "Union classes"
{ $subsection members }
"The set of union classes is a class:"
{ $subsection union-class }
-{ $subsection union-class? } ;
+{ $subsection union-class? }
+"Unions are used to define behavior shared between a fixed set of classes."
+{ $see-also "mixins" "tuple-subclassing" } ;
ABOUT: "unions"
From dbb0cf55cca93b0e7fd9cebd172b44202b8d97de Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 21:29:56 -0500
Subject: [PATCH 104/288] Fix UI completion bug
---
extra/ui/tools/listener/listener.factor | 22 ++++++++++++++++------
1 file changed, 16 insertions(+), 6 deletions(-)
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index 7db0d63f45..52c3d2de42 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inspector ui.tools.interactor ui.tools.inspector
ui.tools.workspace help.markup io io.streams.duplex io.styles
@@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
prettyprint listener debugger threads boxes concurrency.flags
-math arrays ;
+math arrays generic accessors ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
@@ -101,16 +101,26 @@ M: listener-operation invoke-command ( target command -- )
: clear-stack ( listener -- )
[ clear ] swap (call-listener) ;
-: word-completion-string ( word listener -- string )
- >r dup word-name swap word-vocabulary dup vocab-words r>
- listener-gadget-input interactor-use memq?
+GENERIC# word-completion-string 1 ( word listener -- string )
+
+M: method-body word-completion-string
+ >r "method-generic" word-prop r> word-completion-string ;
+
+USE: generic.standard.engines.tuple
+
+M: tuple-dispatch-engine-word word-completion-string
+ >r "engine-generic" word-prop r> word-completion-string ;
+
+M: word word-completion-string ( word listener -- string )
+ >r [ word-name ] [ word-vocabulary ] bi dup vocab-words r>
+ input>> interactor-use memq?
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
: insert-word ( word -- )
get-workspace
workspace-listener
[ word-completion-string ] keep
- listener-gadget-input user-input ;
+ input>> user-input ;
: quot-action ( interactor -- lines )
dup control-value
From e22a7a610047cc2bf768940ba64543c5f4b94937 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 3 Apr 2008 21:39:52 -0500
Subject: [PATCH 105/288] update docs pl0x
---
core/io/files/files-docs.factor | 155 +++++++++++++++++++++++---------
core/io/files/files.factor | 8 +-
2 files changed, 115 insertions(+), 48 deletions(-)
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index 85e17ded46..1dd96a13fc 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -11,7 +11,9 @@ ARTICLE: "file-streams" "Reading and writing files"
{ $subsection with-file-reader }
{ $subsection with-file-writer }
{ $subsection with-file-appender }
+{ $subsection set-file-contents }
{ $subsection file-contents }
+{ $subsection set-file-lines }
{ $subsection file-lines } ;
ARTICLE: "pathnames" "Pathname manipulation"
@@ -27,15 +29,22 @@ ARTICLE: "pathnames" "Pathname manipulation"
{ $subsection pathname }
{ $subsection <pathname> } ;
+ARTICLE: "symbolic-links" "Symbolic links"
+"Reading and creating links:"
+{ $subsection read-link }
+{ $subsection make-link }
+"Copying links:"
+{ $subsection copy-link }
+"Not all operating systems support symbolic links."
+{ $see-also link-info } ;
+
ARTICLE: "directories" "Directories"
"Current directory:"
-{ $subsection with-directory }
{ $subsection current-directory }
+{ $subsection set-current-directory }
+{ $subsection with-directory }
"Home directory:"
{ $subsection home }
-"Current system directory:"
-{ $subsection cwd }
-{ $subsection cd }
"Directory listing:"
{ $subsection directory }
{ $subsection directory* }
@@ -43,18 +52,26 @@ ARTICLE: "directories" "Directories"
{ $subsection make-directory }
{ $subsection make-directories } ;
-! ARTICLE: "file-types" "File Types"
-
-! { $table { +directory+ "" } }
-
-! ;
-
-ARTICLE: "fs-meta" "File meta-data"
+ARTICLE: "file-types" "File Types"
+"Platform-independent types:"
+{ $subsection +regular-file+ }
+{ $subsection +directory+ }
+"Platform-specific types:"
+{ $subsection +character-device+ }
+{ $subsection +block-device+ }
+{ $subsection +fifo+ }
+{ $subsection +symbolic-link+ }
+{ $subsection +socket+ }
+{ $subsection +unknown+ } ;
+ARTICLE: "fs-meta" "File metadata"
+"Querying file-system metadata:"
{ $subsection file-info }
{ $subsection link-info }
{ $subsection exists? }
-{ $subsection directory? } ;
+{ $subsection directory? }
+"File types:"
+{ $subsection "file-types" } ;
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
"Operations for deleting and copying files come in two forms:"
@@ -123,39 +140,40 @@ HELP: file-name
! need a $class-description file-info
HELP: file-info
-
- { $values { "path" "a pathname string" }
- { "info" file-info } }
- { $description "Queries the file system for meta data. "
- "If path refers to a symbolic link, it is followed."
- "If the file does not exist, an exception is thrown." }
-
- { $class-description "File meta data" }
-
- { $table
- { "type" { "One of the following:"
- { $list { $link +regular-file+ }
- { $link +directory+ }
- { $link +symbolic-link+ } } } }
-
- { "size" "Size of the file in bytes" }
- { "modified" "Last modification timestamp." } }
-
- ;
-
-! need a see also to link-info
+{ $values { "path" "a pathname string" } { "info" file-info } }
+{ $description "Queries the file system for metadata. If " { $snippet "path" } " refers to a symbolic link, it is followed. See the article " { $link "file-types" } " for a list of metadata symbols." }
+{ $errors "Throws an error if the file does not exist." } ;
HELP: link-info
- { $values { "path" "a pathname string" }
- { "info" "a file-info tuple" } }
- { $description "Queries the file system for meta data. "
- "If path refers to a symbolic link, information about "
- "the symbolic link itself is returned."
- "If the file does not exist, an exception is thrown." } ;
-! need a see also to file-info
+{ $values { "path" "a pathname string" } { "info" "a file-info tuple" } }
+{ $description "Queries the file system for metadata. If path refers to a symbolic link, information about the symbolic link itself is returned. If the file does not exist, an exception is thrown." } ;
{ file-info link-info } related-words
+HELP: +regular-file+
+{ $description "A regular file. This type exists on all platforms. See " { $link "file-streams" } " for words operating on files." } ;
+
+HELP: +directory+
+{ $description "A directory. This type exists on all platforms. See " { $link "directories" } " for words operating on directories." } ;
+
+HELP: +symbolic-link+
+{ $description "A symbolic link file. This type is currently implemented on Unix platforms only. See " { $link "symbolic-links" } " for words operating on symbolic links." } ;
+
+HELP: +character-device+
+{ $description "A Unix character device file. This type exists on unix platforms only." } ;
+
+HELP: +block-device+
+{ $description "A Unix block device file. This type exists on unix platforms only." } ;
+
+HELP: +fifo+
+{ $description "A Unix fifo file. This type exists on unix platforms only." } ;
+
+HELP: +socket+
+{ $description "A Unix socket file. This type exists on unix platforms only." } ;
+
+HELP: +unknown+
+{ $description "A unknown file type." } ;
+
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
{ "stream" "an input stream" } }
@@ -187,29 +205,44 @@ HELP: with-file-appender
{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
+HELP: set-file-lines
+{ $values { "seq" "an array of strings" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
+{ $description "Sets the contents of a file to the strings with the given encoding." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
HELP: file-lines
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } }
{ $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." }
+{ $errors "Throws an error if the file cannot be opened for reading." } ;
+
+HELP: set-file-contents
+{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
+{ $description "Sets the contents of a file to a string with the given encoding." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: file-contents
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } }
{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." }
-{ $errors "Throws an error if the file cannot be opened for writing." } ;
+{ $errors "Throws an error if the file cannot be opened for reading." } ;
+
+{ set-file-lines file-lines set-file-contents file-contents } related-words
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
-{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
+{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
HELP: cd
{ $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
-{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
+{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
-{ cd cwd current-directory with-directory } related-words
+{ cd cwd current-directory set-current-directory with-directory } related-words
+
+HELP: current-directory
+{ $description "A variable holding the current directory. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ;
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
@@ -219,6 +252,26 @@ HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two pathnames." } ;
+HELP: prepend-path
+{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
+{ $description "Concatenates two pathnames." } ;
+
+{ append-path prepend-path } related-words
+
+HELP: absolute-path?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is absolute. Examples of absolute pathnames are " { $snippet "/foo/bar" } " on Unix and " { $snippet "c:\\foo\\bar" } " on Windows." } ;
+
+HELP: windows-absolute-path?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is absolute on Windows. Examples of absolute pathnames on Windows are " { $snippet "c:\\foo\\bar" } " and " { $snippet "\\\\?\\c:\\foo\\bar" } " for absolute Unicode pathnames." } ;
+
+HELP: root-directory?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is a root directory. Examples of root directory pathnames are " { $snippet "/" } " on Unix and " { $snippet "c:\\" } " on Windows." } ;
+
+{ absolute-path? windows-absolute-path? root-directory? } related-words
+
HELP: exists?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
@@ -264,6 +317,20 @@ HELP: <pathname> ( str -- pathname )
{ $values { "str" "a pathname string" } { "pathname" pathname } }
{ $description "Creates a new " { $link pathname } "." } ;
+HELP: make-link
+{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
+{ $description "Creates a symbolic link." } ;
+
+HELP: read-link
+{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
+{ $description "Reads the symbolic link and returns its target path." } ;
+
+HELP: copy-link
+{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
+{ $description "Copies a symbolic link without following the link." } ;
+
+{ make-link read-link copy-link } related-words
+
HELP: home
{ $values { "dir" string } }
{ $description "Outputs the user's home directory." } ;
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 08ec78492a..ed1b94e556 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -153,19 +153,19 @@ HOOK: file-info io-backend ( path -- info )
! Symlinks
HOOK: link-info io-backend ( path -- info )
-HOOK: make-link io-backend ( path1 path2 -- )
+HOOK: make-link io-backend ( target symlink -- )
-HOOK: read-link io-backend ( path -- info )
+HOOK: read-link io-backend ( symlink -- path )
-: copy-link ( path1 path2 -- )
+: copy-link ( target symlink -- )
>r read-link r> make-link ;
SYMBOL: +regular-file+
SYMBOL: +directory+
+SYMBOL: +symbolic-link+
SYMBOL: +character-device+
SYMBOL: +block-device+
SYMBOL: +fifo+
-SYMBOL: +symbolic-link+
SYMBOL: +socket+
SYMBOL: +unknown+
From 76581ad6d08a5564bc4171aa3971eed2263981f2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 21:43:41 -0500
Subject: [PATCH 106/288] Remove crappy parser feature
---
core/parser/parser-docs.factor | 8 ------
core/parser/parser-tests.factor | 41 ---------------------------
core/parser/parser.factor | 41 ++++++---------------------
core/source-files/source-files.factor | 18 ++++++------
4 files changed, 17 insertions(+), 91 deletions(-)
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index cc4e2c0a42..61fd9f7f30 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -445,18 +445,10 @@ HELP: eval
{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
-HELP: outside-usages
-{ $values { "seq" "a sequence of definitions" } { "usages" "an association list mapping definitions to sequences of definitions" } }
-{ $description "Outputs an association list mapping elements of " { $snippet "seq" } " to lists of usages which exclude the definitions in " { $snippet "seq" } " themselves." } ;
-
HELP: filter-moved
{ $values { "assoc" "an assoc where the keys are definitions" } { "newassoc" "an assoc where the keys are definitions" } }
{ $description "Removes all definitions from the assoc which are no longer present in the current " { $link file } "." } ;
-HELP: smudged-usage
-{ $values { "usages" "a sequence of definitions which reference removed definitions" } { "referenced" "a sequence of definitions removed from this source file which are still referenced elsewhere" } { "removed" "a sequence of definitions removed from this source file" } }
-{ $description "Collects information about changed word definitioins after parsing." } ;
-
HELP: forget-smudged
{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 6bd4abb7e1..ab9648c527 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -348,47 +348,6 @@ IN: parser.tests
] must-fail
] with-file-vocabs
-[
- << file get parsed >> file set
-
- : ~a ;
-
- DEFER: ~b
-
- "IN: parser.tests : ~b ~a ;" <string-reader>
- "smudgy" parse-stream drop
-
- : ~c ;
- : ~d ;
-
- { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
-
- { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
-
- [ V{ ~b } { ~a } { ~a ~c } ] [
- smudged-usage
- natural-sort
- ] unit-test
-] with-scope
-
-[
- << file get parsed >> file set
-
- GENERIC: ~e
-
- : ~f ~e ;
-
- : ~g ;
-
- { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
-
- { H{ { ~g ~g } } H{ } } new-definitions set
-
- [ V{ } { } { ~e ~f } ]
- [ smudged-usage natural-sort ]
- unit-test
-] with-scope
-
[ ] [
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
] unit-test
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 902bae29b5..8fcbad4d3c 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -464,19 +464,6 @@ SYMBOL: interactive-vocabs
"Loading " write <pathname> . flush
] if ;
-: smudged-usage-warning ( usages removed -- )
- parser-notes? [
- "Warning: the following definitions were removed from sources," print
- "but are still referenced from other definitions:" print
- nl
- dup sorted-definitions.
- nl
- "The following definitions need to be updated:" print
- nl
- over sorted-definitions.
- nl
- ] when 2drop ;
-
: filter-moved ( assoc1 assoc2 -- seq )
diff [
drop where dup [ first ] when
@@ -491,32 +478,22 @@ SYMBOL: interactive-vocabs
new-definitions old-definitions
[ get second ] bi@ ;
-: smudged-usage ( -- usages referenced removed )
- removed-definitions filter-moved [
- outside-usages
- [
- empty? [ drop f ] [
- {
- { [ dup pathname? ] [ f ] }
- { [ dup method-body? ] [ f ] }
- { [ t ] [ t ] }
- } cond nip
- ] if
- ] assoc-subset
- dup values concat prune swap keys
- ] keep ;
+: forget-removed-definitions ( -- )
+ removed-definitions filter-moved forget-all ;
+
+: reset-removed-classes ( -- )
+ removed-classes
+ filter-moved [ class? ] subset [ reset-class ] each ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2
- filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each
- removed-classes
- filter-moved [ class? ] subset [ reset-class ] each ;
+ filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
: forget-smudged ( -- )
- smudged-usage forget-all
- over empty? [ 2dup smudged-usage-warning ] unless 2drop
+ forget-removed-definitions
+ reset-removed-classes
fix-class-words ;
: finish-parsing ( lines quot -- )
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 8dea367b6b..5df5f503f9 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -56,10 +56,14 @@ uses definitions ;
M: pathname where pathname-string 1 2array ;
: forget-source ( path -- )
- dup source-file
- dup unxref-source
- source-file-definitions [ keys forget-all ] each
- source-files get delete-at ;
+ [
+ source-file
+ [ unxref-source ]
+ [ definitions>> [ keys forget-all ] each ]
+ bi
+ ]
+ [ source-files get delete-at ]
+ bi ;
M: pathname forget*
pathname-string forget-source ;
@@ -78,9 +82,3 @@ SYMBOL: file
source-file-definitions old-definitions set
[ ] [ file get rollback-source-file ] cleanup
] with-scope ; inline
-
-: outside-usages ( seq -- usages )
- dup [
- over usage
- [ dup pathname? not swap where and ] subset seq-diff
- ] curry { } map>assoc ;
From 1e538ccd03cf725fe71fe6dec5b2acd7e8507bbb Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 3 Apr 2008 22:16:37 -0500
Subject: [PATCH 107/288] more docs
---
core/kernel/kernel-docs.factor | 5 ++++-
core/math/math-docs.factor | 23 +++++++++++++++++++++++
2 files changed, 27 insertions(+), 1 deletion(-)
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 53618d4628..6c71db9e61 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -341,6 +341,9 @@ HELP: set-callstack ( cs -- )
HELP: clear
{ $description "Clears the data stack." } ;
+HELP: build
+{ $description "The current build number. Factor increments this number whenever a new boot image is created." } ;
+
HELP: hashcode*
{ $values { "depth" integer } { "obj" object } { "code" fixnum } }
{ $contract "Outputs the hashcode of an object. The hashcode operation must satisfy the following properties:"
@@ -393,7 +396,7 @@ HELP: identity-tuple
HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "n" real } }
{ $contract
- "Compares two objects using an intrinsic partial order, for example, the natural order for real numbers and lexicographic order for strings."
+ "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
$nl
"The output value is one of the following:"
{ $list
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index 6ec1c5790f..5533c00090 100755
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -83,6 +83,29 @@ HELP: >=
{ $values { "x" real } { "y" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
+HELP: before?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: before=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+{ before? after? before=? after=? } related-words
+
+
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
{ $description
From d031087338d4d4be434c85695a1c0fc456eaafae Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 3 Apr 2008 23:35:57 -0500
Subject: [PATCH 108/288] better cpu report
---
extra/hardware-info/backend/backend.factor | 1 +
extra/hardware-info/hardware-info.factor | 4 +++-
extra/hardware-info/macosx/macosx.factor | 2 +-
3 files changed, 5 insertions(+), 2 deletions(-)
diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor
index 95a56da2d2..283fea6fcc 100644
--- a/extra/hardware-info/backend/backend.factor
+++ b/extra/hardware-info/backend/backend.factor
@@ -2,6 +2,7 @@ USING: system ;
IN: hardware-info.backend
HOOK: cpus os ( -- n )
+HOOK: cpu-mhz os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor
index 6d27cf5252..53aab483a1 100755
--- a/extra/hardware-info/hardware-info.factor
+++ b/extra/hardware-info/hardware-info.factor
@@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info
: write-unit ( x n str -- )
- [ 2^ /i number>string write bl ] [ write ] bi* ;
+ [ 2^ /f number>string write bl ] [ write ] bi* ;
: kb ( x -- ) 10 "kB" write-unit ;
: megs ( x -- ) 20 "MB" write-unit ;
: gigs ( x -- ) 30 "GB" write-unit ;
+: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
<< {
{ [ os windows? ] [ "hardware-info.windows" ] }
@@ -18,4 +19,5 @@ IN: hardware-info
: hardware-report. ( -- )
"CPUs: " write cpus number>string write nl
+ "CPU Speed: " write cpu-mhz ghz nl
"Physical RAM: " write physical-mem megs nl ;
diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor
index dac052a1de..91838d2a53 100644
--- a/extra/hardware-info/macosx/macosx.factor
+++ b/extra/hardware-info/macosx/macosx.factor
@@ -41,7 +41,7 @@ M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
-: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ;
+M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
From 3eb2bd784f8c633840afa5796cdd49637ea01714 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 3 Apr 2008 23:36:14 -0500
Subject: [PATCH 109/288] fix library path
---
extra/db/postgresql/ffi/ffi.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index 7925989bf5..7f428bb6b6 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -6,7 +6,8 @@ IN: db.postgresql.ffi
<< "postgresql" {
{ [ os winnt? ] [ "libpq.dll" ] }
- { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
+ { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] }
+ ! { [ os macosx? ] [ "libpq.dylib" ] }
{ [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
From ef4046cda9f3d8ed6c3b901151090962df79406a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 00:33:06 -0500
Subject: [PATCH 110/288] Converting code to use inheritance
---
core/alien/alien.factor | 6 -
core/alien/compiler/compiler.factor | 54 ++++---
core/bootstrap/compiler/compiler.factor | 2 -
core/classes/algebra/algebra-tests.factor | 12 +-
core/classes/tuple/tuple-docs.factor | 24 +---
core/classes/tuple/tuple-tests.factor | 24 ----
core/compiler/tests/tuples.factor | 8 --
core/continuations/continuations.factor | 24 ++--
core/debugger/debugger.factor | 14 +-
core/generic/standard/standard-docs.factor | 2 +-
core/heaps/heaps-tests.factor | 9 +-
core/heaps/heaps.factor | 26 ++--
core/inference/backend/backend.factor | 14 +-
core/inference/dataflow/dataflow.factor | 149 ++++++++++----------
core/inference/errors/errors.factor | 8 +-
core/inference/inference-docs.factor | 2 +-
core/inference/inference-tests.factor | 5 +
core/io/streams/string/string-docs.factor | 2 +-
core/listener/listener.factor | 4 +-
core/optimizer/backend/backend.factor | 2 +-
core/optimizer/def-use/def-use.factor | 2 +-
core/parser/parser.factor | 31 ++--
core/refs/refs-tests.factor | 22 +++
core/refs/refs.factor | 15 +-
core/source-files/source-files.factor | 2 +-
extra/help/crossref/crossref.factor | 2 +-
extra/ui/tools/interactor/interactor.factor | 7 +-
27 files changed, 226 insertions(+), 246 deletions(-)
create mode 100644 core/refs/refs-tests.factor
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 56be3e66a5..2f82e5db98 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -62,22 +62,16 @@ TUPLE: library path abi dll ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
-TUPLE: alien-callback return parameters abi quot xt ;
-
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
alien-callback-error ;
-TUPLE: alien-indirect return parameters abi ;
-
ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
alien-indirect-error ;
-TUPLE: alien-invoke library function return parameters abi ;
-
ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 1a9d5b5392..ea9476a08a 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -9,6 +9,14 @@ kernel.private threads continuations.private libc combinators
compiler.errors continuations layouts accessors ;
IN: alien.compiler
+TUPLE: #alien-node < node return parameters abi ;
+
+TUPLE: #alien-callback < #alien-node quot xt ;
+
+TUPLE: #alien-indirect < #alien-node ;
+
+TUPLE: #alien-invoke < #alien-node library function ;
+
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
@@ -229,32 +237,32 @@ M: no-such-symbol compiler-error-type
] if ;
: alien-invoke-dlsym ( node -- symbols dll )
- dup alien-invoke-function dup pick stdcall-mangle 2array
- swap alien-invoke-library library dup [ library-dll ] when
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
\ alien-invoke [
! Four literals
4 ensure-values
- \ alien-invoke empty-node
+ #alien-invoke construct-empty
! Compile-time parameters
- pop-parameters over set-alien-invoke-parameters
- pop-literal nip over set-alien-invoke-function
- pop-literal nip over set-alien-invoke-library
- pop-literal nip over set-alien-invoke-return
+ pop-parameters >>parameters
+ pop-literal nip >>function
+ pop-literal nip >>library
+ pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
! Set ABI
- dup alien-invoke-library
- library [ library-abi ] [ "cdecl" ] if*
- over set-alien-invoke-abi
+ dup library>>
+ library [ abi>> ] [ "cdecl" ] if*
+ >>abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
0 alien-invoke-stack
] "infer" set-word-prop
-M: alien-invoke generate-node
+M: #alien-invoke generate-node
dup alien-invoke-frame [
end-basic-block
%prepare-alien-invoke
@@ -273,11 +281,11 @@ M: alien-indirect-error summary
! Three literals and function pointer
4 ensure-values
4 reify-curries
- \ alien-indirect empty-node
+ #alien-indirect construct-empty
! Compile-time parameters
- pop-literal nip over set-alien-indirect-abi
- pop-parameters over set-alien-indirect-parameters
- pop-literal nip over set-alien-indirect-return
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
! Add node to IR
@@ -286,7 +294,7 @@ M: alien-indirect-error summary
1 alien-invoke-stack
] "infer" set-word-prop
-M: alien-indirect generate-node
+M: #alien-indirect generate-node
dup alien-invoke-frame [
! Flush registers
end-basic-block
@@ -320,12 +328,12 @@ M: alien-callback-error summary
\ alien-callback [
4 ensure-values
- \ alien-callback empty-node dup node,
- pop-literal nip over set-alien-callback-quot
- pop-literal nip over set-alien-callback-abi
- pop-parameters over set-alien-callback-parameters
- pop-literal nip over set-alien-callback-return
- gensym dup register-callback over set-alien-callback-xt
+ #alien-callback construct-empty dup node,
+ pop-literal nip >>quot
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
+ gensym dup register-callback >>xt
callback-bottom
] "infer" set-word-prop
@@ -398,5 +406,5 @@ TUPLE: callback-context ;
] with-stack-frame
] with-generator ;
-M: alien-callback generate-node
+M: #alien-callback generate-node
end-basic-block generate-callback iterate-next ;
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 6b467caa5a..618c62f332 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -37,8 +37,6 @@ nl
wrap probe
- delegate
-
underlying
find-pair-next namestack*
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index 0f468908a9..d61b62af3b 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -68,13 +68,13 @@ UNION: c a b ;
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
-TUPLE: delegate-clone ;
+TUPLE: tuple-example ;
-[ t ] [ \ null \ delegate-clone class< ] unit-test
-[ f ] [ \ object \ delegate-clone class< ] unit-test
-[ f ] [ \ object \ delegate-clone class< ] unit-test
-[ t ] [ \ delegate-clone \ tuple class< ] unit-test
-[ f ] [ \ tuple \ delegate-clone class< ] unit-test
+[ t ] [ \ null \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class< ] unit-test
+[ t ] [ \ tuple-example \ tuple class< ] unit-test
+[ f ] [ \ tuple \ tuple-example class< ] unit-test
TUPLE: a1 ;
TUPLE: b1 ;
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 87e035958b..0abfb8851f 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -121,6 +121,7 @@ $nl
"..."
"TUPLE: shape color ... ;"
}
+"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships."
{ $heading "Anti-pattern #2: subclassing for implementation sharing only" }
"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used."
$nl
@@ -237,15 +238,6 @@ $nl
ABOUT: "tuples"
-HELP: delegate
-{ $values { "obj" object } { "delegate" object } }
-{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." }
-{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ;
-
-HELP: set-delegate
-{ $values { "delegate" object } { "tuple" tuple } }
-{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ;
-
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
@@ -299,26 +291,16 @@ HELP: define-tuple-class
{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
-HELP: delegates
-{ $values { "obj" object } { "seq" sequence } }
-{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
-
-HELP: is?
-{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
-$nl
-"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
-
HELP: >tuple
{ $values { "seq" sequence } { "tuple" tuple } }
-{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots."
+{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots."
$nl
"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
HELP: tuple>array ( tuple -- array )
{ $values { "tuple" tuple } { "array" array } }
-{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
+{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index a8e9066f56..25d163d9cd 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -16,25 +16,6 @@ TUPLE: rect x y w h ;
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
-GENERIC: delegation-test
-M: object delegation-test drop 3 ;
-TUPLE: quux-tuple ;
-: <quux-tuple> quux-tuple construct-empty ;
-M: quux-tuple delegation-test drop 4 ;
-TUPLE: quuux-tuple ;
-: <quuux-tuple> { set-delegate } quuux-tuple construct ;
-
-[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
-
-GENERIC: delegation-test-2
-TUPLE: quux-tuple-2 ;
-: <quux-tuple-2> quux-tuple-2 construct-empty ;
-M: quux-tuple-2 delegation-test-2 drop 4 ;
-TUPLE: quuux-tuple-2 ;
-: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
-
-[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
-
! Make sure we handle tuple class redefinition
TUPLE: redefinition-test ;
@@ -102,11 +83,6 @@ C: <empty> empty
[ t ] [ <empty> hashcode fixnum? ] unit-test
-TUPLE: delegate-clone ;
-
-[ T{ delegate-clone T{ empty f } } ]
-[ T{ delegate-clone T{ empty f } } clone ] unit-test
-
! Compiler regression
[ t length ] [ object>> t eq? ] must-fail-with
diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor
index 5843575eeb..97cde6261c 100755
--- a/core/compiler/tests/tuples.factor
+++ b/core/compiler/tests/tuples.factor
@@ -22,11 +22,3 @@ TUPLE: color red green blue ;
[ T{ color f f f f } ]
[ [ color construct-empty ] compile-call ] unit-test
-
-[ T{ color "a" f "b" f } ] [
- "a" "b"
- [ { set-delegate set-color-green } color construct ]
- compile-call
-] unit-test
-
-[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index a2c296e8ce..cf67280cca 100755
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -141,14 +141,9 @@ GENERIC: dispose ( object -- )
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
-TUPLE: condition restarts continuation ;
+TUPLE: condition error restarts continuation ;
-: <condition> ( error restarts cc -- condition )
- {
- set-delegate
- set-condition-restarts
- set-condition-continuation
- } condition construct ;
+C: <condition> condition ( error restarts cc -- condition )
: throw-restarts ( error restarts -- restart )
[ <condition> throw ] callcc1 2nip ;
@@ -161,15 +156,14 @@ TUPLE: restart name obj continuation ;
C: <restart> restart
: restart ( restart -- )
- dup restart-obj swap restart-continuation continue-with ;
+ [ obj>> ] [ continuation>> ] bi continue-with ;
M: object compute-restarts drop { } ;
-M: tuple compute-restarts delegate compute-restarts ;
-
M: condition compute-restarts
- [ delegate compute-restarts ] keep
- [ condition-restarts ] keep
- condition-continuation
- [ <restart> ] curry { } assoc>map
- append ;
+ [ error>> compute-restarts ]
+ [
+ [ restarts>> ]
+ [ condition-continuation [ <restart> ] curry ] bi
+ { } assoc>map
+ ] bi append ;
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index 77e8f0ac05..071535a01e 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators
generic.math io.streams.duplex classes.builtin classes
compiler.units generic.standard vocabs threads threads.private
-init kernel.private libc io.encodings ;
+init kernel.private libc io.encodings accessors ;
IN: debugger
GENERIC: error. ( error -- )
@@ -202,6 +202,12 @@ M: no-method error.
M: no-math-method summary
drop "No suitable arithmetic method" ;
+M: no-next-method summary
+ drop "Executing call-next-method from least-specific method" ;
+
+M: inconsistent-next-method summary
+ drop "Executing call-next-method with inconsistent parameters" ;
+
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
@@ -223,9 +229,11 @@ M: slice-error error.
M: bounds-error summary drop "Sequence index out of bounds" ;
-M: condition error. delegate error. ;
+M: condition error. error>> error. ;
-M: condition error-help drop f ;
+M: condition summary error>> summary ;
+
+M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ;
diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor
index 09746d35f5..1d98dec87c 100644
--- a/core/generic/standard/standard-docs.factor
+++ b/core/generic/standard/standard-docs.factor
@@ -11,7 +11,7 @@ HELP: standard-combination
{ $class-description
"Performs standard method combination."
$nl
- "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. If no suitable method is defined on the class of the dispatch object, the generic word is called on the dispatch object's delegate. If the delegate is " { $link f } ", an exception is thrown."
+ "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. A " { $link no-method } " error is thrown if no suitable method is defined on the class."
}
{ $examples
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor
index 77560c7444..b22d8818c1 100755
--- a/core/heaps/heaps-tests.factor
+++ b/core/heaps/heaps-tests.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test
-heaps heaps.private math.parser random assocs sequences sorting ;
+heaps heaps.private math.parser random assocs sequences sorting
+accessors ;
IN: heaps.tests
[ <min-heap> heap-pop ] must-fail
@@ -47,7 +48,7 @@ IN: heaps.tests
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
- heap-data dup length swap [ entry-index ] map sequence= ;
+ data>> dup length swap [ entry-index ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
@@ -63,9 +64,9 @@ IN: heaps.tests
[
random-alist
<min-heap> [ heap-push-all ] keep
- dup heap-data clone swap
+ dup data>> clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
- heap-data
+ data>>
[ [ entry-key ] map ] bi@
[ natural-sort ] bi@ ;
diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor
index 34a4dc0d49..783d662e43 100755
--- a/core/heaps/heaps.factor
+++ b/core/heaps/heaps.factor
@@ -17,10 +17,10 @@ GENERIC: heap-size ( heap -- n )
<PRIVATE
-: heap-data delegate ; inline
+TUPLE: heap data ;
: <heap> ( class -- heap )
- >r V{ } clone r> construct-delegate ; inline
+ >r V{ } clone r> construct-boa ; inline
TUPLE: entry value key heap index ;
@@ -28,11 +28,11 @@ TUPLE: entry value key heap index ;
PRIVATE>
-TUPLE: min-heap ;
+TUPLE: min-heap < heap ;
: <min-heap> ( -- min-heap ) min-heap <heap> ;
-TUPLE: max-heap ;
+TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
@@ -40,10 +40,10 @@ INSTANCE: min-heap priority-queue
INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? )
- heap-data empty? ;
+ data>> empty? ;
M: priority-queue heap-size ( heap -- n )
- heap-data length ;
+ data>> length ;
<PRIVATE
@@ -54,7 +54,7 @@ M: priority-queue heap-size ( heap -- n )
: up ( n -- m ) 1- 2/ ; inline
: data-nth ( n heap -- entry )
- heap-data nth-unsafe ; inline
+ data>> nth-unsafe ; inline
: up-value ( n heap -- entry )
>r up r> data-nth ; inline
@@ -67,24 +67,24 @@ M: priority-queue heap-size ( heap -- n )
: data-set-nth ( entry n heap -- )
>r [ swap set-entry-index ] 2keep r>
- heap-data set-nth-unsafe ;
+ data>> set-nth-unsafe ;
: data-push ( entry heap -- n )
dup heap-size [
- swap 2dup heap-data ensure 2drop data-set-nth
+ swap 2dup data>> ensure 2drop data-set-nth
] keep ; inline
: data-pop ( heap -- entry )
- heap-data pop ; inline
+ data>> pop ; inline
: data-pop* ( heap -- )
- heap-data pop* ; inline
+ data>> pop* ; inline
: data-peek ( heap -- entry )
- heap-data peek ; inline
+ data>> peek ; inline
: data-first ( heap -- entry )
- heap-data first ; inline
+ data>> first ; inline
: data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 61412ccf9f..c0de217bd1 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors
-generic.standard.engines.tuple ;
+generic.standard.engines.tuple accessors ;
IN: inference.backend
: recursive-label ( word -- label/f )
@@ -32,18 +32,14 @@ M: word inline?
: recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] with contains? ;
-TUPLE: inference-error rstate type ;
+TUPLE: inference-error error type rstate ;
-M: inference-error compiler-error-type
- inference-error-type ;
+M: inference-error compiler-error-type type>> ;
: (inference-error) ( ... class type -- * )
>r construct-boa r>
- recursive-state get {
- set-delegate
- set-inference-error-type
- set-inference-error-rstate
- } \ inference-error construct throw ; inline
+ recursive-state get
+ \ inference-error construct-boa throw ; inline
: inference-error ( ... class -- * )
+error+ (inference-error) ; inline
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index 01c0a9c5f4..a4b7ad1888 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/core/inference/dataflow/dataflow.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
-inference.state ;
+inference.state accessors combinators ;
IN: inference.dataflow
! Computed value
@@ -39,12 +39,12 @@ M: node hashcode* drop node hashcode* ;
GENERIC: flatten-curry ( value -- )
M: curried flatten-curry
- dup curried-obj flatten-curry
- curried-quot flatten-curry ;
+ [ obj>> flatten-curry ]
+ [ quot>> flatten-curry ] bi ;
M: composed flatten-curry
- dup composed-quot1 flatten-curry
- composed-quot2 flatten-curry ;
+ [ quot1>> flatten-curry ]
+ [ quot2>> flatten-curry ] bi ;
M: object flatten-curry , ;
@@ -57,31 +57,27 @@ M: object flatten-curry , ;
meta-d get clone flatten-curries ;
: modify-values ( node quot -- )
- [ swap [ node-in-d swap call ] keep set-node-in-d ] 2keep
- [ swap [ node-in-r swap call ] keep set-node-in-r ] 2keep
- [ swap [ node-out-d swap call ] keep set-node-out-d ] 2keep
- swap [ node-out-r swap call ] keep set-node-out-r ; inline
+ {
+ [ change-in-d ]
+ [ change-in-r ]
+ [ change-out-d ]
+ [ change-out-r ]
+ } cleave drop ; inline
: node-shuffle ( node -- shuffle )
- dup node-in-d swap node-out-d <effect> ;
-
-: make-node ( slots class -- node )
- >r node construct r> construct-delegate ; inline
-
-: empty-node ( class -- node )
- { } swap make-node ; inline
+ [ in-d>> ] [ out-d>> ] bi <effect> ;
: param-node ( param class -- node )
- { set-node-param } swap make-node ; inline
+ construct-empty swap >>param ; inline
: in-node ( seq class -- node )
- { set-node-in-d } swap make-node ; inline
+ construct-empty swap >>in-d ; inline
: all-in-node ( class -- node )
flatten-meta-d swap in-node ; inline
: out-node ( seq class -- node )
- { set-node-out-d } swap make-node ; inline
+ construct-empty swap >>out-d ; inline
: all-out-node ( class -- node )
flatten-meta-d swap out-node ; inline
@@ -94,81 +90,81 @@ M: object flatten-curry , ;
: node-child node-children first ;
-TUPLE: #label word loop? ;
+TUPLE: #label < node word loop? ;
: #label ( word label -- node )
- \ #label param-node [ set-#label-word ] keep ;
+ \ #label param-node swap >>word ;
PREDICATE: #loop < #label #label-loop? ;
-TUPLE: #entry ;
+TUPLE: #entry < node ;
: #entry ( -- node ) \ #entry all-out-node ;
-TUPLE: #call ;
+TUPLE: #call < node ;
: #call ( word -- node ) \ #call param-node ;
-TUPLE: #call-label ;
+TUPLE: #call-label < node ;
: #call-label ( label -- node ) \ #call-label param-node ;
-TUPLE: #push ;
+TUPLE: #push < node ;
-: #push ( -- node ) \ #push empty-node ;
+: #push ( -- node ) \ #push construct-empty ;
-TUPLE: #shuffle ;
+TUPLE: #shuffle < node ;
-: #shuffle ( -- node ) \ #shuffle empty-node ;
+: #shuffle ( -- node ) \ #shuffle construct-empty ;
-TUPLE: #>r ;
+TUPLE: #>r < node ;
-: #>r ( -- node ) \ #>r empty-node ;
+: #>r ( -- node ) \ #>r construct-empty ;
-TUPLE: #r> ;
+TUPLE: #r> < node ;
-: #r> ( -- node ) \ #r> empty-node ;
+: #r> ( -- node ) \ #r> construct-empty ;
-TUPLE: #values ;
+TUPLE: #values < node ;
: #values ( -- node ) \ #values all-in-node ;
-TUPLE: #return ;
+TUPLE: #return < node ;
: #return ( label -- node )
- \ #return all-in-node [ set-node-param ] keep ;
+ \ #return all-in-node swap >>param ;
-TUPLE: #if ;
+TUPLE: #branch < node ;
+
+TUPLE: #if < #branch ;
: #if ( -- node ) peek-d 1array \ #if in-node ;
-TUPLE: #dispatch ;
+TUPLE: #dispatch < #branch ;
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
-TUPLE: #merge ;
+TUPLE: #merge < node ;
: #merge ( -- node ) \ #merge all-out-node ;
-TUPLE: #terminate ;
+TUPLE: #terminate < node ;
-: #terminate ( -- node ) \ #terminate empty-node ;
+: #terminate ( -- node ) \ #terminate construct-empty ;
-TUPLE: #declare ;
+TUPLE: #declare < node ;
: #declare ( classes -- node ) \ #declare param-node ;
-UNION: #branch #if #dispatch ;
-
: node-inputs ( d-count r-count node -- )
tuck
- >r r-tail flatten-curries r> set-node-in-r
- >r d-tail flatten-curries r> set-node-in-d ;
+ [ swap d-tail flatten-curries >>in-d drop ]
+ [ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
: node-outputs ( d-count r-count node -- )
tuck
- >r r-tail flatten-curries r> set-node-out-r
- >r d-tail flatten-curries r> set-node-out-d ;
+ [ swap d-tail flatten-curries >>out-d drop ]
+ [ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
: node, ( node -- )
dataflow-graph get [
@@ -178,17 +174,15 @@ UNION: #branch #if #dispatch ;
] if ;
: node-values ( node -- values )
- dup node-in-d
- over node-out-d
- pick node-in-r
- roll node-out-r 4array concat ;
+ { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
+ 4array concat ;
: last-node ( node -- last )
- dup node-successor [ last-node ] [ ] ?if ;
+ dup successor>> [ last-node ] [ ] ?if ;
: penultimate-node ( node -- penultimate )
- dup node-successor dup [
- dup node-successor
+ dup successor>> dup [
+ dup successor>>
[ nip penultimate-node ] [ drop ] if
] [
2drop f
@@ -202,7 +196,7 @@ UNION: #branch #if #dispatch ;
2dup 2slip rot [
2drop t
] [
- >r dup node-children swap node-successor suffix r>
+ >r [ children>> ] [ successor>> ] bi suffix r>
[ node-exists? ] curry contains?
] if
] [
@@ -213,13 +207,13 @@ GENERIC: calls-label* ( label node -- ? )
M: node calls-label* 2drop f ;
-M: #call-label calls-label* node-param eq? ;
+M: #call-label calls-label* param>> eq? ;
: calls-label? ( label node -- ? )
[ calls-label* ] with node-exists? ;
: recursive-label? ( node -- ? )
- dup node-param swap calls-label? ;
+ [ param>> ] keep calls-label? ;
SYMBOL: node-stack
@@ -227,7 +221,7 @@ SYMBOL: node-stack
: node> node-stack get pop ;
: node@ node-stack get peek ;
-: iterate-next ( -- node ) node@ node-successor ;
+: iterate-next ( -- node ) node@ successor>> ;
: iterate-nodes ( node quot -- )
over [
@@ -255,54 +249,55 @@ SYMBOL: node-stack
] iterate-nodes drop
] with-node-iterator ; inline
-: change-children ( node quot -- )
+: map-children ( node quot -- )
over [
- >r dup node-children dup r>
- [ map swap set-node-children ] curry
- [ 2drop ] if
+ over children>> [
+ [ map ] curry change-children drop
+ ] [
+ 2drop
+ ] if
] [
2drop
] if ; inline
: (transform-nodes) ( prev node quot -- )
dup >r call dup [
- dup rot set-node-successor
- dup node-successor r> (transform-nodes)
+ >>successor
+ successor>> dup successor>>
+ r> (transform-nodes)
] [
- r> drop f swap set-node-successor drop
+ r> 2drop f >>successor drop
] if ; inline
: transform-nodes ( node quot -- new-node )
over [
- [ call dup dup node-successor ] keep (transform-nodes)
+ [ call dup dup successor>> ] keep (transform-nodes)
] [ drop ] if ; inline
: node-literal? ( node value -- ? )
- dup value? >r swap node-literals key? r> or ;
+ dup value? >r swap literals>> key? r> or ;
: node-literal ( node value -- obj )
dup value?
- [ nip value-literal ] [ swap node-literals at ] if ;
+ [ nip value-literal ] [ swap literals>> at ] if ;
: node-interval ( node value -- interval )
- swap node-intervals at ;
+ swap intervals>> at ;
: node-class ( node value -- class )
- swap node-classes at object or ;
+ swap classes>> at object or ;
: node-input-classes ( node -- seq )
- dup node-in-d [ node-class ] with map ;
+ dup in-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq )
- dup node-in-d [ node-interval ] with map ;
+ dup in-d>> [ node-interval ] with map ;
: node-class-first ( node -- class )
- dup node-in-d first node-class ;
+ dup in-d>> first node-class ;
: active-children ( node -- seq )
- node-children
- [ last-node ] map
- [ #terminate? not ] subset ;
+ children>> [ last-node ] map [ #terminate? not ] subset ;
DEFER: #tail?
@@ -317,5 +312,5 @@ UNION: #tail
#! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces.
node-stack get [
- node-successor dup #tail? swap #terminate? not and
+ successor>> [ #tail? ] [ #terminate? not ] bi and
] all? ;
diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor
index 4d57ac5883..f565420cac 100644
--- a/core/inference/errors/errors.factor
+++ b/core/inference/errors/errors.factor
@@ -1,15 +1,15 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: inference.errors
USING: inference.backend inference.dataflow kernel generic
sequences prettyprint io words arrays inspector effects debugger
-assocs ;
+assocs accessors ;
M: inference-error error.
- dup inference-error-rstate
+ dup rstate>>
keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless
- swap delegate error. "Nesting: " write . ;
+ swap error>> error. "Nesting: " write . ;
M: inference-error error-help drop f ;
diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor
index 68e5920a3d..a837cfce5e 100755
--- a/core/inference/inference-docs.factor
+++ b/core/inference/inference-docs.factor
@@ -105,7 +105,7 @@ HELP: inference-error
{ $error-description
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
$nl
- "This error always delegates to one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
+ "The " { $snippet "error" } " slot contains one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
{ $list
{ $link no-effect }
{ $link literal-expected }
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index 84014512aa..f688f60e56 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -8,6 +8,9 @@ classes.predicate debugger threads.private io.streams.string
io.timeouts io.thread sequences.private ;
IN: inference.tests
+[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
+
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
@@ -542,3 +545,5 @@ ERROR: custom-error ;
: missing->r-check >r ;
[ [ missing->r-check ] infer ] must-fail
+
+{ 1 0 } [ [ ] map-children ] must-infer-as
diff --git a/core/io/streams/string/string-docs.factor b/core/io/streams/string/string-docs.factor
index 91ac244608..5b09baa56d 100644
--- a/core/io/streams/string/string-docs.factor
+++ b/core/io/streams/string/string-docs.factor
@@ -13,7 +13,7 @@ ABOUT: "io.streams.string"
HELP: <string-writer>
{ $values { "stream" "an output stream" } }
-{ $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ;
+{ $description "Creates an output stream that collects text into a string buffer. The contents of the buffer can be obtained by executing " { $link >string } "." } ;
HELP: with-string-writer
{ $values { "quot" quotation } { "str" string } }
diff --git a/core/listener/listener.factor b/core/listener/listener.factor
index bf262b77a2..ddb29bb768 100755
--- a/core/listener/listener.factor
+++ b/core/listener/listener.factor
@@ -3,7 +3,7 @@
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators
-continuations debugger definitions compiler.units ;
+continuations debugger definitions compiler.units accessors ;
IN: listener
SYMBOL: quit-flag
@@ -19,7 +19,7 @@ GENERIC: stream-read-quot ( stream -- quot/f )
: read-quot-step ( lines -- quot/f )
[ parse-lines-interactive ] [
- dup delegate unexpected-eof?
+ dup error>> unexpected-eof?
[ 2drop f ] [ rethrow ] if
] recover ;
diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor
index 1703bea5d4..e6b7533756 100755
--- a/core/optimizer/backend/backend.factor
+++ b/core/optimizer/backend/backend.factor
@@ -51,7 +51,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
DEFER: optimize-nodes
: optimize-children ( node -- )
- [ optimize-nodes ] change-children ;
+ [ optimize-nodes ] map-children ;
: optimize-node ( node -- node )
dup [
diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor
index df5c1e0aa4..54fca38ee2 100755
--- a/core/optimizer/def-use/def-use.factor
+++ b/core/optimizer/def-use/def-use.factor
@@ -100,7 +100,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
dup [
dup [ dead-literals get swap remove-all ] modify-values
dup kill-node* dup t eq? [
- drop dup [ kill-nodes ] change-children
+ drop dup [ kill-nodes ] map-children
] [
nip kill-node
] if
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 8fcbad4d3c..7db7e46b3a 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -157,23 +157,33 @@ name>char-hook global [
[ swap tail-slice (parse-string) ] "" make swap
] change-lexer-column ;
-TUPLE: parse-error file line col text ;
+TUPLE: parse-error file line column line-text error ;
: <parse-error> ( msg -- error )
- file get
- lexer get [ line>> ] [ column>> ] [ line-text>> ] tri
- parse-error construct-boa
- [ set-delegate ] keep ;
+ \ parse-error construct-empty
+ file get >>file
+ lexer get line>> >>line
+ lexer get column>> >>column
+ lexer get line-text>> >>line-text
+ swap >>error ;
: parse-dump ( error -- )
- dup parse-error-file file.
- dup parse-error-line number>string print
- dup parse-error-text dup string? [ print ] [ drop ] if
- parse-error-col 0 or CHAR: \s <string> write
+ {
+ [ file>> file. ]
+ [ line>> number>string print ]
+ [ line-text>> dup string? [ print ] [ drop ] if ]
+ [ column>> 0 or CHAR: \s <string> write ]
+ } cleave
"^" print ;
M: parse-error error.
- dup parse-dump delegate error. ;
+ [ parse-dump ] [ error>> error. ] bi ;
+
+M: parse-error summary
+ error>> summary ;
+
+M: parse-error compute-restarts
+ error>> compute-restarts ;
SYMBOL: use
SYMBOL: in
@@ -409,6 +419,7 @@ SYMBOL: bootstrap-syntax
SYMBOL: interactive-vocabs
{
+ "accessors"
"arrays"
"assocs"
"combinators"
diff --git a/core/refs/refs-tests.factor b/core/refs/refs-tests.factor
new file mode 100644
index 0000000000..1d921854e9
--- /dev/null
+++ b/core/refs/refs-tests.factor
@@ -0,0 +1,22 @@
+USING: refs tools.test kernel ;
+
+[ 3 ] [
+ H{ { "a" 3 } } "a" <value-ref> get-ref
+] unit-test
+
+[ 4 ] [
+ 4 H{ { "a" 3 } } clone "a" <value-ref>
+ [ set-ref ] keep
+ get-ref
+] unit-test
+
+[ "a" ] [
+ H{ { "a" 3 } } "a" <key-ref> get-ref
+] unit-test
+
+[ H{ { "b" 3 } } ] [
+ "b" H{ { "a" 3 } } clone [
+ "a" <key-ref>
+ set-ref
+ ] keep
+] unit-test
diff --git a/core/refs/refs.factor b/core/refs/refs.factor
index c52c5daf9e..81a2338b8f 100644
--- a/core/refs/refs.factor
+++ b/core/refs/refs.factor
@@ -5,21 +5,18 @@ IN: refs
TUPLE: ref assoc key ;
-: <ref> ( assoc key class -- tuple )
- >r ref construct-boa r> construct-delegate ; inline
-
-: >ref< ( ref -- key assoc ) [ key>> ] [ assoc>> ] bi ;
+: >ref< [ key>> ] [ assoc>> ] bi ; inline
: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
GENERIC: set-ref ( obj ref -- )
-TUPLE: key-ref ;
-: <key-ref> ( assoc key -- ref ) key-ref <ref> ;
-M: key-ref get-ref ref-key ;
+TUPLE: key-ref < ref ;
+C: <key-ref> key-ref ( assoc key -- ref )
+M: key-ref get-ref key>> ;
M: key-ref set-ref >ref< rename-at ;
-TUPLE: value-ref ;
-: <value-ref> ( assoc key -- ref ) value-ref <ref> ;
+TUPLE: value-ref < ref ;
+C: <value-ref> value-ref ( assoc key -- ref )
M: value-ref get-ref >ref< at ;
M: value-ref set-ref >ref< set-at ;
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 5df5f503f9..b385fbf369 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.crc32 vocabs hashtables
-graphs compiler.units io.encodings.utf8 ;
+graphs compiler.units io.encodings.utf8 accessors ;
IN: source-files
SYMBOL: source-files
diff --git a/extra/help/crossref/crossref.factor b/extra/help/crossref/crossref.factor
index e347fde051..0b17461a99 100644
--- a/extra/help/crossref/crossref.factor
+++ b/extra/help/crossref/crossref.factor
@@ -14,7 +14,7 @@ M: link uses
collect-elements [ \ f or ] map ;
: help-path ( topic -- seq )
- [ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ;
+ [ article-parent ] follow 1 tail ;
: set-article-parents ( parent article -- )
article-children [ set-article-parent ] with each ;
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 06fc3c87a0..c760867d71 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -6,7 +6,8 @@ math.vectors models namespaces parser prettyprint quotations
sequences sequences.lib strings threads listener
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes calendar concurrency.flags ui.tools.workspace ;
+definitions boxes calendar concurrency.flags ui.tools.workspace
+accessors ;
IN: ui.tools.interactor
TUPLE: interactor history output flag thread help ;
@@ -123,12 +124,12 @@ M: interactor stream-read-partial
stream-read ;
: go-to-error ( interactor error -- )
- dup parse-error-line 1- swap parse-error-col 2array
+ [ line>> 1- ] [ column>> ] bi 2array
over set-caret
mark>caret ;
: handle-parse-error ( interactor error -- )
- dup parse-error? [ 2dup go-to-error delegate ] when
+ dup parse-error? [ 2dup go-to-error error>> ] when
swap find-workspace debugger-popup ;
: try-parse ( lines interactor -- quot/error/f )
From 82fc8f18db9b2b8c9e2f6eee2c2847790dbaf672 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 03:46:30 -0500
Subject: [PATCH 111/288] Converting core to use inheritance
---
core/alien/arrays/arrays.factor | 2 +-
core/alien/c-types/c-types.factor | 245 ++++++++++--------
core/alien/compiler/compiler.factor | 34 ++-
core/classes/tuple/tuple-tests.factor | 4 +-
core/compiler/tests/templates-early.factor | 8 +-
core/compiler/tests/templates.factor | 44 ++++
core/cpu/architecture/architecture.factor | 2 +-
core/cpu/ppc/architecture/architecture.factor | 12 +-
core/cpu/x86/32/32.factor | 2 +-
core/cpu/x86/64/64.factor | 8 +-
core/cpu/x86/architecture/architecture.factor | 8 +-
core/generator/registers/registers.factor | 55 ++--
core/kernel/kernel-docs.factor | 4 +-
core/memory/memory-tests.factor | 3 +-
core/optimizer/optimizer-tests.factor | 6 -
core/parser/parser-tests.factor | 14 +-
core/syntax/syntax-docs.factor | 4 +-
core/vocabs/loader/loader-tests.factor | 4 +-
core/words/words-tests.factor | 4 +-
19 files changed, 269 insertions(+), 194 deletions(-)
diff --git a/core/alien/arrays/arrays.factor b/core/alien/arrays/arrays.factor
index c9b9d838dd..402b01550b 100644
--- a/core/alien/arrays/arrays.factor
+++ b/core/alien/arrays/arrays.factor
@@ -25,7 +25,7 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ;
-M: value-type c-type-reg-class drop T{ int-regs } ;
+M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-prep drop f ;
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index ca1a89b4ae..508fcd61a6 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -4,7 +4,8 @@ USING: bit-arrays byte-arrays float-arrays arrays
generator.registers 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 ;
+layouts system compiler.units io.files io.encodings.binary
+accessors combinators ;
IN: alien.c-types
DEFER: <int>
@@ -17,8 +18,12 @@ boxer prep unboxer
getter setter
reg-class size align stack-align? ;
+: construct-c-type ( class -- type )
+ construct-empty
+ int-regs >>reg-class ;
+
: <c-type> ( -- type )
- T{ int-regs } { set-c-type-reg-class } \ c-type construct ;
+ \ c-type construct-c-type ;
SYMBOL: c-types
@@ -181,10 +186,10 @@ DEFER: >c-ushort-array
: define-c-type ( type name vocab -- )
>r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
-TUPLE: long-long-type ;
+TUPLE: long-long-type < c-type ;
-: <long-long-type> ( type -- type )
- long-long-type construct-delegate ;
+: <long-long-type> ( -- type )
+ long-long-type construct-c-type ;
M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ;
@@ -235,22 +240,15 @@ M: long-long-type box-return ( type -- )
: define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot define ;
-: <primitive-type> ( getter setter width boxer unboxer -- type )
- <c-type>
- [ set-c-type-unboxer ] keep
- [ set-c-type-boxer ] keep
- [ set-c-type-size ] 2keep
- [ set-c-type-align ] keep
- [ set-c-type-setter ] keep
- [ set-c-type-getter ] keep ;
-
: define-primitive-type ( type name -- )
"alien.c-types"
- [ define-c-type ] 2keep
- [ define-deref ] 2keep
- [ define-to-array ] 2keep
- [ define-from-array ] 2keep
- define-out ;
+ {
+ [ define-c-type ]
+ [ define-deref ]
+ [ define-to-array ]
+ [ define-from-array ]
+ [ define-out ]
+ } 2cleave ;
: expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around
@@ -264,130 +262,157 @@ M: long-long-type box-return ( type -- )
binary file-contents dup malloc-byte-array swap length ;
[
- [ alien-cell ]
- [ set-alien-cell ]
- bootstrap-cell
- "box_alien"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell ] >>getter
+ [ set-alien-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_alien" >>boxer
+ "alien_offset" >>unboxer
"void*" define-primitive-type
- [ alien-signed-8 ]
- [ set-alien-signed-8 ]
- 8
- "box_signed_8"
- "to_signed_8" <primitive-type> <long-long-type>
+ <long-long-type>
+ [ alien-signed-8 ] >>getter
+ [ set-alien-signed-8 ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_signed_8" >>boxer
+ "to_signed_8" >>unboxer
"longlong" define-primitive-type
- [ alien-unsigned-8 ]
- [ set-alien-unsigned-8 ]
- 8
- "box_unsigned_8"
- "to_unsigned_8" <primitive-type> <long-long-type>
+ <long-long-type>
+ [ alien-unsigned-8 ] >>getter
+ [ set-alien-unsigned-8 ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_unsigned_8" >>boxer
+ "to_unsigned_8" >>unboxer
"ulonglong" define-primitive-type
- [ alien-signed-cell ]
- [ set-alien-signed-cell ]
- bootstrap-cell
- "box_signed_cell"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-cell ] >>getter
+ [ set-alien-signed-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_signed_cell" >>boxer
+ "to_fixnum" >>unboxer
"long" define-primitive-type
- [ alien-unsigned-cell ]
- [ set-alien-unsigned-cell ]
- bootstrap-cell
- "box_unsigned_cell"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-cell ] >>getter
+ [ set-alien-unsigned-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_unsigned_cell" >>boxer
+ "to_cell" >>unboxer
"ulong" define-primitive-type
- [ alien-signed-4 ]
- [ set-alien-signed-4 ]
- 4
- "box_signed_4"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-4 ] >>getter
+ [ set-alien-signed-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_signed_4" >>boxer
+ "to_fixnum" >>unboxer
"int" define-primitive-type
- [ alien-unsigned-4 ]
- [ set-alien-unsigned-4 ]
- 4
- "box_unsigned_4"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-4 ] >>getter
+ [ set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_unsigned_4" >>boxer
+ "to_cell" >>unboxer
"uint" define-primitive-type
- [ alien-signed-2 ]
- [ set-alien-signed-2 ]
- 2
- "box_signed_2"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-2 ] >>getter
+ [ set-alien-signed-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ "box_signed_2" >>boxer
+ "to_fixnum" >>unboxer
"short" define-primitive-type
- [ alien-unsigned-2 ]
- [ set-alien-unsigned-2 ]
- 2
- "box_unsigned_2"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-2 ] >>getter
+ [ set-alien-unsigned-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ "box_unsigned_2" >>boxer
+ "to_cell" >>unboxer
"ushort" define-primitive-type
- [ alien-signed-1 ]
- [ set-alien-signed-1 ]
- 1
- "box_signed_1"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-1 ] >>getter
+ [ set-alien-signed-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ "box_signed_1" >>boxer
+ "to_fixnum" >>unboxer
"char" define-primitive-type
- [ alien-unsigned-1 ]
- [ set-alien-unsigned-1 ]
- 1
- "box_unsigned_1"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-1 ] >>getter
+ [ set-alien-unsigned-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ "box_unsigned_1" >>boxer
+ "to_cell" >>unboxer
"uchar" define-primitive-type
- [ alien-unsigned-4 zero? not ]
- [ 1 0 ? set-alien-unsigned-4 ]
- 4
- "box_boolean"
- "to_boolean" <primitive-type>
+ <c-type>
+ [ alien-unsigned-4 zero? not ] >>getter
+ [ 1 0 ? set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
"bool" define-primitive-type
- [ alien-float ]
- [ >r >r >float r> r> set-alien-float ]
- 4
- "box_float"
- "to_float" <primitive-type>
+ <c-type>
+ [ alien-float ] >>getter
+ [ >r >r >float r> r> set-alien-float ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_float" >>boxer
+ "to_float" >>unboxer
+ single-float-regs >>reg-class
+ [ >float ] >>prep
"float" define-primitive-type
- T{ float-regs f 4 } "float" c-type set-c-type-reg-class
- [ >float ] "float" c-type set-c-type-prep
-
- [ alien-double ]
- [ >r >r >float r> r> set-alien-double ]
- 8
- "box_double"
- "to_double" <primitive-type>
+ <c-type>
+ [ alien-double ] >>getter
+ [ >r >r >float r> r> set-alien-double ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_double" >>boxer
+ "to_double" >>unboxer
+ double-float-regs >>reg-class
+ [ >float ] >>prep
"double" define-primitive-type
- T{ float-regs f 8 } "double" c-type set-c-type-reg-class
- [ >float ] "double" c-type set-c-type-prep
-
- [ alien-cell alien>char-string ]
- [ set-alien-cell ]
- bootstrap-cell
- "box_char_string"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell alien>char-string ] >>getter
+ [ set-alien-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_char_string" >>boxer
+ "alien_offset" >>unboxer
+ [ string>char-alien ] >>prep
"char*" define-primitive-type
"char*" "uchar*" typedef
- [ string>char-alien ] "char*" c-type set-c-type-prep
-
- [ alien-cell alien>u16-string ]
- [ set-alien-cell ]
- 4
- "box_u16_string"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell alien>u16-string ] >>getter
+ [ set-alien-cell ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_u16_string" >>boxer
+ "alien_offset" >>unboxer
+ [ string>u16-alien ] >>prep
"ushort*" define-primitive-type
- [ string>u16-alien ] "ushort*" c-type set-c-type-prep
-
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
-
] with-compilation-unit
diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index ea9476a08a..0f74f52d60 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -70,29 +70,36 @@ GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
-M: float-regs reg-size float-regs-size ;
+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 -- )
-: (inc-reg-class)
- dup class inc
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-M: int-regs inc-reg-class
- (inc-reg-class) ;
-
M: float-regs inc-reg-class
- dup (inc-reg-class)
+ dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? )
- dup class get swap param-regs length >= ;
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class )
- reg-size stack-params dup get -rot +@ T{ stack-params } ;
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
: fastcall-param ( reg-class -- n reg-class )
- [ dup class get swap inc-reg-class ] keep ;
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full?
@@ -323,7 +330,7 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
- alien-callback-xt [ word-xt drop <alien> ] curry
+ xt>> [ word-xt drop <alien> ] curry
recursive-state get infer-quot ;
\ alien-callback [
@@ -373,8 +380,7 @@ TUPLE: callback-context ;
: wrap-callback-quot ( node -- quot )
[
- dup alien-callback-quot
- swap prepare-callback-return append ,
+ [ quot>> ] [ prepare-callback-return ] bi append ,
[ callback-context construct-empty do-callback ] %
] [ ] make ;
@@ -395,7 +401,7 @@ TUPLE: callback-context ;
callback-unwind %unwind ;
: generate-callback ( node -- )
- dup alien-callback-xt dup [
+ dup xt>> dup [
init-templates
%save-word-xt
%prologue-later
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 25d163d9cd..729997d3b2 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -218,7 +218,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ [ no-tuple-class? ] is? ] must-fail-with
+] [ error>> no-tuple-class? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
@@ -488,7 +488,7 @@ USE: vocabs
] with-compilation-unit
] unit-test
-[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with
+[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor
index bdbc985078..d04f182e04 100755
--- a/core/compiler/tests/templates-early.factor
+++ b/core/compiler/tests/templates-early.factor
@@ -4,7 +4,7 @@ USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units ;
-: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
+: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
[
[ ] [ init-templates ] unit-test
@@ -15,18 +15,18 @@ words kernel math effects definitions compiler.units ;
[ ] [ compute-free-vregs ] unit-test
- [ f ] [ 0 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
+ [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
[ f ] [
[
copy-templates
1 <int-vreg> phantom-push
compute-free-vregs
- 1 <int-vreg> T{ int-regs } free-vregs member?
+ 1 <int-vreg> int-regs free-vregs member?
] with-scope
] unit-test
- [ t ] [ 1 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
+ [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
] with-scope
[
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index 565c045e2a..845189ce2c 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -202,3 +202,47 @@ TUPLE: my-tuple ;
] [ 2drop no-case ] if
] compile-call
] unit-test
+
+: float-spill-bug
+ {
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ } cleave ;
+
+[ t ] [ \ float-spill-bug compiled? ] unit-test
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 4670cf86d2..7ea8849d30 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -6,7 +6,7 @@ byte-arrays bit-arrays float-arrays combinators words ;
IN: cpu.architecture
! A pseudo-register class for parameters spilled on the stack
-TUPLE: stack-params ;
+SINGLETON: stack-params
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index a1a4bd3809..bd5273efcb 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -146,11 +146,19 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
-: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
+GENERIC: STF ( src dst reg-class -- )
+
+M: single-float-regs STF drop STFS ;
+
+M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
-: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
+GENERIC: LF ( src dst reg-class -- )
+
+M: single-float-regs LF drop LFS ;
+
+M: double-float-regs LF drop LFD ;
M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index 4d447b38fc..699670aecd 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -155,7 +155,7 @@ M: x86.32 %box ( n reg-class func -- )
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
#! boxing a parameter being passed to a callback from C.
[
- T{ int-regs } box@
+ int-regs box@
EDX over stack@ MOV
EAX swap cell - stack@ MOV
] when*
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index d3ccffe00e..811387675a 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -65,7 +65,7 @@ M: x86.64 %unbox ( n reg-class func -- )
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: x86.64 %unbox-long-long ( n func -- )
- T{ int-regs } swap %unbox ;
+ int-regs swap %unbox ;
M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI.
@@ -103,7 +103,7 @@ M: x86.64 %box ( n reg-class func -- )
f %alien-invoke ;
M: x86.64 %box-long-long ( n func -- )
- T{ int-regs } swap %box ;
+ int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
@@ -170,7 +170,7 @@ USE: cpu.x86.intrinsics
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
-T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
+stack-params "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
@@ -192,7 +192,7 @@ M: struct-type flatten-value-type ( type -- seq )
] [
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
- T{ int-regs } swap member?
+ int-regs swap member?
"void*" "double" ? c-type ,
] each
] if ;
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 6c9a4dc05f..25bb3c6e07 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
@@ -22,7 +22,11 @@ M: rs-loc v>operand rs-loc-n rs-reg reg-stack ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;
-: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ;
+GENERIC: MOVSS/D ( dst src reg-class -- )
+
+M: single-float-regs MOVSS/D drop MOVSS ;
+
+M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index aac1b2cdc6..a7a2c94adf 100755
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -3,7 +3,8 @@
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 bit-arrays float-arrays ;
+words effects alien byte-arrays bit-arrays float-arrays
+accessors ;
IN: generator.registers
SYMBOL: +input+
@@ -13,9 +14,11 @@ SYMBOL: +clobber+
SYMBOL: known-tag
! Register classes
-TUPLE: int-regs ;
-
-TUPLE: float-regs size ;
+SINGLETON: int-regs
+SINGLETON: single-float-regs
+SINGLETON: double-float-regs
+UNION: float-regs single-float-regs double-float-regs ;
+UNION: reg-class int-regs float-regs ;
<PRIVATE
@@ -48,13 +51,13 @@ M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
! A scratch register for computations
-TUPLE: vreg n ;
+TUPLE: vreg n reg-class ;
-: <vreg> ( n reg-class -- vreg )
- { set-vreg-n set-delegate } vreg construct ;
+C: <vreg> vreg ( n reg-class -- vreg )
-M: vreg v>operand dup vreg-n swap vregs nth ;
+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
@@ -62,9 +65,9 @@ M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
-TUPLE: temp-reg ;
+TUPLE: temp-reg reg-class>> ;
-: temp-reg T{ temp-reg T{ int-regs } } ;
+: temp-reg T{ temp-reg f int-regs } ;
M: temp-reg move-spec drop f ;
@@ -73,7 +76,7 @@ INSTANCE: temp-reg value
! A data stack location.
TUPLE: ds-loc n class ;
-: <ds-loc> { set-ds-loc-n } ds-loc construct ;
+: <ds-loc> f ds-loc construct-boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
@@ -84,8 +87,7 @@ M: ds-loc live-loc?
! A retain stack location.
TUPLE: rs-loc n class ;
-: <rs-loc> { set-rs-loc-n } rs-loc construct ;
-
+: <rs-loc> f rs-loc construct-boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
@@ -126,7 +128,7 @@ INSTANCE: cached value
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
- { set-tagged-vreg } tagged construct ;
+ f tagged construct-boa ;
M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ;
@@ -340,8 +342,7 @@ SYMBOL: fresh-objects
! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class )
- float eq?
- T{ float-regs f 8 } T{ int-regs } ? ;
+ float eq? double-float-regs int-regs ? ;
: free-vregs ( reg-class -- seq )
#! Free vregs in a given register class
@@ -393,7 +394,7 @@ M: value (lazy-load)
: compute-free-vregs ( -- )
#! Create a new hashtable for thee free-vregs variable.
live-vregs
- { T{ int-regs } T{ float-regs f 8 } }
+ { int-regs double-float-regs }
[ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set
drop ;
@@ -442,7 +443,7 @@ M: loc lazy-store
: fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all
#! shuffle inputs at once.
- T{ int-regs } free-vregs [ length ] bi@ <= ;
+ int-regs free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
@@ -483,8 +484,8 @@ M: loc lazy-store
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
- T{ float-regs f 8 } free-vregs length <=
- >r T{ int-regs } free-vregs length <= r> and ;
+ double-float-regs free-vregs length <=
+ >r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' )
[ length f pad-left ] keep
@@ -534,7 +535,7 @@ M: loc lazy-store
: count-input-vregs ( phantom spec -- )
phantom&spec [
- >r dup cached? [ cached-vreg ] when r> allocation
+ >r dup cached? [ cached-vreg ] when r> first allocation
] 2map count-vregs ;
: count-scratch-regs ( spec -- )
@@ -542,13 +543,13 @@ M: loc lazy-store
: guess-vregs ( dinput rinput scratch -- int# float# )
H{
- { T{ int-regs } 0 }
- { T{ float-regs 8 } 0 }
+ { int-regs 0 }
+ { double-float-regs 0 }
} clone [
count-scratch-regs
phantom-r get swap count-input-vregs
phantom-d get swap count-input-vregs
- T{ int-regs } get T{ float-regs 8 } get
+ int-regs get double-float-regs get
] bind ;
: alloc-scratch ( -- )
@@ -581,12 +582,6 @@ M: loc lazy-store
2drop t
] if ;
-: class-tags ( class -- tag/f )
- class-types [
- dup num-tags get >=
- [ drop object tag-number ] when
- ] map prune ;
-
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 328a647339..8c4c0e61c8 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -217,9 +217,7 @@ $nl
{ $example "\\ f class ." "word" }
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
{ $example "t \\ t eq? ." "t" }
-"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "."
-$nl
-"A tuple cannot delegate to " { $link f } " at all, since a delegate of " { $link f } " actually denotes that no delegate is set. See " { $link set-delegate } "." ;
+"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor
index 8808b30c59..0c46e307df 100755
--- a/core/memory/memory-tests.factor
+++ b/core/memory/memory-tests.factor
@@ -1,5 +1,6 @@
USING: generic kernel kernel.private math memory prettyprint
-sequences tools.test words namespaces layouts classes ;
+sequences tools.test words namespaces layouts classes
+classes.builtin ;
IN: memory.tests
TUPLE: testing x y z ;
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index aa081e8e2c..6c6adfa3e6 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -140,12 +140,6 @@ GENERIC: void-generic ( obj -- * )
[ breakage ] must-fail
! regression
-: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
-: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
-: test-2 ( -- ) 5 test-1 ;
-
-[ f ] [ f test-2 ] unit-test
-
: branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index ab9648c527..ab193e1c02 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
sorting classes.tuple compiler.units debugger vocabs
-vocabs.loader ;
+vocabs.loader accessors ;
IN: parser.tests
[
@@ -297,12 +297,12 @@ IN: parser.tests
[
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[
"IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
@@ -312,7 +312,7 @@ IN: parser.tests
[
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ;"
@@ -322,7 +322,7 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ no-word-error? ] is? ] must-fail-with
+ ] [ error>> error>> no-word-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
@@ -332,12 +332,12 @@ IN: parser.tests
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ no-word-error? ] is? ] must-fail-with
+ ] [ error>> error>> no-word-error? ] must-fail-with
[
"IN: parser.tests : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index 39a4d266e9..17dbd9f17b 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -333,8 +333,8 @@ HELP: C{
{ $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ;
HELP: T{
-{ $syntax "T{ class delegate slots... }" }
-{ $values { "class" "a tuple class word" } { "delegate" "a delegate" } { "slots" "list of objects" } }
+{ $syntax "T{ class slots... }" }
+{ $values { "class" "a tuple class word" } { "slots" "list of objects" } }
{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "."
$nl
"The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ;
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 4b978932bc..1191594fe5 100755
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -3,7 +3,7 @@ IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
-debugger compiler.units tools.vocabs ;
+debugger compiler.units tools.vocabs accessors ;
! This vocab should not exist, but just in case...
[ ] [
@@ -68,7 +68,7 @@ IN: vocabs.loader.tests
<string-reader>
"resource:core/vocabs/loader/test/a/a.factor"
parse-stream
-] [ [ no-word-error? ] is? ] must-fail-with
+] [ error>> error>> no-word-error? ] must-fail-with
0 "count-me" set-global
diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor
index cef6b19943..694e54cf96 100755
--- a/core/words/words-tests.factor
+++ b/core/words/words-tests.factor
@@ -1,7 +1,7 @@
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
vocabs continuations classes.tuple compiler.units
-io.streams.string ;
+io.streams.string accessors ;
IN: words.tests
[ 4 ] [
@@ -147,7 +147,7 @@ SYMBOL: quot-uses-b
] when*
[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
-[ [ undefined? ] is? ] must-fail-with
+[ error>> undefined? ] must-fail-with
[ ] [
"IN: words.tests GENERIC: symbol-generic" eval
From f669d2c9f18d11b6b8f7ffddd492220d5a405be4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 04:12:25 -0500
Subject: [PATCH 112/288] Fixing editors for parse-error/condition changes
---
extra/editors/editors.factor | 39 ++++++++++++++++++++++++------------
1 file changed, 26 insertions(+), 13 deletions(-)
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index e871d5f808..16de8f5eee 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -3,7 +3,7 @@
USING: parser kernel namespaces sequences definitions io.files
inspector continuations tools.crossref tools.vocabs
io prettyprint source-files assocs vocabs vocabs.loader
-io.backend splitting classes.tuple ;
+io.backend splitting accessors ;
IN: editors
TUPLE: no-edit-hook ;
@@ -18,7 +18,7 @@ SYMBOL: edit-hook
: editor-restarts ( -- alist )
available-editors
- [ "Load " over append swap ] { } map>assoc ;
+ [ [ "Load " prepend ] keep ] { } map>assoc ;
: no-edit-hook ( -- )
\ no-edit-hook construct-empty
@@ -26,7 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
- >r (normalize-path) "\\\\?\\" ?head drop r>
+ >r (normalize-path) r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
@@ -35,18 +35,31 @@ SYMBOL: edit-hook
: edit-vocab ( name -- )
vocab-source-path 1 edit-location ;
+GENERIC: find-parse-error ( error -- error' )
+
+M: parse-error find-parse-error
+ dup error>> find-parse-error [ ] [ ] ?if ;
+
+M: condition find-parse-error
+ error>> find-parse-error ;
+
+M: object find-parse-error
+ drop f ;
+
: :edit ( -- )
- error get delegates [ parse-error? ] find-last nip [
- dup parse-error-file source-file-path
- swap parse-error-line edit-location
+ error get find-parse-error [
+ [ file>> path>> ] [ line>> ] bi edit-location
] when* ;
: fix ( word -- )
- "Fixing " write dup pprint " and all usages..." print nl
- dup usage swap prefix [
- "Editing " write dup .
- "RETURN moves on to the next usage, C+d stops." print
- flush
- edit
- readln
+ [ "Fixing " write pprint " and all usages..." print nl ]
+ [ [ usage ] keep prefix ] bi
+ [
+ [ "Editing " write . ]
+ [
+ "RETURN moves on to the next usage, C+d stops." print
+ flush
+ edit
+ readln
+ ] bi
] all? drop ;
From fe8448b4e89703982e6d05fe84beb763072b68d0 Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Fri, 4 Apr 2008 11:20:10 +0200
Subject: [PATCH 113/288] Use more combinators
---
extra/math/primes/primes.factor | 2 +-
extra/project-euler/169/169.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor
index 685124e4e9..eeb1b66a89 100644
--- a/extra/math/primes/primes.factor
+++ b/extra/math/primes/primes.factor
@@ -45,7 +45,7 @@ PRIVATE>
: primes-between ( low high -- seq )
primes-upto
- >r 1- next-prime r>
+ [ 1- next-prime ] dip
[ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor
index 61645bf50b..35fb2c2c1e 100644
--- a/extra/project-euler/169/169.factor
+++ b/extra/project-euler/169/169.factor
@@ -30,7 +30,7 @@ MEMO: fn ( n -- x )
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
- { [ t ] [ 2/ [ fn ] keep 1- fn + ] }
+ { [ t ] [ 2/ [ fn ] [ 1- fn + ] bi ] }
} cond ;
: euler169 ( -- result )
From b040d4d033442061d640c2866e90d53c55315a5f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 04:33:35 -0500
Subject: [PATCH 114/288] Convert prettyprinter to inheritance
---
core/classes/tuple/tuple-docs.factor | 2 +-
core/prettyprint/prettyprint-docs.factor | 6 +-
.../prettyprint/sections/sections-docs.factor | 14 +--
core/prettyprint/sections/sections.factor | 118 +++++++++---------
4 files changed, 70 insertions(+), 70 deletions(-)
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 0abfb8851f..3e1f85c936 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -269,7 +269,7 @@ $low-level-note ;
HELP: tuple-slots
{ $values { "tuple" tuple } { "seq" sequence } }
-{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ;
+{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ;
{ tuple-slots tuple>array } related-words
diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor
index 7ea0f5c412..2b294115be 100755
--- a/core/prettyprint/prettyprint-docs.factor
+++ b/core/prettyprint/prettyprint-docs.factor
@@ -48,7 +48,7 @@ ARTICLE: "prettyprint-limitations" "Prettyprinter limitations"
"On a final note, the " { $link short. } " and " { $link pprint-short } " words restrict the length and nesting of printed sequences, their output will very likely not be valid syntax. They are only intended for interactive use." ;
ARTICLE: "prettyprint-section-protocol" "Prettyprinter section protocol"
-"Prettyprinter sections must delegate to an instance of " { $link section } ", and they must also obey a protocol."
+"Prettyprinter sections must subclass " { $link section } ", and they must also obey a protocol."
$nl
"Layout queries:"
{ $subsection section-fits? }
@@ -60,8 +60,8 @@ $nl
{ $subsection short-section }
{ $subsection long-section }
"Utilities to use when implementing sections:"
-{ $subsection <section> }
-{ $subsection delegate>block }
+{ $subsection construct-section }
+{ $subsection construct-block }
{ $subsection add-section } ;
ARTICLE: "prettyprint-sections" "Prettyprinter sections"
diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor
index 9833a7e50a..e704df2085 100755
--- a/core/prettyprint/sections/sections-docs.factor
+++ b/core/prettyprint/sections/sections-docs.factor
@@ -67,7 +67,7 @@ HELP: short-section?
{ $contract "Tests if a section should be output as a " { $link short-section } ". The default implementation calls " { $link section-fits? } " but this behavior can be cutomized." } ;
HELP: section
-{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various classes which delegate to this class:"
+{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various subclasses of this class:"
{ $list
{ $link text }
{ $link line-break }
@@ -78,12 +78,12 @@ HELP: section
}
"Instances of this class have the following slots:"
{ $list
- { { $link section-start } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-end } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-start-group? } " - see " { $link start-group } }
- { { $link section-end } " - see " { $link end-group } }
- { { $link section-style } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
- { { $link section-overhang } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
+ { { $snippet "start" } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "end" } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "start-group?" } " - see " { $link start-group } }
+ { { $snippet "end-group?" } " - see " { $link end-group } }
+ { { $snippet "style" } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
+ { { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
} } ;
HELP: <section>
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor
index 9574d18eb1..c5b26ca837 100644
--- a/core/prettyprint/sections/sections.factor
+++ b/core/prettyprint/sections/sections.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays generic hashtables io kernel math assocs
namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-io.streams.nested ;
+io.streams.nested accessors ;
IN: prettyprint.sections
! State
@@ -70,17 +70,15 @@ start end
start-group? end-group?
style overhang ;
-: <section> ( style length -- section )
- position [ dup rot + dup ] change 0 {
- set-section-style
- set-section-start
- set-section-end
- set-section-overhang
- } section construct ;
+: construct-section ( length class -- section )
+ construct-empty
+ position get >>start
+ swap position [ + ] change
+ position get >>end
+ 0 >>overhang ; inline
M: section section-fits? ( section -- ? )
- dup section-end last-newline get -
- swap section-overhang + text-fits? ;
+ [ end>> last-newline get - ] [ overhang>> ] bi + text-fits? ;
M: section indent-section? drop f ;
@@ -98,10 +96,10 @@ M: object short-section? section-fits? ;
: indent> ( section -- ) tab-size get neg change-indent ;
: <fresh-line ( section -- )
- section-start fresh-line ;
+ start>> fresh-line ;
: fresh-line> ( section -- )
- dup newline-after? [ section-end fresh-line ] [ drop ] if ;
+ dup newline-after? [ end>> fresh-line ] [ drop ] if ;
: <long-section ( section -- )
dup unindent-first-line?
@@ -124,53 +122,54 @@ M: object short-section? section-fits? ;
] if ;
! Break section
-TUPLE: line-break type ;
+TUPLE: line-break < section type ;
: <line-break> ( type -- section )
- H{ } 0 <section>
- { set-line-break-type set-delegate }
- \ line-break construct ;
+ 0 \ line-break construct-section
+ swap >>type ;
M: line-break short-section drop ;
M: line-break long-section drop ;
! Block sections
-TUPLE: block sections ;
+TUPLE: block < section sections ;
+
+: construct-block ( style class -- block )
+ 0 swap construct-section
+ V{ } clone >>sections
+ swap >>style ; inline
: <block> ( style -- block )
- 0 <section> V{ } clone
- { set-delegate set-block-sections } block construct ;
-
-: delegate>block ( obj -- ) H{ } <block> swap set-delegate ;
+ block construct-block ;
: pprinter-block ( -- block ) pprinter-stack get peek ;
: add-section ( section -- )
- pprinter-block block-sections push ;
+ pprinter-block sections>> push ;
: last-section ( -- section )
- pprinter-block block-sections
+ pprinter-block sections>>
[ line-break? not ] find-last nip ;
: start-group ( -- )
- t last-section set-section-start-group? ;
+ last-section t >>start-group? drop ;
: end-group ( -- )
- t last-section set-section-end-group? ;
+ last-section t >>end-group? drop ;
: advance ( section -- )
- dup section-start last-newline get = not
- swap short-section? and
- [ bl ] when ;
+ [ start>> last-newline get = not ]
+ [ short-section? ] bi
+ and [ bl ] when ;
: line-break ( type -- ) [ <line-break> add-section ] when* ;
M: block section-fits? ( section -- ? )
- line-limit? [ drop t ] [ delegate section-fits? ] if ;
+ line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
- swap block-sections [ line-break? not ] subset
+ swap sections>> [ line-break? not ] subset
unclip pprint-section [
dup rot call pprint-section
] with each ; inline
@@ -179,28 +178,28 @@ M: block short-section ( block -- )
[ advance ] pprint-sections ;
: do-break ( break -- )
- dup line-break-type hard eq?
+ dup type>> hard eq?
over section-end last-newline get - margin get 2/ > or
[ <fresh-line ] [ drop ] if ;
-: empty-block? ( block -- ? ) block-sections empty? ;
+: empty-block? ( block -- ? ) sections>> empty? ;
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
: (<block) pprinter-stack get push ;
-: <block H{ } <block> (<block) ;
+: <block f <block> (<block) ;
: <object ( obj -- ) presented associate <block> (<block) ;
! Text section
-TUPLE: text string ;
+TUPLE: text < section string ;
: <text> ( string style -- text )
- over length 1+ <section>
- { set-text-string set-delegate }
- \ text construct ;
+ over length 1+ \ text construct-section
+ swap >>style
+ swap >>string ;
M: text short-section text-string write ;
@@ -211,18 +210,18 @@ M: text long-section short-section ;
: text ( string -- ) H{ } styled-text ;
! Inset section
-TUPLE: inset narrow? ;
+TUPLE: inset < block narrow? ;
: <inset> ( narrow? -- block )
- 2 H{ } <block>
- { set-inset-narrow? set-section-overhang set-delegate }
- inset construct ;
+ H{ } inset construct-block
+ 2 >>overhang
+ swap >>narrow? ;
M: inset long-section
- dup inset-narrow? [
+ dup narrow?>> [
[ <fresh-line ] pprint-sections
] [
- delegate long-section
+ call-next-method
] if ;
M: inset indent-section? drop t ;
@@ -232,25 +231,26 @@ M: inset newline-after? drop t ;
: <inset ( narrow? -- ) <inset> (<block) ;
! Flow section
-TUPLE: flow ;
+TUPLE: flow < block ;
: <flow> ( -- block )
- H{ } <block> flow construct-delegate ;
+ H{ } flow construct-block ;
M: flow short-section? ( section -- ? )
#! If we can make room for this entire block by inserting
#! a newline, do it; otherwise, don't bother, print it as
#! a short section
- dup section-fits?
- over section-end rot section-start - text-fits? not or ;
+ [ section-fits? ]
+ [ [ end>> ] [ start>> ] bi - text-fits? not ] bi
+ or ;
: <flow ( -- ) <flow> (<block) ;
! Colon definition section
-TUPLE: colon ;
+TUPLE: colon < block ;
: <colon> ( -- block )
- H{ } <block> colon construct-delegate ;
+ H{ } colon construct-block ;
M: colon long-section short-section ;
@@ -261,11 +261,11 @@ M: colon unindent-first-line? drop t ;
: <colon ( -- ) <colon> (<block) ;
: save-end-position ( block -- )
- position get swap set-section-end ;
+ position get >>end drop ;
: block> ( -- )
pprinter-stack get pop
- [ dup save-end-position add-section ] if-nonempty ;
+ [ [ save-end-position ] [ add-section ] bi ] if-nonempty ;
: with-section-state ( quot -- )
[
@@ -278,7 +278,7 @@ M: colon unindent-first-line? drop t ;
: do-pprint ( block -- )
[
[
- dup section-style [
+ dup style>> [
[ end-printing set dup short-section ] callcc0
] with-nesting drop
] if-nonempty
@@ -298,9 +298,9 @@ M: f section-start-group? drop t ;
M: f section-end-group? drop f ;
: split-before ( section -- )
- dup section-start-group? prev get section-end-group? and
- swap flow? prev get flow? not and
- or split-groups ;
+ [ section-start-group? prev get section-end-group? and ]
+ [ flow? prev get flow? not and ]
+ bi or split-groups ;
: split-after ( section -- )
section-end-group? split-groups ;
@@ -315,19 +315,19 @@ M: f section-end-group? drop f ;
] { } make { t } split [ empty? not ] subset ;
: break-group? ( seq -- ? )
- dup first section-fits? swap peek section-fits? not and ;
+ [ first section-fits? ] [ peek section-fits? not ] bi and ;
: ?break-group ( seq -- )
dup break-group? [ first <fresh-line ] [ drop ] if ;
M: block long-section ( block -- )
[
- block-sections chop-break group-flow [
+ sections>> chop-break group-flow [
dup ?break-group [
dup line-break? [
do-break
] [
- dup advance pprint-section
+ [ advance ] [ pprint-section ] bi
] if
] each
] each
From f2cbd7648f19ccc98e923083a3aef2c43abfc5c9 Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Fri, 4 Apr 2008 11:40:49 +0200
Subject: [PATCH 115/288] Use more combinators
---
extra/lazy-lists/lazy-lists.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor
index f642d8881c..19dc8a186b 100644
--- a/extra/lazy-lists/lazy-lists.factor
+++ b/extra/lazy-lists/lazy-lists.factor
@@ -78,7 +78,7 @@ M: lazy-cons nil? ( lazy-cons -- bool )
swap [ cdr ] times car ;
: (llength) ( list acc -- n )
- over nil? [ nip ] [ >r cdr r> 1+ (llength) ] if ;
+ over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
: llength ( list -- n )
0 (llength) ;
@@ -273,7 +273,7 @@ M: lazy-from-by car ( lazy-from-by -- car )
M: lazy-from-by cdr ( lazy-from-by -- cdr )
[ lazy-from-by-n ] keep
- lazy-from-by-quot dup >r call r> lfrom-by ;
+ lazy-from-by-quot dup slip lfrom-by ;
M: lazy-from-by nil? ( lazy-from-by -- bool )
drop f ;
@@ -370,10 +370,10 @@ M: lazy-concat nil? ( lazy-concat -- bool )
] if ;
: lcomp ( list quot -- result )
- >r lcartesian-product* r> lmap ;
+ [ lcartesian-product* ] dip lmap ;
: lcomp* ( list guards quot -- result )
- >r >r lcartesian-product* r> [ lsubset ] each r> lmap ;
+ [ [ lcartesian-product* ] dip [ lsubset ] each ] dip lmap ;
DEFER: lmerge
@@ -382,7 +382,7 @@ DEFER: lmerge
[
dup [ car ] curry -rot
[
- >r cdr r> cdr lmerge
+ [ cdr ] bi lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
@@ -419,7 +419,7 @@ M: lazy-io cdr ( lazy-io -- cdr )
[ lazy-io-stream ] keep
[ lazy-io-quot ] keep
car [
- >r f f r> <lazy-io> [ swap set-lazy-io-cdr ] keep
+ [ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
] [
3drop nil
] if
From 9e227d394e531921574797e5be5398c58f190da4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 05:09:58 -0500
Subject: [PATCH 116/288] Remove redundant code
---
core/classes/tuple/tuple.factor | 4 ----
core/kernel/kernel.factor | 4 ----
2 files changed, 8 deletions(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index ef81a0c953..546f7b15e8 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -7,10 +7,6 @@ classes classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs ;
IN: classes.tuple
-M: tuple delegate 2 slot ;
-
-M: tuple set-delegate 2 set-slot ;
-
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: no-tuple-class class ;
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 1935c89431..2b1dd3cf9c 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -194,12 +194,8 @@ M: callstack clone (clone) ;
PRIVATE>
! Deprecated
-GENERIC: delegate ( obj -- delegate )
-
M: object delegate drop f ;
-GENERIC: set-delegate ( delegate tuple -- )
-
GENERIC# get-slots 1 ( tuple slots -- ... )
GENERIC# set-slots 1 ( ... tuple slots -- )
From 48a6baedcd8b6978186e90016833a5797830d24f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 05:44:45 -0500
Subject: [PATCH 117/288] Convert compiler to use inheritance
---
core/compiler/tests/templates-early.factor | 4 +-
core/generator/registers/registers.factor | 142 ++++++++++-----------
2 files changed, 70 insertions(+), 76 deletions(-)
diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor
index d04f182e04..71da9436f1 100755
--- a/core/compiler/tests/templates-early.factor
+++ b/core/compiler/tests/templates-early.factor
@@ -173,12 +173,12 @@ SYMBOL: template-chosen
] unit-test
[ ] [
- 2 phantom-d get phantom-input
+ 2 phantom-datastack get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test
[ t ] [
- phantom-d get [ cached? ] all?
+ phantom-datastack get [ cached? ] all?
] unit-test
! >r
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index a7a2c94adf..b5b3f0b2c0 100755
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -230,48 +230,44 @@ INSTANCE: constant value
} case ;
! A compile-time stack
-TUPLE: phantom-stack height ;
+TUPLE: phantom-stack height stack ;
+
+M: phantom-stack clone
+ call-next-method [ clone ] change-stack ;
GENERIC: finalize-height ( stack -- )
-SYMBOL: phantom-d
-SYMBOL: phantom-r
-
-: <phantom-stack> ( class -- stack )
- >r
- V{ } clone 0
- { set-delegate set-phantom-stack-height }
- phantom-stack construct
- r> construct-delegate ;
+: construct-phantom-stack ( class -- stack )
+ >r 0 V{ } clone r> construct-boa ; inline
: (loc)
#! Utility for methods on <loc>
- phantom-stack-height - ;
+ height>> - ;
: (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing
#! instruction here.
- swap [
- phantom-stack-height
- dup zero? [ 2drop ] [ swap execute ] if
- 0
- ] keep set-phantom-stack-height ; inline
+ [
+ over zero? [ 2drop ] [ execute ] if 0
+ ] curry change-height drop ; inline
GENERIC: <loc> ( n stack -- loc )
-TUPLE: phantom-datastack ;
+TUPLE: phantom-datastack < phantom-stack ;
-: <phantom-datastack> phantom-datastack <phantom-stack> ;
+: <phantom-datastack> ( -- stack )
+ phantom-datastack construct-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
-TUPLE: phantom-retainstack ;
+TUPLE: phantom-retainstack < phantom-stack ;
-: <phantom-retainstack> phantom-retainstack <phantom-stack> ;
+: <phantom-retainstack> ( -- stack )
+ phantom-retainstack construct-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
@@ -283,34 +279,33 @@ M: phantom-retainstack finalize-height
>r <reversed> r> [ <loc> ] curry map ;
: phantom-locs* ( phantom -- locs )
- dup length swap phantom-locs ;
+ [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+ phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- )
- >r dup phantom-locs* swap r> 2each ; inline
+ >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- )
- >r phantom-d get r> phantom-r get over
- >r >r (each-loc) r> r> (each-loc) ; inline
+ phantoms 2array swap [ (each-loc) ] curry each ; inline
: adjust-phantom ( n phantom -- )
- [ phantom-stack-height + ] keep set-phantom-stack-height ;
+ swap [ + ] curry change-height drop ;
-GENERIC: cut-phantom ( n phantom -- seq )
-
-M: phantom-stack cut-phantom
- [ delegate swap cut* swap ] keep set-delegate ;
+: cut-phantom ( n phantom -- seq )
+ swap [ cut* swap ] curry change-stack drop ;
: phantom-append ( seq stack -- )
- over length over adjust-phantom push-all ;
+ over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- )
- 2dup length <= [
+ 2dup stack>> length <= [
2drop
] [
[ phantom-locs ] keep
- [ length head-slice* ] keep
- [ append >vector ] keep
- delegate set-delegate
+ [ stack>> length head-slice* ] keep
+ [ append >vector ] change-stack drop
] if ;
: phantom-input ( n phantom -- seq )
@@ -318,18 +313,16 @@ M: phantom-stack cut-phantom
2dup cut-phantom
>r >r neg r> adjust-phantom r> ;
-: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
-
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: live-vregs ( -- seq )
- [ [ [ live-vregs* ] each ] each-phantom ] { } make ;
+ [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
- dup phantom-locs* swap 2array flip
+ [ phantom-locs* ] [ stack>> ] bi 2array flip
[ live-loc? ] assoc-subset
values ;
@@ -349,7 +342,7 @@ SYMBOL: fresh-objects
\ free-vregs get at ;
: alloc-vreg ( spec -- reg )
- dup reg-spec>class free-vregs pop swap {
+ [ reg-spec>class free-vregs pop ] keep {
{ f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
@@ -375,8 +368,8 @@ SYMBOL: fresh-objects
} cond ;
: alloc-vreg-for ( value spec -- vreg )
- swap operand-class swap alloc-vreg
- dup tagged? [ tuck set-tagged-class ] [ nip ] if ;
+ alloc-vreg swap operand-class
+ over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
2dup allocation [
@@ -419,7 +412,7 @@ M: loc lazy-store
#! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in
#! use.
- dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ;
+ [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced
@@ -463,13 +456,13 @@ M: loc lazy-store
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
- over [
+ over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
] if
] 2map
- over delete-all
- swap push-all ;
+ over stack>> delete-all
+ swap stack>> push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
@@ -488,6 +481,7 @@ M: loc lazy-store
>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
@@ -505,7 +499,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
- [ substitute-here ] curry each-phantom ;
+ [ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ;
@@ -517,14 +511,15 @@ M: loc lazy-store
substitute-vregs ;
: load-inputs ( -- )
- +input+ get dup length phantom-d get phantom-input
- swap lazy-load ;
+ +input+ get
+ [ length phantom-datastack get phantom-input ] keep
+ lazy-load ;
: output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? )
- phantoms append [
+ phantoms [ stack>> ] bi@ append [
dup cached? [ cached-vreg ] when swap member?
] with contains? ;
@@ -542,15 +537,14 @@ M: loc lazy-store
[ first reg-spec>class ] map count-vregs ;
: guess-vregs ( dinput rinput scratch -- int# float# )
- H{
- { int-regs 0 }
- { double-float-regs 0 }
- } clone [
+ [
+ 0 int-regs set
+ 0 double-float-regs set
count-scratch-regs
- phantom-r get swap count-input-vregs
- phantom-d get swap count-input-vregs
+ phantom-retainstack get swap count-input-vregs
+ phantom-datastack get swap count-input-vregs
int-regs get double-float-regs get
- ] bind ;
+ ] with-scope ;
: alloc-scratch ( -- )
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
@@ -567,7 +561,7 @@ M: loc lazy-store
outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- )
- +output+ get [ get ] map phantom-d get phantom-append ;
+ +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
@@ -597,7 +591,7 @@ M: loc lazy-store
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( spec -- ? )
- phantom-d get +input+ rot at
+ phantom-datastack get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- )
@@ -606,14 +600,14 @@ M: loc lazy-store
] unless ;
: clear-phantoms ( -- )
- [ delete-all ] each-phantom ;
+ [ stack>> delete-all ] each-phantom ;
PRIVATE>
: set-operand-classes ( classes -- )
- phantom-d get
+ phantom-datastack get
over length over add-locs
- [ set-operand-class ] 2reverse-each ;
+ stack>> [ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
@@ -622,7 +616,7 @@ PRIVATE>
finalize-contents
clear-phantoms
finalize-heights
- fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
+ fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: with-template ( quot hash -- )
clone [
@@ -642,16 +636,16 @@ PRIVATE>
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
- <phantom-datastack> phantom-d set
- <phantom-retainstack> phantom-r 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-d [ clone ] change
- phantom-r [ clone ] change
+ phantom-datastack [ clone ] change
+ phantom-retainstack [ clone ] change
compute-free-vregs ;
: find-template ( templates -- pair/f )
@@ -667,17 +661,17 @@ UNION: immediate fixnum POSTPONE: f ;
operand-class immediate class< ;
: phantom-push ( obj -- )
- 1 phantom-d get adjust-phantom
- phantom-d get push ;
+ 1 phantom-datastack get adjust-phantom
+ phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- )
- [ effect-in length phantom-d get phantom-input ] keep
- shuffle* phantom-d get phantom-append ;
+ [ effect-in length phantom-datastack get phantom-input ] keep
+ shuffle* phantom-datastack get phantom-append ;
: phantom->r ( n -- )
- phantom-d get phantom-input
- phantom-r get phantom-append ;
+ phantom-datastack get phantom-input
+ phantom-retainstack get phantom-append ;
: phantom-r> ( n -- )
- phantom-r get phantom-input
- phantom-d get phantom-append ;
+ phantom-retainstack get phantom-input
+ phantom-datastack get phantom-append ;
From dcc28cd0f837f18b447d887fa3c5d75e45416cf7 Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Fri, 4 Apr 2008 12:48:36 +0200
Subject: [PATCH 118/288] Fix bug in project-euler.169 introduced by a former
checkin
---
extra/project-euler/169/169.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor
index 35fb2c2c1e..90655149dc 100644
--- a/extra/project-euler/169/169.factor
+++ b/extra/project-euler/169/169.factor
@@ -30,7 +30,7 @@ MEMO: fn ( n -- x )
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
- { [ t ] [ 2/ [ fn ] [ 1- fn + ] bi ] }
+ { [ t ] [ 2/ [ fn ] [ 1- fn + ] bi + ] }
} cond ;
: euler169 ( -- result )
From cf5ff72eb96d4e390754e084466cc86a74f4640a Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Fri, 4 Apr 2008 12:51:05 +0200
Subject: [PATCH 119/288] Fix bug introduced by former checkin
---
extra/lazy-lists/lazy-lists.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor
index 19dc8a186b..d13848498f 100644
--- a/extra/lazy-lists/lazy-lists.factor
+++ b/extra/lazy-lists/lazy-lists.factor
@@ -382,7 +382,7 @@ DEFER: lmerge
[
dup [ car ] curry -rot
[
- [ cdr ] bi lmerge
+ [ cdr ] bi@ lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
From 6b626f108c94057d6066173ad34399b87227ac8c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 05:57:59 -0500
Subject: [PATCH 120/288] Update extra/delegate; removing section protocol
since it makes little sense
---
extra/delegate/protocols/protocols.factor | 7 -------
1 file changed, 7 deletions(-)
diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor
index f9b4c8648d..ce03b3b205 100755
--- a/extra/delegate/protocols/protocols.factor
+++ b/extra/delegate/protocols/protocols.factor
@@ -23,10 +23,3 @@ PROTOCOL: stream-protocol
PROTOCOL: definition-protocol
where set-where forget uses redefined*
synopsis* definer definition ;
-
-PROTOCOL: prettyprint-section-protocol
- section-fits? indent-section? unindent-first-line?
- newline-after? short-section? short-section long-section
- <section> delegate>block add-section ;
-
-
From 5cc78f5b3900651754a12718352ce532afd5eea4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 06:21:50 -0500
Subject: [PATCH 121/288] Remove usages of delegation from core io
---
core/io/streams/duplex/duplex-docs.factor | 2 +-
core/io/streams/nested/nested.factor | 67 ++++++++++------
core/io/streams/plain/plain.factor | 2 +-
.../prettyprint/sections/sections-docs.factor | 2 +-
core/prettyprint/sections/sections.factor | 80 +++++++++----------
5 files changed, 86 insertions(+), 67 deletions(-)
diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor
index fa82c54163..6a956c6694 100755
--- a/core/io/streams/duplex/duplex-docs.factor
+++ b/core/io/streams/duplex/duplex-docs.factor
@@ -10,7 +10,7 @@ ARTICLE: "io.streams.duplex" "Duplex streams"
ABOUT: "io.streams.duplex"
HELP: duplex-stream
-{ $class-description "A bidirectional stream delegating to a pair of streams, sending input to one delegate and output to another." } ;
+{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor
index e32c90a2fc..6a8a09fbdb 100755
--- a/core/io/streams/nested/nested.factor
+++ b/core/io/streams/nested/nested.factor
@@ -1,30 +1,57 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.streams.nested
USING: arrays generic assocs kernel namespaces strings
-quotations io continuations ;
+quotations io continuations accessors ;
+IN: io.streams.nested
-TUPLE: ignore-close-stream ;
+TUPLE: filter-writer stream ;
-: <ignore-close-stream> ignore-close-stream construct-delegate ;
+M: filter-writer stream-format
+ stream>> stream-format ;
-M: ignore-close-stream dispose drop ;
+M: filter-writer stream-write
+ stream>> stream-write ;
-TUPLE: style-stream style ;
+M: filter-writer stream-write1
+ stream>> stream-write1 ;
-: do-nested-style ( style stream -- style delegate )
- [ style-stream-style swap union ] keep
- delegate ; inline
+M: filter-writer make-span-stream
+ stream>> make-span-stream ;
-: <style-stream> ( style delegate -- stream )
- { set-style-stream-style set-delegate }
- style-stream construct ;
+M: filter-writer make-block-stream
+ stream>> make-block-stream ;
+
+M: filter-writer make-cell-stream
+ stream>> make-cell-stream ;
+
+M: filter-writer stream-flush
+ stream>> stream-flush ;
+
+M: filter-writer stream-nl
+ stream>> stream-nl ;
+
+M: filter-writer stream-write-table
+ stream>> stream-write-table ;
+
+M: filter-writer dispose
+ drop ;
+
+TUPLE: ignore-close-stream < filter-writer ;
+
+C: <ignore-close-stream> ignore-close-stream
+
+TUPLE: style-stream < filter-writer style ;
+
+: do-nested-style ( style style-stream -- style stream )
+ [ style>> swap union ] [ stream>> ] bi ; inline
+
+C: <style-stream> style-stream
M: style-stream stream-format
do-nested-style stream-format ;
M: style-stream stream-write
- dup style-stream-style swap delegate stream-format ;
+ [ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1
>r 1string r> stream-write ;
@@ -33,15 +60,9 @@ M: style-stream make-span-stream
do-nested-style make-span-stream ;
M: style-stream make-block-stream
- [ do-nested-style make-block-stream ] keep
- style-stream-style swap <style-stream> ;
+ [ do-nested-style make-block-stream ] [ style>> ] bi
+ <style-stream> ;
M: style-stream make-cell-stream
- [ do-nested-style make-cell-stream ] keep
- style-stream-style swap <style-stream> ;
-
-TUPLE: block-stream ;
-
-: <block-stream> block-stream construct-delegate ;
-
-M: block-stream dispose drop ;
+ [ do-nested-style make-cell-stream ] [ style>> ] bi
+ <style-stream> ;
diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor
index 4898a58fb1..8d8a0a8810 100644
--- a/core/io/streams/plain/plain.factor
+++ b/core/io/streams/plain/plain.factor
@@ -12,7 +12,7 @@ M: plain-writer stream-format
nip stream-write ;
M: plain-writer make-span-stream
- <style-stream> <ignore-close-stream> ;
+ swap <style-stream> ;
M: plain-writer make-block-stream
nip <ignore-close-stream> ;
diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor
index e704df2085..3a86c014af 100755
--- a/core/prettyprint/sections/sections-docs.factor
+++ b/core/prettyprint/sections/sections-docs.factor
@@ -86,7 +86,7 @@ HELP: section
{ { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
} } ;
-HELP: <section>
+HELP: construct-section
{ $values { "style" hashtable } { "length" integer } { "section" section } }
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor
index c5b26ca837..848947e624 100644
--- a/core/prettyprint/sections/sections.factor
+++ b/core/prettyprint/sections/sections.factor
@@ -11,37 +11,38 @@ SYMBOL: position
SYMBOL: recursion-check
SYMBOL: pprinter-stack
-SYMBOL: last-newline
-SYMBOL: line-count
-SYMBOL: end-printing
-SYMBOL: indent
-
! We record vocabs of all words
SYMBOL: pprinter-in
SYMBOL: pprinter-use
+TUPLE: pprinter last-newline line-count end-printing indent ;
+
+: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter construct-boa ;
+
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
! Utility words
: line-limit? ( -- ? )
- line-limit get dup [ line-count get <= ] when ;
+ line-limit get dup [ pprinter get line-count>> <= ] when ;
-: do-indent ( -- ) indent get CHAR: \s <string> write ;
+: do-indent ( -- ) pprinter get indent>> CHAR: \s <string> write ;
: fresh-line ( n -- )
- dup last-newline get = [
+ dup pprinter get last-newline>> = [
drop
] [
- last-newline set
- line-limit? [ "..." write end-printing get continue ] when
- line-count inc
+ pprinter get (>>last-newline)
+ line-limit? [
+ "..." write pprinter get end-printing>> continue
+ ] when
+ pprinter get [ 1+ ] change-line-count drop
nl do-indent
] if ;
: text-fits? ( len -- ? )
margin get dup zero?
- [ 2drop t ] [ >r indent get + r> <= ] if ;
+ [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ;
! break only if position margin 2 / >
SYMBOL: soft
@@ -78,7 +79,9 @@ style overhang ;
0 >>overhang ; inline
M: section section-fits? ( section -- ? )
- [ end>> last-newline get - ] [ overhang>> ] bi + text-fits? ;
+ [ end>> pprinter get last-newline>> - ]
+ [ overhang>> ] bi
+ + text-fits? ;
M: section indent-section? drop f ;
@@ -88,12 +91,14 @@ M: section newline-after? drop f ;
M: object short-section? section-fits? ;
-: change-indent ( section n -- )
- swap indent-section? [ indent +@ ] [ drop ] if ;
+: indent+ ( section n -- )
+ swap indent-section? [
+ pprinter get [ + ] change-indent drop
+ ] [ drop ] if ;
-: <indent ( section -- ) tab-size get change-indent ;
+: <indent ( section -- ) tab-size get indent+ ;
-: indent> ( section -- ) tab-size get neg change-indent ;
+: indent> ( section -- ) tab-size get neg indent+ ;
: <fresh-line ( section -- )
start>> fresh-line ;
@@ -108,17 +113,14 @@ M: object short-section? section-fits? ;
: long-section> ( section -- )
dup indent> fresh-line> ;
-: with-style* ( style quot -- )
- swap stdio [ <style-stream> ] change
- call stdio [ delegate ] change ; inline
-
: pprint-section ( section -- )
dup short-section? [
- dup section-style [ short-section ] with-style*
+ dup section-style [ short-section ] with-style
] [
- dup <long-section
- dup section-style [ dup long-section ] with-style*
- long-section>
+ [ <long-section ]
+ [ dup section-style [ long-section ] with-style ]
+ [ long-section> ]
+ tri
] if ;
! Break section
@@ -159,7 +161,7 @@ TUPLE: block < section sections ;
last-section t >>end-group? drop ;
: advance ( section -- )
- [ start>> last-newline get = not ]
+ [ start>> pprinter get last-newline>> = not ]
[ short-section? ] bi
and [ bl ] when ;
@@ -178,9 +180,10 @@ M: block short-section ( block -- )
[ advance ] pprint-sections ;
: do-break ( break -- )
- dup type>> hard eq?
- over section-end last-newline get - margin get 2/ > or
- [ <fresh-line ] [ drop ] if ;
+ [ ]
+ [ type>> hard eq? ]
+ [ end>> pprinter get last-newline>> - margin get 2/ > ] tri
+ or [ <fresh-line ] [ drop ] if ;
: empty-block? ( block -- ? ) sections>> empty? ;
@@ -267,22 +270,17 @@ M: colon unindent-first-line? drop t ;
pprinter-stack get pop
[ [ save-end-position ] [ add-section ] bi ] if-nonempty ;
-: with-section-state ( quot -- )
- [
- 0 indent set
- 0 last-newline set
- 1 line-count set
- call
- ] with-scope ; inline
-
: do-pprint ( block -- )
- [
+ <pprinter> pprinter [
[
dup style>> [
- [ end-printing set dup short-section ] callcc0
- ] with-nesting drop
+ [
+ >r pprinter get (>>end-printing) r>
+ short-section
+ ] curry callcc0
+ ] with-nesting
] if-nonempty
- ] with-section-state ;
+ ] with-variable ;
! Long section layout algorithm
: chop-break ( seq -- seq )
From c8588a37ee08f2c2fc90a0883f2931363ffc0d7a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 06:28:51 -0500
Subject: [PATCH 122/288] Load fixes
---
core/prettyprint/config/config-docs.factor | 6 ------
core/prettyprint/sections/sections-docs.factor | 13 -------------
2 files changed, 19 deletions(-)
diff --git a/core/prettyprint/config/config-docs.factor b/core/prettyprint/config/config-docs.factor
index f197ac7966..1a2fd69949 100644
--- a/core/prettyprint/config/config-docs.factor
+++ b/core/prettyprint/config/config-docs.factor
@@ -4,12 +4,6 @@ IN: prettyprint.config
ABOUT: "prettyprint-variables"
-HELP: indent
-{ $var-description "The prettyprinter's current indent level." } ;
-
-HELP: pprinter-stack
-{ $var-description "A stack of " { $link block } " objects currently being constructed by the prettyprinter." } ;
-
HELP: tab-size
{ $var-description "Prettyprinter tab size. Indent nesting is always a multiple of the tab size." } ;
diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor
index 3a86c014af..b07e83d0d1 100755
--- a/core/prettyprint/sections/sections-docs.factor
+++ b/core/prettyprint/sections/sections-docs.factor
@@ -5,18 +5,9 @@ strings definitions ;
HELP: position
{ $var-description "The prettyprinter's current character position." } ;
-HELP: last-newline
-{ $var-description "The character position of the last newline output by the prettyprinter." } ;
-
HELP: recursion-check
{ $var-description "The current nesting of collections being output by the prettyprinter, used to detect circularity and prevent infinite recursion." } ;
-HELP: line-count
-{ $var-description "The number of lines output by the prettyprinter so far, used for line limiting (see " { $link line-limit } ")." } ;
-
-HELP: end-printing
-{ $var-description "A continuation captured by " { $link do-pprint } " that breaks out of the printer." } ;
-
HELP: line-limit?
{ $values { "?" "a boolean" } }
{ $description "Tests if the line number limit has been reached, and thus if prettyprinting should stop." } ;
@@ -90,10 +81,6 @@ HELP: construct-section
{ $values { "style" hashtable } { "length" integer } { "section" section } }
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
-HELP: change-indent
-{ $values { "section" section } { "n" integer } }
-{ $description "If the section requests indentation, adds " { $snippet "n" } " to the indent level, otherwise does nothing." } ;
-
HELP: <indent
{ $values { "section" section } }
{ $description "Increases indentation by the " { $link tab-size } " if requested by the section." } ;
From 3a374f2045ecd40df9bf80794bdea76bbef38a38 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 4 Apr 2008 07:08:03 -0500
Subject: [PATCH 123/288] Fix amazing performance regression
---
core/definitions/definitions-docs.factor | 7 -------
core/definitions/definitions.factor | 7 -------
core/words/words.factor | 24 ++++++++++++++++++++++--
vm/types.c | 2 +-
4 files changed, 23 insertions(+), 17 deletions(-)
diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor
index d855a14be9..d43c61ff70 100755
--- a/core/definitions/definitions-docs.factor
+++ b/core/definitions/definitions-docs.factor
@@ -12,8 +12,6 @@ $nl
{ $subsection forget }
"Definitions can answer a sequence of definitions they directly depend on:"
{ $subsection uses }
-"When a definition is changed, all definitions which depend on it are notified via a hook:"
-{ $subsection redefined* }
"Definitions must implement a few operations used for printing them in source form:"
{ $subsection synopsis* }
{ $subsection definer }
@@ -108,11 +106,6 @@ HELP: usage
{ $description "Outputs a sequence of definitions that directly call the given definition." }
{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
-HELP: redefined*
-{ $values { "defspec" "a definition specifier" } }
-{ $contract "Updates the definition to cope with a callee being redefined." }
-$low-level-note ;
-
HELP: unxref
{ $values { "defspec" "a definition specifier" } }
{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." }
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index cec5109909..6ee21fc016 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -42,13 +42,6 @@ M: object uses drop f ;
: usage ( defspec -- seq ) \ f or crossref get at keys ;
-GENERIC: redefined* ( defspec -- )
-
-M: object redefined* drop ;
-
-: redefined ( defspec -- )
- [ crossref get at ] closure [ drop redefined* ] assoc-each ;
-
: unxref ( defspec -- )
dup uses crossref get remove-vertex ;
diff --git a/core/words/words.factor b/core/words/words.factor
index 059815e952..2510c50347 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -121,8 +121,28 @@ SYMBOL: +called+
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
] with each keys ;
-M: word redefined* ( word -- )
- { "inferred-effect" "no-effect" } reset-props ;
+<PRIVATE
+
+SYMBOL: visited
+
+: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
+
+: (redefined) ( word -- )
+ dup visited get key? [ drop ] [
+ [ reset-on-redefine reset-props ]
+ [ dup visited get set-at ]
+ [
+ crossref get at keys [ word? ] subset [
+ reset-on-redefine [ word-prop ] with contains?
+ ] subset
+ [ (redefined) ] each
+ ] tri
+ ] if ;
+
+PRIVATE>
+
+: redefined ( word -- )
+ H{ } clone visited [ (redefined) ] with-variable ;
SYMBOL: changed-words
diff --git a/vm/types.c b/vm/types.c
index 24bb4cb3ca..f88c3ef3cb 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -42,7 +42,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
UNREGISTER_ROOT(name);
UNREGISTER_ROOT(vocab);
- word->hashcode = tag_fixnum(rand());
+ word->hashcode = tag_fixnum((rand() << 16) ^ rand());
word->vocabulary = vocab;
word->name = name;
word->def = userenv[UNDEFINED_ENV];
From 9c31dc1164796afaad34a3bb966ace3dcf9b7608 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 07:39:00 -0500
Subject: [PATCH 124/288] Fix failing unit test
---
core/io/files/files-tests.factor | 6 +++---
core/io/streams/nested/nested.factor | 6 +++++-
2 files changed, 8 insertions(+), 4 deletions(-)
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index b4a7d44433..5efbb9496d 100755
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -1,7 +1,7 @@
IN: io.files.tests
-USING: tools.test io.files io threads kernel continuations
-io.encodings.ascii io.files.unique sequences strings accessors
-io.encodings.utf8 ;
+USING: tools.test io.files io.files.private io threads kernel
+continuations io.encodings.ascii io.files.unique sequences
+strings accessors io.encodings.utf8 ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor
index 6a8a09fbdb..2a522d8e36 100755
--- a/core/io/streams/nested/nested.factor
+++ b/core/io/streams/nested/nested.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel namespaces strings
-quotations io continuations accessors ;
+quotations io continuations accessors sequences ;
IN: io.streams.nested
TUPLE: filter-writer stream ;
@@ -66,3 +66,7 @@ M: style-stream make-block-stream
M: style-stream make-cell-stream
[ do-nested-style make-cell-stream ] [ style>> ] bi
<style-stream> ;
+
+M: style-stream stream-write-table
+ [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
+ stream-write-table ;
From 7e7ba4ca383a024efd798681131fd121a5661932 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 07:39:09 -0500
Subject: [PATCH 125/288] Fixing streams
---
extra/ui/gadgets/panes/panes.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 91b7f0f225..94ff427961 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -166,7 +166,7 @@ M: pane-stream dispose drop ;
M: pane-stream stream-flush drop ;
M: pane-stream make-span-stream
- <style-stream> <ignore-close-stream> ;
+ swap <style-stream> ;
! Character styles
From fa65bdad14c89d0072f0a02d2ab5cfad9f940e9c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 4 Apr 2008 07:40:36 -0500
Subject: [PATCH 126/288] Fix load failures
---
extra/hardware-info/windows/ce/ce.factor | 2 +-
extra/random-tester/safe-words/safe-words.factor | 6 ------
2 files changed, 1 insertion(+), 7 deletions(-)
diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor
index 55c2ac6c0d..c61a3c8b8a 100755
--- a/extra/hardware-info/windows/ce/ce.factor
+++ b/extra/hardware-info/windows/ce/ce.factor
@@ -1,5 +1,5 @@
USING: alien.c-types hardware-info kernel math namespaces
-windows windows.kernel32 hardware-info.backend ;
+windows windows.kernel32 hardware-info.backend system ;
IN: hardware-info.windows.ce
: memory-status ( -- MEMORYSTATUS )
diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor
index f7eac4c32d..5ca2c79afe 100755
--- a/extra/random-tester/safe-words/safe-words.factor
+++ b/extra/random-tester/safe-words/safe-words.factor
@@ -52,11 +52,6 @@ IN: random-tester.safe-words
>r r>
} ;
-: method-words
- {
- forget-word
- } ;
-
: stateful-words
{
counter
@@ -82,7 +77,6 @@ IN: random-tester.safe-words
bignum-words %
initialization-words %
stack-words %
- method-words %
stateful-words %
exit-words %
foo-words %
From a4700e072e06f3373e3e9d02cd9c9af9127df098 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 01:56:37 +1300
Subject: [PATCH 127/288] delocalise apply-rule
---
extra/peg/peg.factor | 16 ++++++----------
1 file changed, 6 insertions(+), 10 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 217805ce47..e9f1d05473 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -188,16 +188,12 @@ C: <head> peg-head
m ans>>
] if ;
-:: apply-rule ( r p -- ast )
- [let* |
- m [ r p recall ]
- |
- m [
- r m apply-memo-rule
- ] [
- r p apply-non-memo-rule
- ] if
- ] ; inline
+: apply-rule ( r p -- ast )
+ 2dup recall [
+ nip apply-memo-rule
+ ] [
+ apply-non-memo-rule
+ ] if* ; inline
: with-packrat ( input quot -- result )
#! Run the quotation with a packrat cache active.
From 72dbac6a2900617818a41d726e2016f3b3b810bb Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 02:07:17 +1300
Subject: [PATCH 128/288] delocalise apply-memo-rule
---
extra/peg/peg.factor | 13 ++++++-------
1 file changed, 6 insertions(+), 7 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index e9f1d05473..b157580f9b 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -179,14 +179,13 @@ C: <head> peg-head
] if
] ; inline
-:: apply-memo-rule ( r m -- ast )
- m pos>> pos set
- m ans>> left-recursion? [
- r m ans>> setup-lr
- m ans>> seed>>
+: apply-memo-rule ( r m -- ast )
+ [ ans>> ] [ pos>> ] bi pos set
+ dup left-recursion? [
+ [ setup-lr ] keep seed>>
] [
- m ans>>
- ] if ;
+ nip
+ ] if ; inline
: apply-rule ( r p -- ast )
2dup recall [
From a6b160c447445461a96c973b7d5e6031ff189c03 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 02:26:41 +1300
Subject: [PATCH 129/288] apply-memo-rule doesn't need to be inline
---
extra/peg/peg.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index b157580f9b..3828fe7d9e 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -185,7 +185,7 @@ C: <head> peg-head
[ setup-lr ] keep seed>>
] [
nip
- ] if ; inline
+ ] if ;
: apply-rule ( r p -- ast )
2dup recall [
From ca652dc1573acfbfaeb8244d1cb0791ac6a36516 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 08:44:32 -0500
Subject: [PATCH 130/288] Fix UI panes
---
core/io/streams/nested/nested.factor | 4 +-
core/io/streams/plain/plain.factor | 2 +-
extra/ui/gadgets/panes/panes-tests.factor | 73 ++++++++++++++++++++---
extra/ui/gadgets/panes/panes.factor | 2 +-
4 files changed, 71 insertions(+), 10 deletions(-)
diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor
index 2a522d8e36..6b8953f86e 100755
--- a/core/io/streams/nested/nested.factor
+++ b/core/io/streams/nested/nested.factor
@@ -34,10 +34,12 @@ M: filter-writer stream-write-table
stream>> stream-write-table ;
M: filter-writer dispose
- drop ;
+ stream>> dispose ;
TUPLE: ignore-close-stream < filter-writer ;
+M: ignore-close-stream dispose drop ;
+
C: <ignore-close-stream> ignore-close-stream
TUPLE: style-stream < filter-writer style ;
diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor
index 8d8a0a8810..47bff681cd 100644
--- a/core/io/streams/plain/plain.factor
+++ b/core/io/streams/plain/plain.factor
@@ -12,7 +12,7 @@ M: plain-writer stream-format
nip stream-write ;
M: plain-writer make-span-stream
- swap <style-stream> ;
+ swap <style-stream> <ignore-close-stream> ;
M: plain-writer make-block-stream
nip <ignore-close-stream> ;
diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor
index e3f6e36050..0263b15d71 100755
--- a/extra/ui/gadgets/panes/panes-tests.factor
+++ b/extra/ui/gadgets/panes/panes-tests.factor
@@ -1,8 +1,8 @@
IN: ui.gadgets.panes.tests
USING: alien ui.gadgets.panes ui.gadgets namespaces
-kernel sequences io io.streams.string tools.test prettyprint
-definitions help help.syntax help.markup splitting
-tools.test.ui models ;
+kernel sequences io io.styles io.streams.string tools.test
+prettyprint definitions help help.syntax help.markup
+help.stylesheet splitting tools.test.ui models math inspector ;
: #children "pane" get gadget-children length ;
@@ -17,20 +17,79 @@ tools.test.ui models ;
[ t ] [ #children "num-children" get = ] unit-test
: test-gadget-text
- dup make-pane gadget-text
- swap with-string-writer "\n" ?tail drop "\n" ?tail drop = ;
+ dup make-pane gadget-text dup print "======" print
+ swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting
+ ] test-gadget-text
+] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [
+ H{ } [
+ "hello" pprint
+ ] with-style
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
+[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
[ t ] [ [ \ = see ] test-gadget-text ] unit-test
[ t ] [ [ \ = help ] test-gadget-text ] unit-test
-ARTICLE: "test-article" "This is a test article"
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ [ "Hello world" write ] ($block)
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+ARTICLE: "test-article-1" "This is a test article"
+"Hello world, how are you today." ;
+
+[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
+
+[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+
+ARTICLE: "test-article-2" "This is a test article"
"Hello world, how are you today."
{ $table { "a" "b" } { "c" "d" } } ;
-[ t ] [ [ "test-article" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
<pane> [ \ = see ] with-pane
<pane> [ \ = help ] with-pane
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 94ff427961..fedacbd2af 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -166,7 +166,7 @@ M: pane-stream dispose drop ;
M: pane-stream stream-flush drop ;
M: pane-stream make-span-stream
- swap <style-stream> ;
+ swap <style-stream> <ignore-close-stream> ;
! Character styles
From 5b5aaa344a574b92f0776a0403874e761758bfb1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 09:17:26 -0500
Subject: [PATCH 131/288] Smarter fep
---
vm/debug.c | 34 ++++++++++++++++++++++++++++++++--
1 file changed, 32 insertions(+), 2 deletions(-)
diff --git a/vm/debug.c b/vm/debug.c
index 7e18738afc..101313a5ee 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -146,6 +146,18 @@ void print_objects(CELL start, CELL end)
}
}
+void print_datastack(void)
+{
+ printf("==== DATA STACK:\n");
+ print_objects(ds_bot,ds);
+}
+
+void print_retainstack(void)
+{
+ printf("==== RETAIN STACK:\n");
+ print_objects(rs_bot,rs);
+}
+
void print_stack_frame(F_STACK_FRAME *frame)
{
print_obj(frame_executing(frame));
@@ -158,6 +170,7 @@ void print_stack_frame(F_STACK_FRAME *frame)
void print_callstack(void)
{
+ printf("==== CALL STACK:\n");
CELL bottom = (CELL)stack_chain->callstack_bottom;
CELL top = (CELL)stack_chain->callstack_top;
iterate_callstack(top,bottom,print_stack_frame);
@@ -336,6 +349,8 @@ void factorbug(void)
printf("push <addr> -- push object on data stack - NOT SAFE\n");
printf("code -- code heap dump\n");
+ bool seen_command = false;
+
for(;;)
{
char cmd[1024];
@@ -344,7 +359,22 @@ void factorbug(void)
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
+ {
+ if(!seen_command)
+ {
+ /* If we exit with an EOF immediately, then
+ dump stacks. This is useful for builder and
+ other cases where Factor is run with stdin
+ redirected to /dev/null */
+ print_datastack();
+ print_retainstack();
+ print_callstack();
+ }
+
exit(1);
+ }
+
+ seen_command = true;
if(strcmp(cmd,"d") == 0)
{
@@ -371,9 +401,9 @@ void factorbug(void)
else if(strcmp(cmd,"r") == 0)
dump_memory(rs_bot,rs);
else if(strcmp(cmd,".s") == 0)
- print_objects(ds_bot,ds);
+ print_datastack();
else if(strcmp(cmd,".r") == 0)
- print_objects(rs_bot,rs);
+ print_retainstack();
else if(strcmp(cmd,".c") == 0)
print_callstack();
else if(strcmp(cmd,"e") == 0)
From 41e5226df6c9777e2defd5921d9b34f3259a678d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 09:17:33 -0500
Subject: [PATCH 132/288] Load fixes
---
extra/contributors/contributors.factor | 5 +++--
extra/delegate/protocols/protocols.factor | 2 +-
extra/pack/pack.factor | 7 +++----
3 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor
index 6365b91517..d0da724cc6 100755
--- a/extra/contributors/contributors.factor
+++ b/extra/contributors/contributors.factor
@@ -5,8 +5,9 @@ sequences sequences.lib assocs system sorting math.parser ;
IN: contributors
: changelog ( -- authors )
- image parent-directory cd
- "git-log --pretty=format:%an" <process-stream> lines ;
+ image parent-directory [
+ "git-log --pretty=format:%an" <process-stream> lines
+ ] with-directory ;
: patch-counts ( authors -- assoc )
dup prune
diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor
index ce03b3b205..64e133dd2a 100755
--- a/extra/delegate/protocols/protocols.factor
+++ b/extra/delegate/protocols/protocols.factor
@@ -21,5 +21,5 @@ PROTOCOL: stream-protocol
make-cell-stream stream-write-table ;
PROTOCOL: definition-protocol
- where set-where forget uses redefined*
+ where set-where forget uses
synopsis* definer definition ;
diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor
index f5ba0fd11d..65912244dd 100755
--- a/extra/pack/pack.factor
+++ b/extra/pack/pack.factor
@@ -1,8 +1,7 @@
USING: alien alien.c-types arrays assocs byte-arrays inference
-inference.transforms io io.binary io.streams.string kernel
-math math.parser namespaces parser prettyprint
-quotations sequences strings vectors
-words macros math.functions ;
+inference.transforms io io.binary io.streams.string kernel math
+math.parser namespaces parser prettyprint quotations sequences
+strings vectors words macros math.functions math.bitfields.lib ;
IN: pack
SYMBOL: big-endian
From 8f8d78d73d209f01bd1a4baab5ef32275ca85762 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 09:57:06 -0500
Subject: [PATCH 133/288] Documentation updates
---
core/classes/tuple/tuple-docs.factor | 22 ++++++++++++++++
core/continuations/continuations-docs.factor | 27 +++++++++++++++++---
core/kernel/kernel-docs.factor | 1 +
core/syntax/syntax-docs.factor | 14 +++++++---
4 files changed, 58 insertions(+), 6 deletions(-)
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 3e1f85c936..4ee72cdf83 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -219,6 +219,26 @@ ARTICLE: "tuple-examples" "Tuple examples"
}
"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ;
+ARTICLE: "tuple-redefinition" "Tuple redefinition"
+"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses."
+$nl
+"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "."
+$nl
+"There are three ways to change the list of effective slots of a class:"
+{ $list
+ "Adding or removing direct slots of the class"
+ "Adding or removing direct slots of a superclass of the class"
+ "Changing the inheritance hierarchy by redefining a class to have a different superclass"
+}
+"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:"
+{ $list
+ "If any slots were removed, the values are removed from the instance and are lost forever."
+ { "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." }
+ "If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory."
+ "If the number or order of effective slots changes, any BOA constructors are recompiled."
+}
+"Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ;
+
ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots."
{ $subsection "tuple-examples" }
@@ -234,6 +254,8 @@ $nl
{ $subsection "tuple-subclassing" }
"Introspection:"
{ $subsection "tuple-introspection" }
+"Tuple classes can be redefined; this updates existing instances:"
+{ $subsection "tuple-redefinition" }
"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
ABOUT: "tuples"
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index ca7af930f2..b3adb1b165 100755
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private
continuations.private parser vectors arrays namespaces
-assocs words quotations ;
+assocs words quotations io ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
@@ -17,6 +17,25 @@ ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
{ $subsection error-continuation }
"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
+ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
+"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
+{ $heading "Anti-pattern #1: Ignoring errors" }
+"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
+{ $heading "Anti-pattern #2: Catching errors too early" }
+"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
+$nl
+"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
+{ $heading "Anti-pattern #3: Dropping and rethrowing" }
+"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
+{ $heading "Anti-pattern #4: Logging and rethrowing" }
+"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information."
+{ $heading "Anti-pattern #5: Leaking external resources" }
+"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
+{ $code
+ "<external-resource> ... do stuff ... dispose"
+}
+"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
+
ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl
@@ -27,10 +46,13 @@ $nl
{ $subsection cleanup }
{ $subsection recover }
{ $subsection ignore-errors }
+"Syntax sugar for defining errors:"
+{ $subsection POSTPONE: ERROR: }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "debugger" }
{ $subsection "errors-post-mortem" }
+{ $subsection "errors-anti-examples" }
"When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ;
@@ -61,8 +83,7 @@ $nl
"Another two words resume continuations:"
{ $subsection continue }
{ $subsection continue-with }
-"Continuations serve as the building block for a number of higher-level abstractions."
-{ $subsection "errors" }
+"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
ABOUT: "continuations"
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 6a2a2ff917..4578e2a93f 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -278,6 +278,7 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "combinators" }
"Advanced topics:"
{ $subsection "implementing-combinators" }
+{ $subsection "errors" }
{ $subsection "continuations" } ;
ABOUT: "dataflow"
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index 17dbd9f17b..61e77ae9a5 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -565,9 +565,17 @@ HELP: TUPLE:
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
-{ $description "Defines a new tuple class. Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ;
-
-{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words
+{ $description "Defines a new tuple class whose class word throws a new instance of the error." }
+{ $notes
+ "The following two snippets are equivalent:"
+ { $code
+ "ERROR: invalid-values x y ;"
+ ""
+ "TUPLE: invalid-values x y ;"
+ ": invalid-values ( x y -- * )"
+ " \\ invalid-values construct-boa throw ;"
+ }
+} ;
HELP: C:
{ $syntax "C: constructor class" }
From 0cc26425fd03b10b812e4461a671cfec4ba13106 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 4 Apr 2008 10:05:52 -0500
Subject: [PATCH 134/288] Make image smaller on Windows
---
extra/tools/deploy/shaker/shaker.factor | 5 +++++
1 file changed, 5 insertions(+)
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index ee9c2b9fab..ca421ecff8 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -186,6 +186,11 @@ IN: tools.deploy.shaker
deploy-ui? get [
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
+
+ "<counter>" "inference.dataflow" lookup [ , ] when*
+
+ "windows-messages" "windows.messages" lookup [ , ] when*
+
] { } make ;
: strip-globals ( stripped-globals -- )
From f6030fb3a4976139893d0ff55c04bd2e42449c3b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 4 Apr 2008 10:11:31 -0500
Subject: [PATCH 135/288] Another improvement
---
extra/tools/deploy/shaker/shaker.factor | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index ca421ecff8..72e1c33a26 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -6,6 +6,7 @@ memory kernel.private continuations io prettyprint
vocabs.loader debugger system strings ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
+QUALIFIED: command-line
QUALIFIED: compiler.errors.private
QUALIFIED: compiler.units
QUALIFIED: continuations
@@ -139,14 +140,17 @@ IN: tools.deploy.shaker
{ } { "cpu" } strip-vocab-globals %
{
+ gensym
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
classes:class<-cache
classes:classes-intersect-cache
classes:update-map
+ command-line:main-vocab-hook
compiled-crossref
compiler.units:recompile-hook
+ compiler.units:update-tuples-hook
definitions:crossref
interactive-vocabs
layouts:num-tags
@@ -187,7 +191,7 @@ IN: tools.deploy.shaker
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
- "<counter>" "inference.dataflow" lookup [ , ] when*
+ "<computer>" "inference.dataflow" lookup [ , ] when*
"windows-messages" "windows.messages" lookup [ , ] when*
From 87a705e782cbefb6c2034799605f30ed638401b5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 4 Apr 2008 12:02:12 -0500
Subject: [PATCH 136/288] fix sha1-interleave
---
extra/crypto/sha1/sha1.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor
index d054eda31b..37e92db60f 100755
--- a/extra/crypto/sha1/sha1.factor
+++ b/extra/crypto/sha1/sha1.factor
@@ -125,4 +125,4 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
seq>2seq [ byte-array>sha1 ] bi@
- swap 2seq>seq ;
+ 2seq>seq ;
From b35ef018600eb8cd681e8e5520c3896014613658 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 4 Apr 2008 12:02:25 -0500
Subject: [PATCH 137/288] fix windows bootstrap
---
extra/io/windows/launcher/launcher.factor | 9 +++++----
extra/io/windows/windows.factor | 11 ++++++-----
2 files changed, 11 insertions(+), 9 deletions(-)
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index f9b2742cda..07ce6c308a 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -1,11 +1,12 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays continuations destructors io
+USING: alien alien.c-types arrays continuations io
io.windows io.windows.nt.pipes libc io.nonblocking
-io.streams.duplex windows.types math windows.kernel32 windows
-namespaces io.launcher kernel sequences windows.errors assocs
+io.streams.duplex windows.types math windows.kernel32
+namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators
-io.backend accessors concurrency.flags io.files ;
+io.backend accessors concurrency.flags io.files assocs
+io.files.private windows destructors ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 7755f111c6..3e0f4e9e86 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -32,7 +32,8 @@ M: windows normalize-directory ( string -- string )
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
- "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
+ "SECURITY_ATTRIBUTES" heap-size
+ over set-SECURITY_ATTRIBUTES-nLength ;
: security-attributes-inherit ( -- obj )
default-security-attributes
@@ -47,8 +48,8 @@ M: win32-file close-handle ( handle -- )
! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode flags -- handle )
[
- >r >r
- share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
+ >r >r share-mode security-attributes-inherit r> r>
+ CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
@@ -95,7 +96,8 @@ M: win32-file close-handle ( handle -- )
>r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
+ hFile lpBuffer nNumberOfBytesToRead
+ lpNumberOfBytesRet lpOverlapped ;
C: <FileArgs> FileArgs
@@ -195,4 +197,3 @@ M: windows addrinfo-error ( n -- )
: tcp-socket ( addrspec -- socket )
protocol-family SOCK_STREAM open-socket ;
-
From a870b7d635984ed4004940004724f823f98eb0fa Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 4 Apr 2008 12:26:39 -0500
Subject: [PATCH 138/288] builder: remove reference to 'cwd'
---
extra/builder/builder.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 75664ce5e5..2982f675b4 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -127,10 +127,10 @@ SYMBOL: build-status
"report" utf8
[
- "Build machine: " write host-name print
- "CPU: " write cpu print
- "OS: " write os print
- "Build directory: " write cwd print
+ "Build machine: " write host-name print
+ "CPU: " write cpu print
+ "OS: " write os print
+ "Build directory: " write current-directory get print
git-clone [ "git clone failed" print ] run-or-bail
From 89d4c4ca595d96f831cac149cd58feeb0690ff99 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 4 Apr 2008 12:27:30 -0500
Subject: [PATCH 139/288] newfx: add a couple of variants
---
extra/newfx/newfx.factor | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index 53cda66dfc..ae92f8f6c0 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -22,11 +22,16 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ;
+: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: mutate-nth ( seq i val -- ) swap rot set-nth ;
-: mutate-at-nth ( seq val i -- ) rot set-nth ;
+: mutate-nth-at ( seq val i -- ) rot set-nth ;
: mutate-nth-of ( i val seq -- ) swapd set-nth ;
-: mutate-at-nth-of ( val i seq -- ) set-nth ;
+: mutate-nth-at-of ( val i seq -- ) set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From a245dcb0c9bbd5a88a9eda47470acc58c608d618 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 4 Apr 2008 12:40:25 -0500
Subject: [PATCH 140/288] builder: up bootstrap timeout to 60 minutes (yikes!)
---
extra/builder/builder.factor | 12 +-----------
1 file changed, 1 insertion(+), 11 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index c555233410..d335403b2c 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -13,8 +13,6 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : cd ( path -- ) current-directory set ;
-
: cd ( path -- ) set-current-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -56,18 +54,10 @@ IN: builder
[ "make" ]
if ;
-! : do-make-clean ( -- ) { "make" "clean" } try-process ;
-
: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : make-vm ( -- desc )
-! <process>
-! { "make" } >>command
-! "../compile-log" >>stdout
-! +stdout+ >>stderr ;
-
: make-vm ( -- desc )
<process>
{ gnu-make } to-strings >>command
@@ -94,7 +84,7 @@ IN: builder
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
- 20 minutes >>timeout ;
+ 60 minutes >>timeout ;
: do-bootstrap ( -- )
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
From 5f50c1cbffbac2e3d3b91d810a252b193a772bf8 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 4 Apr 2008 15:22:21 -0500
Subject: [PATCH 141/288] builder: update to handle latest changes
---
extra/builder/builder.factor | 8 ++----
extra/builder/release/release.factor | 26 +++++++++---------
extra/builder/test/test.factor | 41 ++++++++++++----------------
3 files changed, 34 insertions(+), 41 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index d335403b2c..141a78304a 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -49,7 +49,7 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gnu-make ( -- string )
- os { "freebsd" "openbsd" "netbsd" } member?
+ os { freebsd openbsd netbsd } member?
[ "gmake" ]
[ "make" ]
if ;
@@ -118,8 +118,8 @@ SYMBOL: build-status
"report" utf8
[
"Build machine: " write host-name print
- "CPU: " write cpu print
- "OS: " write os print
+ "CPU: " write cpu .
+ "OS: " write os .
"Build directory: " write current-directory get print
git-clone [ "git clone failed" print ] run-or-bail
@@ -148,8 +148,6 @@ SYMBOL: build-status
"Did not pass test-all: " print "test-all-vocabs" cat
"test-failures" cat
-! "test-failures" eval-file test-failures.
-
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks.
diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor
index d76eda8013..9b449a51c5 100644
--- a/extra/builder/release/release.factor
+++ b/extra/builder/release/release.factor
@@ -1,6 +1,6 @@
USING: kernel system namespaces sequences splitting combinators
- io io.files io.launcher
+ io io.files io.launcher prettyprint
bake combinators.cleave builder.common builder.util ;
IN: builder.release
@@ -33,22 +33,22 @@ IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cpu- ( -- cpu ) cpu "." split "-" join ;
+: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ;
+: base-name ( -- string )
+ { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: extension ( -- extension )
- os
{
- { "linux" [ ".tar.gz" ] }
- { "winnt" [ ".zip" ] }
- { "macosx" [ ".dmg" ] }
+ { [ os winnt? ] [ ".zip" ] }
+ { [ os macosx? ] [ ".dmg" ] }
+ { [ os unix? ] [ ".tar.gz" ] }
}
- case ;
+ cond ;
: archive-name ( -- string ) base-name extension append ;
@@ -69,9 +69,9 @@ IN: builder.release
: archive-cmd ( -- cmd )
{
- { [ windows? ] [ windows-archive-cmd ] }
- { [ macosx? ] [ macosx-archive-cmd ] }
- { [ unix? ] [ unix-archive-cmd ] }
+ { [ os windows? ] [ windows-archive-cmd ] }
+ { [ os macosx? ] [ macosx-archive-cmd ] }
+ { [ os unix? ] [ unix-archive-cmd ] }
}
cond ;
@@ -83,13 +83,13 @@ IN: builder.release
{ "rm" "-rf" common-files } to-strings try-process ;
: remove-factor-app ( -- )
- macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
+ os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode
-: platform ( -- string ) { os cpu- } to-strings "-" join ;
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
: remote-location ( -- dest )
"factorcode.org:/var/www/factorcode.org/newsite/downloads"
diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor
index 3634082f56..d5c3e9cd94 100644
--- a/extra/builder/test/test.factor
+++ b/extra/builder/test/test.factor
@@ -1,40 +1,35 @@
-USING: kernel namespaces sequences assocs builder continuations
- vocabs vocabs.loader
- io
- io.files
- prettyprint
- tools.vocabs
- tools.test
- io.encodings.utf8
- combinators.cleave
+! USING: kernel namespaces sequences assocs continuations
+! vocabs vocabs.loader
+! io
+! io.files
+! prettyprint
+! tools.vocabs
+! tools.test
+! io.encodings.utf8
+! combinators.cleave
+! help.lint
+! bootstrap.stage2 benchmark builder.util ;
+
+USING: kernel namespaces assocs
+ io.files io.encodings.utf8 prettyprint
help.lint
- bootstrap.stage2 benchmark builder.util ;
+ benchmark
+ bootstrap.stage2
+ tools.test tools.vocabs
+ builder.util ;
IN: builder.test
: do-load ( -- )
try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
-! : do-tests ( -- )
-! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
-
: do-tests ( -- )
run-all-tests
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
bi ;
-! : do-tests ( -- )
-! run-all-tests
-! "../test-all-vocabs" utf8
-! [
-! [ keys . ]
-! [ test-failures. ]
-! bi
-! ]
-! with-file-writer ;
-
: do-help-lint ( -- )
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
From fa15df31890ee5edc0574f87590e791829e59896 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 4 Apr 2008 16:21:45 -0500
Subject: [PATCH 142/288] fix unit test
---
extra/io/windows/nt/files/files-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor
index 1e6268fbc0..a08241ad1b 100755
--- a/extra/io/windows/nt/files/files-tests.factor
+++ b/extra/io/windows/nt/files/files-tests.factor
@@ -1,5 +1,5 @@
USING: io.files kernel tools.test io.backend
-io.windows.nt.files splitting sequences ;
+io.windows.nt.files splitting sequences io.files.private ;
IN: io.windows.nt.files.tests
[ f ] [ "\\foo" absolute-path? ] unit-test
From 979d0b7dfedd7930addfd8c3c3db61fd4bd39132 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 19:30:04 -0500
Subject: [PATCH 143/288] Fixing unit tests
---
core/compiler/tests/templates-early.factor | 4 ++--
extra/io/windows/nt/files/files-tests.factor | 4 +---
2 files changed, 3 insertions(+), 5 deletions(-)
diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor
index 71da9436f1..004d088343 100755
--- a/core/compiler/tests/templates-early.factor
+++ b/core/compiler/tests/templates-early.factor
@@ -2,7 +2,7 @@
IN: compiler.tests
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
-words kernel math effects definitions compiler.units ;
+words kernel math effects definitions compiler.units accessors ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
@@ -178,7 +178,7 @@ SYMBOL: template-chosen
] unit-test
[ t ] [
- phantom-datastack get [ cached? ] all?
+ phantom-datastack get stack>> [ cached? ] all?
] unit-test
! >r
diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor
index a08241ad1b..0fa4b4151c 100755
--- a/extra/io/windows/nt/files/files-tests.factor
+++ b/extra/io/windows/nt/files/files-tests.factor
@@ -1,5 +1,5 @@
USING: io.files kernel tools.test io.backend
-io.windows.nt.files splitting sequences io.files.private ;
+io.windows.nt.files splitting sequences ;
IN: io.windows.nt.files.tests
[ f ] [ "\\foo" absolute-path? ] unit-test
@@ -27,8 +27,6 @@ IN: io.windows.nt.files.tests
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
-[ ] [ "" resource-path cd ] unit-test
-
[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
From d046c3b614bc78cbd4cb468c018f0ae6d6f50e8d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 19:40:08 -0500
Subject: [PATCH 144/288] Documentation updates
---
core/classes/builtin/builtin-docs.factor | 4 ++--
core/classes/tuple/tuple-docs.factor | 2 +-
core/classes/tuple/tuple.factor | 4 ++--
core/parser/parser-docs.factor | 6 +++---
core/prettyprint/sections/sections-docs.factor | 5 +++--
5 files changed, 11 insertions(+), 10 deletions(-)
diff --git a/core/classes/builtin/builtin-docs.factor b/core/classes/builtin/builtin-docs.factor
index 6c5c262087..054587ff14 100644
--- a/core/classes/builtin/builtin-docs.factor
+++ b/core/classes/builtin/builtin-docs.factor
@@ -13,9 +13,9 @@ HELP: builtin-class
{ $class-description "The class of built-in classes." }
{ $examples
"The class of arrays is a built-in class:"
- { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
+ { $example "USING: arrays classes.builtin prettyprint ;" "array builtin-class? ." "t" }
"However, an instance of the array class is not a built-in class; it is not even a class:"
- { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
+ { $example "USING: classes.builtin prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
} ;
HELP: builtins
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 4ee72cdf83..5d35afb7d3 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -296,7 +296,7 @@ HELP: tuple-slots
{ tuple-slots tuple>array } related-words
HELP: define-tuple-slots
-{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
+{ $values { "class" tuple-class } }
{ $description "Defines slot accessor and mutator words for the tuple." }
$low-level-note ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 546f7b15e8..8b5972417d 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -40,7 +40,7 @@ PRIVATE>
>r copy-tuple-slots r>
layout-class prefix ;
-: tuple-slots ( tuple -- array )
+: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( tuple class -- array )
@@ -48,7 +48,7 @@ PRIVATE>
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
] keep ;
-: >tuple ( tuple -- array )
+: >tuple ( tuple -- seq )
unclip slots>tuple ;
: slot-names ( class -- seq )
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 61fd9f7f30..5adecca206 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -1,7 +1,7 @@
USING: help.markup help.syntax kernel sequences words
math strings vectors quotations generic effects classes
vocabs.loader definitions io vocabs source-files
-quotations namespaces compiler.units ;
+quotations namespaces compiler.units assocs ;
IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
@@ -446,8 +446,8 @@ HELP: eval
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
HELP: filter-moved
-{ $values { "assoc" "an assoc where the keys are definitions" } { "newassoc" "an assoc where the keys are definitions" } }
-{ $description "Removes all definitions from the assoc which are no longer present in the current " { $link file } "." } ;
+{ $values { "assoc1" assoc } { "assoc2" assoc } { "seq" "an seqence of definitions" } }
+{ $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ;
HELP: forget-smudged
{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor
index b07e83d0d1..bb1752b72e 100755
--- a/core/prettyprint/sections/sections-docs.factor
+++ b/core/prettyprint/sections/sections-docs.factor
@@ -1,6 +1,7 @@
USING: prettyprint io kernel help.markup help.syntax
-prettyprint.sections prettyprint.config words hashtables math
+prettyprint.config words hashtables math
strings definitions ;
+IN: prettyprint.sections
HELP: position
{ $var-description "The prettyprinter's current character position." } ;
@@ -78,7 +79,7 @@ HELP: section
} } ;
HELP: construct-section
-{ $values { "style" hashtable } { "length" integer } { "section" section } }
+{ $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } }
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
HELP: <indent
From 886ab8b18e7d8fa5c968c37c144ed7acd62fe466 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Fri, 4 Apr 2008 21:14:24 -0500
Subject: [PATCH 145/288] builder: fix minor bug
---
extra/builder/builder.factor | 59 +++++++++++++++++++++++++-----------
1 file changed, 41 insertions(+), 18 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 141a78304a..8e9565f82a 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -2,7 +2,7 @@
USING: kernel namespaces sequences splitting system combinators continuations
parser io io.files io.launcher io.sockets prettyprint threads
bootstrap.image benchmark vars bake smtp builder.util accessors
- io.encodings.utf8
+ debugger io.encodings.utf8
calendar
tools.test
builder.common
@@ -17,10 +17,18 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: builds/factor ( -- path ) builds "factor" append-path ;
+: build-dir ( -- path ) builds stamp> append-path ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: prepare-build-machine ( -- )
builds make-directory
- builds cd
- { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
+ builds
+ [
+ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process
+ ]
+ with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -70,8 +78,8 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: copy-image ( -- )
- builds "factor" append-path my-boot-image-name append-path ".." copy-file-into
- builds "factor" append-path my-boot-image-name append-path "." copy-file-into ;
+ builds/factor my-boot-image-name append-path ".." copy-file-into
+ builds/factor my-boot-image-name append-path "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -184,15 +192,27 @@ SYMBOL: builder-recipients
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: compress-image ( -- )
- { "bzip2" my-boot-image-name } to-strings run-process drop ;
+: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
+
+! : build ( -- )
+! [ (build) ] try
+! builds cd stamp> cd
+! [ send-builder-email ] try
+! { "rm" "-rf" "factor" } [ ] run-or-bail
+! [ compress-image ] try ;
: build ( -- )
- [ (build) ] failsafe
- builds cd stamp> cd
- [ send-builder-email ] [ drop "not sending mail" . ] recover
- { "rm" "-rf" "factor" } run-process drop
- [ compress-image ] failsafe ;
+ [
+ (build)
+ build-dir
+ [
+ { "rm" "-rf" "factor" } try-process
+ compress-image
+ ]
+ with-directory
+ ]
+ try
+ send-builder-email ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -209,7 +229,7 @@ USE: bootstrap.image.download
: updates-available? ( -- ? )
git-id
- git-pull run-process drop
+ git-pull try-process
git-id
= not ;
@@ -222,12 +242,15 @@ USE: bootstrap.image.download
: build-loop ( -- )
builds-check
[
- builds "/factor" append cd
- updates-available? new-image-available? or
- [ build ]
- when
+ builds/factor
+ [
+ updates-available? new-image-available? or
+ [ build ]
+ when
+ ]
+ with-directory
]
- failsafe
+ try
5 minutes sleep
build-loop ;
From 3bd09a2d9a4975bd3f2a69297b9aa349ec6266e1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 21:37:05 -0500
Subject: [PATCH 146/288] Removing obsolete directory
---
extra/cel-shading/authors.txt | 1 -
extra/cel-shading/summary.txt | 1 -
extra/cel-shading/tags.txt | 3 ---
3 files changed, 5 deletions(-)
delete mode 100644 extra/cel-shading/authors.txt
delete mode 100644 extra/cel-shading/summary.txt
delete mode 100644 extra/cel-shading/tags.txt
diff --git a/extra/cel-shading/authors.txt b/extra/cel-shading/authors.txt
deleted file mode 100644
index 6a0dc7293a..0000000000
--- a/extra/cel-shading/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Joe Groff
\ No newline at end of file
diff --git a/extra/cel-shading/summary.txt b/extra/cel-shading/summary.txt
deleted file mode 100644
index 60da092f6d..0000000000
--- a/extra/cel-shading/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Stanford Bunny rendered with a cel-shading GLSL program
\ No newline at end of file
diff --git a/extra/cel-shading/tags.txt b/extra/cel-shading/tags.txt
deleted file mode 100644
index 0db7e8e629..0000000000
--- a/extra/cel-shading/tags.txt
+++ /dev/null
@@ -1,3 +0,0 @@
-demos
-opengl
-glsl
\ No newline at end of file
From 315b46774883a91ea5b0689c7ce6b7049c3c6f5c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 21:44:39 -0500
Subject: [PATCH 147/288] Add debug messages
---
vm/data_gc.c | 73 ++++++++++++++++++++++++++++++++++++++--------------
vm/data_gc.h | 3 ++-
vm/debug.c | 10 +++----
vm/debug.h | 1 +
vm/master.h | 2 +-
5 files changed, 62 insertions(+), 27 deletions(-)
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 24f7cfecb9..372409c990 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -1,5 +1,20 @@
#include "master.h"
+#define GC_DEBUG 1
+
+#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld\n"
+#define GC_REQUESTED "garbage_collection: code_gc=%d, growing_data_heap=%d, requested_bytes=%ld\n"
+#define BEGIN_GC "begin_gc: code_gc=%d, growing_data_heap=%d, collecting_gen=%ld\n"
+#define END_GC "end_gc: gc_elapsed=%ld\n"
+#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n"
+#define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n"
+
+#ifdef GC_DEBUG
+ #define GC_PRINT printf
+#else
+ INLINE void GC_PRINT(...) { }
+#endif
+
CELL init_zone(F_ZONE *z, CELL size, CELL start)
{
z->size = size;
@@ -16,6 +31,8 @@ void init_cards_offset(void)
F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size)
{
+ GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size);
+
young_size = align_page(young_size);
aging_size = align_page(aging_size);
@@ -133,7 +150,8 @@ void init_data_heap(CELL gens,
extra_roots = extra_roots_region->start - CELLS;
gc_time = 0;
- minor_collections = 0;
+ aging_collections = 0;
+ nursery_collections = 0;
cards_scanned = 0;
secure_gc = secure_gc_;
}
@@ -618,16 +636,14 @@ void begin_gc(CELL requested_bytes)
so we set the newspace so the next generation. */
newspace = &data_heap->generations[collecting_gen + 1];
}
-}
-void major_gc_message(void)
-{
- fprintf(stderr,"*** %s GC (%ld minor, %ld cards)\n",
- collecting_code ? "Code and data" : "Data",
- minor_collections,cards_scanned);
- fflush(stderr);
- minor_collections = 0;
- cards_scanned = 0;
+#ifdef GC_DEBUG
+ //printf("\n");
+ dump_generations();
+ printf("Newspace: ");
+ dump_zone(newspace);
+ //printf("\n");
+#endif;
}
void end_gc(void)
@@ -637,9 +653,6 @@ void end_gc(void)
dealloc_data_heap(old_data_heap);
old_data_heap = NULL;
growing_data_heap = false;
-
- fprintf(stderr,"*** Data heap resized to %lu bytes\n",
- data_heap->segment->size);
}
if(collecting_accumulation_gen_p())
@@ -651,9 +664,19 @@ void end_gc(void)
reset_generations(NURSERY,collecting_gen - 1);
if(collecting_gen == TENURED)
- major_gc_message();
+ {
+ GC_PRINT(END_AGING_GC,aging_collections,cards_scanned);
+ aging_collections = 0;
+ cards_scanned = 0;
+ }
else if(HAVE_AGING_P && collecting_gen == AGING)
- minor_collections++;
+ {
+ aging_collections++;
+
+ GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned);
+ nursery_collections = 0;
+ cards_scanned = 0;
+ }
}
else
{
@@ -661,7 +684,7 @@ void end_gc(void)
collected are now empty */
reset_generations(NURSERY,collecting_gen);
- minor_collections++;
+ nursery_collections++;
}
if(collecting_code)
@@ -688,6 +711,8 @@ void garbage_collection(CELL gen,
return;
}
+ GC_PRINT(GC_REQUESTED,code_gc,growing_data_heap_,requested_bytes);
+
s64 start = current_millis();
performing_gc = true;
@@ -702,11 +727,15 @@ void garbage_collection(CELL gen,
resort to growing the data heap */
if(collecting_gen == TENURED)
{
- growing_data_heap = true;
-
- /* see the comment in unmark_marked() */
if(collecting_code)
+ {
+ growing_data_heap = true;
+
+ /* see the comment in unmark_marked() */
unmark_marked(&code_heap);
+ }
+ else
+ collecting_code = true;
}
/* we try collecting AGING space twice before going on to
collect TENURED */
@@ -723,6 +752,7 @@ void garbage_collection(CELL gen,
}
}
+ GC_PRINT(BEGIN_GC,collecting_code,growing_data_heap,collecting_gen);
begin_gc(requested_bytes);
/* initialize chase pointer */
@@ -754,9 +784,12 @@ void garbage_collection(CELL gen,
while(scan < newspace->here)
scan = collect_next(scan);
+ CELL gc_elapsed = (current_millis() - start);
+
+ GC_PRINT(END_GC,gc_elapsed);
end_gc();
- gc_time += (current_millis() - start);
+ gc_time += gc_elapsed;
performing_gc = false;
}
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 8f93ce79a1..77d54854d7 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -138,7 +138,8 @@ void init_data_heap(CELL gens,
/* statistics */
s64 gc_time;
-CELL minor_collections;
+CELL nursery_collections;
+CELL aging_collections;
CELL cards_scanned;
/* only meaningful during a GC */
diff --git a/vm/debug.c b/vm/debug.c
index 101313a5ee..145004f113 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -218,10 +218,10 @@ void dump_memory(CELL from, CELL to)
dump_cell(from);
}
-void dump_zone(F_ZONE z)
+void dump_zone(F_ZONE *z)
{
- printf("start=%lx, size=%lx, end=%lx, here=%lx\n",
- z.start,z.size,z.end,z.here - z.start);
+ printf("start=%ld, size=%ld, here=%ld\n",
+ z->start,z->size,z->here - z->start);
}
void dump_generations(void)
@@ -230,13 +230,13 @@ void dump_generations(void)
for(i = 0; i < data_heap->gen_count; i++)
{
printf("Generation %d: ",i);
- dump_zone(data_heap->generations[i]);
+ dump_zone(&data_heap->generations[i]);
}
for(i = 0; i < data_heap->gen_count; i++)
{
printf("Semispace %d: ",i);
- dump_zone(data_heap->semispaces[i]);
+ dump_zone(&data_heap->semispaces[i]);
}
printf("Cards: base=%lx, size=%lx\n",
diff --git a/vm/debug.h b/vm/debug.h
index ff8075c457..2ca6f8944c 100755
--- a/vm/debug.h
+++ b/vm/debug.h
@@ -2,5 +2,6 @@ void print_obj(CELL obj);
void print_nested_obj(CELL obj, F_FIXNUM nesting);
void dump_generations(void);
void factorbug(void);
+void dump_zone(F_ZONE *z);
DECLARE_PRIMITIVE(die);
diff --git a/vm/master.h b/vm/master.h
index 178c8fc7ff..0f4daa705b 100644
--- a/vm/master.h
+++ b/vm/master.h
@@ -20,13 +20,13 @@
#include "layouts.h"
#include "platform.h"
#include "primitives.h"
-#include "debug.h"
#include "run.h"
#include "profiler.h"
#include "errors.h"
#include "bignumint.h"
#include "bignum.h"
#include "data_gc.h"
+#include "debug.h"
#include "types.h"
#include "math.h"
#include "float_bits.h"
From 4139f0e8046c3803761b59ed706900af5f6fe524 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 22:22:38 -0500
Subject: [PATCH 148/288] Fix set-current-directory
---
core/io/files/files.factor | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index ed1b94e556..6719d1334c 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -205,12 +205,11 @@ SYMBOL: current-directory
M: object normalize-path ( path -- path' )
(normalize-path) ;
-: with-directory ( path quot -- )
- >r (normalize-path) r>
- current-directory swap with-variable ; inline
-
: set-current-directory ( path -- )
- normalize-path current-directory set ;
+ (normalize-path) current-directory set ;
+
+: with-directory ( path quot -- )
+ >r (normalize-path) current-directory r> with-variable ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
From 6a823c4a698c8b0a8bf91d5dfd8c0d7cf70796f6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 22:40:37 -0500
Subject: [PATCH 149/288] Windows launcher fix
---
extra/io/windows/launcher/launcher.factor | 3 ++-
extra/io/windows/nt/launcher/launcher.factor | 2 ++
2 files changed, 4 insertions(+), 1 deletion(-)
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 07ce6c308a..6185159ddc 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -116,9 +116,10 @@ M: windows current-process-handle ( -- handle )
M: windows run-process* ( process -- handle )
[
+ current-directory get (normalize-path) cd
+
dup make-CreateProcess-args
tuck fill-redirection
- current-directory get (normalize-path) cd
dup call-CreateProcess
lpProcessInformation>>
] with-destructors ;
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index 4bbf7c8e32..3aa2a9994b 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -120,6 +120,8 @@ M: winnt fill-redirection ( process args -- )
M: winnt (process-stream)
[
+ current-directory get (normalize-path) cd
+
dup make-CreateProcess-args
fill-stdout-pipe
From 3eeffbb10456e8b58c681635d60f23690ecbf120 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 22:40:48 -0500
Subject: [PATCH 150/288] Disable logging for now
---
vm/code_gc.c | 1 +
vm/data_gc.c | 15 ++++++++++-----
2 files changed, 11 insertions(+), 5 deletions(-)
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 5b0d2ebabb..54979b8a01 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -181,6 +181,7 @@ void free_unmarked(F_HEAP *heap)
}
break;
case B_FREE:
+ printf("RECLAIMED\n");
if(prev && prev->status == B_FREE)
prev->size += scan->size;
break;
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 372409c990..9f6b06a528 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -1,6 +1,6 @@
#include "master.h"
-#define GC_DEBUG 1
+//#define GC_DEBUG 1
#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld\n"
#define GC_REQUESTED "garbage_collection: code_gc=%d, growing_data_heap=%d, requested_bytes=%ld\n"
@@ -12,7 +12,7 @@
#ifdef GC_DEBUG
#define GC_PRINT printf
#else
- INLINE void GC_PRINT(...) { }
+ INLINE void GC_PRINT() { }
#endif
CELL init_zone(F_ZONE *z, CELL size, CELL start)
@@ -584,7 +584,10 @@ CELL collect_next(CELL scan)
do_slots(scan,copy_handle);
if(collecting_code)
+ {
+ printf("do_code_slots\n");
do_code_slots(scan);
+ }
return scan + untagged_object_size(scan);
}
@@ -720,6 +723,8 @@ void garbage_collection(CELL gen,
growing_data_heap = growing_data_heap_;
collecting_gen = gen;
+ //if(collecting_gen == TENURED) collecting_code = true;
+
/* we come back here if a generation is full */
if(setjmp(gc_jmp))
{
@@ -727,15 +732,15 @@ void garbage_collection(CELL gen,
resort to growing the data heap */
if(collecting_gen == TENURED)
{
- if(collecting_code)
+ //if(collecting_code)
{
growing_data_heap = true;
/* see the comment in unmark_marked() */
unmark_marked(&code_heap);
}
- else
- collecting_code = true;
+ //else
+ // collecting_code = true;
}
/* we try collecting AGING space twice before going on to
collect TENURED */
From 21831d2c1624ea58d819f51f2192d9a6a287accc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 22:49:19 -0500
Subject: [PATCH 151/288] Fix Unix launcher with current directory
---
extra/io/unix/launcher/launcher.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 5f0a9b96cb..9abedf38ac 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -70,7 +70,7 @@ USE: unix
[
setup-priority
setup-redirection
- current-directory get resource-path cd
+ current-directory get (normalize-path) cd
dup pass-environment? [
dup get-environment set-os-envs
] when
From 5a4b5b01f96a7283d48d784fb6b6bcb0cb89e69f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Apr 2008 22:59:23 -0500
Subject: [PATCH 152/288] Fix using
---
extra/io/windows/nt/launcher/launcher.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index 3aa2a9994b..a01ba4698e 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -4,8 +4,8 @@ USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings
-io.windows.launcher io.windows.nt.pipes io.backend
-combinators shuffle accessors locals ;
+io.windows.launcher io.windows.nt.pipes io.backend io.files
+io.files.private combinators shuffle accessors locals ;
IN: io.windows.nt.launcher
: duplicate-handle ( handle -- handle' )
From fe797265ec2b033a3af85840b84df94b93210946 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Fri, 4 Apr 2008 23:14:40 -0500
Subject: [PATCH 153/288] Working on delegate
---
extra/delegate/delegate-tests.factor | 30 ++++++++----
extra/delegate/delegate.factor | 68 +++++++++++++++++++++-------
2 files changed, 73 insertions(+), 25 deletions(-)
diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor
index 2a0e013c1a..8563c12b75 100644
--- a/extra/delegate/delegate-tests.factor
+++ b/extra/delegate/delegate-tests.factor
@@ -1,4 +1,5 @@
-USING: delegate kernel arrays tools.test words math ;
+USING: delegate kernel arrays tools.test words math definitions
+compiler.units parser generic prettyprint io.streams.string ;
IN: delegate.tests
DEFER: example
@@ -6,7 +7,6 @@ DEFER: example
[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
[ 2 ] [ \ example "prop" word-prop ] unit-test
-
TUPLE: hello this that ;
C: <hello> hello
@@ -17,17 +17,29 @@ GENERIC: foo ( x -- y )
GENERIC: bar ( a -- b )
PROTOCOL: baz foo bar ;
+: hello-test ( hello/goodbye -- array )
+ [ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
+
CONSULT: baz goodbye goodbye-these ;
M: hello foo hello-this ;
-M: hello bar dup hello? swap hello-that 2array ;
+M: hello bar hello-test ;
GENERIC: bing ( c -- d )
-CONSULT: hello goodbye goodbye-these ;
-M: hello bing dup hello? swap hello-that 2array ;
+CONSULT: hello goodbye goodbye-those ;
+M: hello bing hello-test ;
MIMIC: bing goodbye hello
-[ 1 { t 0 } ] [ 1 0 <hello> [ foo ] keep bar ] unit-test
-[ { t 0 } ] [ 1 0 <hello> bing ] unit-test
+[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
+[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
-[ { t 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
-[ { f 0 } ] [ 1 0 <hello> f <goodbye> bing ] unit-test
+[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
+[ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
+
+[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
+[ V{ goodbye } ] [ baz protocol-users ] unit-test
+
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar ;\n" ]
+[ [ baz see ] with-string-writer ] unit-test
+
+! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
+! [ f ] [ goodbye baz method ] unit-test
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index fc62c290df..a32a44db0f 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -1,17 +1,50 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
-vectors ;
+vectors definitions prettyprint ;
IN: delegate
-: define-protocol ( wordlist protocol -- )
- swap { } like "protocol-words" set-word-prop ;
+! Protocols
+
+: cross-2each ( seq1 seq2 quot -- )
+ [ with each ] 2curry each ; inline
+
+: forget-all-methods ( classes words -- )
+ [ 2array forget ] cross-2each ;
+
+: protocol-words ( protocol -- words )
+ "protocol-words" word-prop ;
+
+: protocol-users ( protocol -- users )
+ "protocol-users" word-prop ;
+
+: users-and-words ( protocol -- users words )
+ [ protocol-users ] [ protocol-words ] bi ;
+
+: forget-old-definitions ( protocol new-wordlist -- )
+ >r users-and-words r>
+ seq-diff forget-all-methods ;
+
+: define-protocol ( protocol wordlist -- )
+ 2dup forget-old-definitions
+ { } like "protocol-words" set-word-prop ;
: PROTOCOL:
- CREATE-WORD dup define-symbol
- parse-definition swap define-protocol ; parsing
+ CREATE-WORD
+ dup define-symbol
+ dup f "inline" set-word-prop
+ parse-definition define-protocol ; parsing
-PREDICATE: protocol < word "protocol-words" word-prop ;
+PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
+
+M: protocol forget*
+ [ users-and-words forget-all-methods ] [ call-next-method ] bi ;
+
+M: protocol definition protocol-words ;
+
+M: protocol definer drop \ PROTOCOL: \ ; ;
+
+M: protocol synopsis* word-synopsis ; ! Necessary?
GENERIC: group-words ( group -- words )
@@ -22,22 +55,23 @@ M: generic group-words
1array ;
M: tuple-class group-words
- "slots" word-prop 1 tail ! The first slot is the delegate
- ! 1 tail should be removed when the delegate slot is removed
- dup [ slot-spec-reader ] map
- swap [ slot-spec-writer ] map append ;
+ "slots" word-prop
+ [ [ slot-spec-reader ] map ]
+ [ [ slot-spec-writer ] map ] bi append ;
+
+! Consultation
: define-consult-method ( word class quot -- )
pick suffix >r swap create-method r> define ;
-: 3bi ( x y z p q -- p(x,y,z) q(x,y,z) )
- >r 3keep r> call ; inline
-
: change-word-prop ( word prop quot -- )
>r swap word-props r> change-at ; inline
+: add ( item vector/f -- vector )
+ 2dup member? [ nip ] [ ?push ] if ;
+
: declare-consult ( class group -- )
- "protocol-users" [ ?push ] change-word-prop ;
+ "protocol-users" [ add ] change-word-prop ;
: define-consult ( class group quot -- )
>r 2dup declare-consult group-words swap r>
@@ -46,10 +80,12 @@ M: tuple-class group-words
: CONSULT:
scan-word scan-word parse-definition swapd define-consult ; parsing
+! Mimic still needs to be updated
+
: define-mimic ( group mimicker mimicked -- )
- >r >r group-words r> r> [
+ rot group-words -rot [
pick "methods" word-prop at dup
- [ >r swap create-method r> word-def define ]
+ [ >r swap create-method-in r> word-def define ]
[ 3drop ] if
] 2curry each ;
From 8b16816bf8ae66e0a3ffa0d22fd0376ee2aee974 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 17:15:43 +1300
Subject: [PATCH 154/288] Refactor satisfy peg parser
---
extra/peg/peg.factor | 27 +++++++++++++--------------
1 file changed, 13 insertions(+), 14 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 3828fe7d9e..8b4991eef3 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings namespaces math assocs shuffle
+USING: kernel sequences strings fry namespaces math assocs shuffle
vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser
words quotations effects memoize accessors locals effects ;
@@ -282,21 +282,20 @@ TUPLE: satisfy-parser quot ;
MATCH-VARS: ?quot ;
-: satisfy-pattern ( -- quot )
- [
- input-slice dup empty? [
- drop f
- ] [
- unclip-slice dup ?quot call [
- <parse-result>
- ] [
- 2drop f
- ] if
- ] if
- ] ;
+: parse-satisfy ( input quot -- result )
+ swap dup empty? [
+ 2drop f
+ ] [
+ unclip-slice rot dupd call [
+ <parse-result>
+ ] [
+ 2drop f
+ ] if
+ ] if ; inline
+
M: satisfy-parser (compile) ( parser -- quot )
- quot>> \ ?quot satisfy-pattern match-replace ;
+ quot>> '[ input-slice , parse-satisfy ] ;
TUPLE: range-parser min max ;
From 80d11405a980c2d21d1a5b7b34ddab1368fdbc44 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 17:25:04 +1300
Subject: [PATCH 155/288] Refactor token peg parser
---
extra/peg/peg.factor | 14 +++++++-------
1 file changed, 7 insertions(+), 7 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 8b4991eef3..5ee497707d 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -3,7 +3,7 @@
USING: kernel sequences strings fry namespaces math assocs shuffle
vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser
- words quotations effects memoize accessors locals effects ;
+ words quotations effects memoize accessors locals effects splitting ;
IN: peg
USE: prettyprint
@@ -269,19 +269,17 @@ MATCH-VARS: ?token ;
: parse-token ( input string -- result )
#! Parse the string, returning a parse result
- 2dup head? [
- dup >r length tail-slice r> <parse-result>
+ dup >r ?head-slice [
+ r> <parse-result>
] [
- 2drop f
+ r> 2drop f
] if ;
M: token-parser (compile) ( parser -- quot )
- [ \ input-slice , symbol>> , \ parse-token , ] [ ] make ;
+ symbol>> '[ input-slice , parse-token ] ;
TUPLE: satisfy-parser quot ;
-MATCH-VARS: ?quot ;
-
: parse-satisfy ( input quot -- result )
swap dup empty? [
2drop f
@@ -320,6 +318,8 @@ M: range-parser (compile) ( parser -- quot )
TUPLE: seq-parser parsers ;
+MATCH-VARS: ?quot ;
+
: seq-pattern ( -- quot )
[
dup [
From 7b73d2734fde7387c060816ceee79977404d0671 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 17:30:10 +1300
Subject: [PATCH 156/288] Refactor range peg parser
---
extra/peg/peg.factor | 25 ++++++++++---------------
1 file changed, 10 insertions(+), 15 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 5ee497707d..671b63949f 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -297,24 +297,19 @@ M: satisfy-parser (compile) ( parser -- quot )
TUPLE: range-parser min max ;
-MATCH-VARS: ?min ?max ;
-
-: range-pattern ( -- quot )
- [
- input-slice dup empty? [
+: parse-range ( input min max -- result )
+ pick empty? [
+ 3drop f
+ ] [
+ pick first -rot between? [
+ unclip-slice <parse-result>
+ ] [
drop f
- ] [
- 0 over nth dup
- ?min ?max between? [
- [ 1 tail-slice ] dip <parse-result>
- ] [
- 2drop f
- ] if
- ] if
- ] ;
+ ] if
+ ] if ;
M: range-parser (compile) ( parser -- quot )
- T{ range-parser _ ?min ?max } range-pattern match-replace ;
+ [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ;
TUPLE: seq-parser parsers ;
From 102178f787aabd5f5e4ca6f9f3e2c61d3447eb91 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 17:51:42 +1300
Subject: [PATCH 157/288] Refactor seq peg parser
---
extra/peg/peg.factor | 38 +++++++++++++++++++++-----------------
1 file changed, 21 insertions(+), 17 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 671b63949f..8c92605c44 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -313,34 +313,38 @@ M: range-parser (compile) ( parser -- quot )
TUPLE: seq-parser parsers ;
-MATCH-VARS: ?quot ;
+: ignore? ( ast -- bool )
+ ignore = ;
-: seq-pattern ( -- quot )
+: calc-seq-result ( prev-result current-result -- next-result )
[
- dup [
- ?quot [
- [ remaining>> swap (>>remaining) ] 2keep
- ast>> dup ignore = [
- drop
- ] [
- swap [ ast>> push ] keep
- ] if
- ] [
- drop f
- ] if*
+ [ remaining>> swap (>>remaining) ] 2keep
+ ast>> dup ignore? [
+ drop
] [
- drop f
- ] if
- ] ;
+ swap [ ast>> push ] keep
+ ] if
+ ] [
+ drop f
+ ] if* ;
+
+: parse-seq-element ( result quot -- result )
+ over [
+ call calc-seq-result
+ ] [
+ 2drop f
+ ] if ; inline
M: seq-parser (compile) ( parser -- quot )
[
[ input-slice V{ } clone <parse-result> ] %
- parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each
+ parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each
] [ ] make ;
TUPLE: choice-parser parsers ;
+MATCH-VARS: ?quot ;
+
: choice-pattern ( -- quot )
[
[ ?quot ] unless*
From 226d211342bef6b64354396fbcbb06e49700b5dc Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 17:54:18 +1300
Subject: [PATCH 158/288] Refactor choice peg parser
---
extra/peg/peg.factor | 11 +++--------
1 file changed, 3 insertions(+), 8 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 8c92605c44..465e0dd757 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -343,21 +343,16 @@ M: seq-parser (compile) ( parser -- quot )
TUPLE: choice-parser parsers ;
-MATCH-VARS: ?quot ;
-
-: choice-pattern ( -- quot )
- [
- [ ?quot ] unless*
- ] ;
-
M: choice-parser (compile) ( parser -- quot )
[
f ,
- parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each
+ parsers>> [ compiled-parser 1quotation , \ unless* , ] each
] [ ] make ;
TUPLE: repeat0-parser p1 ;
+MATCH-VARS: ?quot ;
+
: (repeat0) ( quot result -- result )
over call [
[ remaining>> swap (>>remaining) ] 2keep
From d4897fa007bd12dd2bd56dd7dd11cf4eeb7e885f Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 18:01:18 +1300
Subject: [PATCH 159/288] Refactor repeat0 and repeat1 peg parsers
---
extra/peg/peg.factor | 42 +++++++++++++++---------------------------
1 file changed, 15 insertions(+), 27 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 465e0dd757..8c427d5e27 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -351,48 +351,36 @@ M: choice-parser (compile) ( parser -- quot )
TUPLE: repeat0-parser p1 ;
-MATCH-VARS: ?quot ;
-
-: (repeat0) ( quot result -- result )
+: (repeat) ( quot result -- result )
over call [
[ remaining>> swap (>>remaining) ] 2keep
ast>> swap [ ast>> push ] keep
- (repeat0)
- ] [
+ (repeat)
+ ] [
nip
] if* ; inline
-: repeat0-pattern ( -- quot )
- [
- [ ?quot ] swap (repeat0)
- ] ;
-
M: repeat0-parser (compile) ( parser -- quot )
- [
- [ input-slice V{ } clone <parse-result> ] %
- p1>> compiled-parser \ ?quot repeat0-pattern match-replace %
- ] [ ] make ;
+ p1>> compiled-parser 1quotation '[
+ input-slice V{ } clone <parse-result> , swap (repeat)
+ ] ;
TUPLE: repeat1-parser p1 ;
-: repeat1-pattern ( -- quot )
+: repeat1-empty-check ( result -- result )
[
- [ ?quot ] swap (repeat0) [
- dup ast>> empty? [
- drop f
- ] when
- ] [
- f
- ] if*
- ] ;
+ dup ast>> empty? [ drop f ] when
+ ] [
+ f
+ ] if* ;
M: repeat1-parser (compile) ( parser -- quot )
- [
- [ input-slice V{ } clone <parse-result> ] %
- p1>> compiled-parser \ ?quot repeat1-pattern match-replace %
- ] [ ] make ;
+ p1>> compiled-parser 1quotation '[
+ input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
+ ] ;
TUPLE: optional-parser p1 ;
+MATCH-VARS: ?quot ;
: optional-pattern ( -- quot )
[
From 3123654a8462634914010b5135261cc4237f9661 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 18:05:09 +1300
Subject: [PATCH 160/288] Refactor optional peg parser
---
extra/peg/peg.factor | 10 ++++------
1 file changed, 4 insertions(+), 6 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 8c427d5e27..332f7164f8 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -380,17 +380,15 @@ M: repeat1-parser (compile) ( parser -- quot )
] ;
TUPLE: optional-parser p1 ;
-MATCH-VARS: ?quot ;
-: optional-pattern ( -- quot )
- [
- ?quot [ input-slice f <parse-result> ] unless*
- ] ;
+: check-optional ( result -- result )
+ [ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile) ( parser -- quot )
- p1>> compiled-parser \ ?quot optional-pattern match-replace ;
+ p1>> compiled-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ;
+MATCH-VARS: ?quot ;
MATCH-VARS: ?parser ;
From 796981e192e3a2f622be5c3bc455efd1e49bd6af Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 18:19:11 +1300
Subject: [PATCH 161/288] Refactor semantic peg parser
---
extra/peg/peg.factor | 18 ++++++++----------
1 file changed, 8 insertions(+), 10 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 332f7164f8..ab70745b11 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -392,18 +392,16 @@ MATCH-VARS: ?quot ;
MATCH-VARS: ?parser ;
-: semantic-pattern ( -- quot )
- [
- ?parser [
- dup parse-result-ast ?quot call [ drop f ] unless
- ] [
- f
- ] if*
- ] ;
+: check-semantic ( result quot -- result )
+ over [
+ over ast>> swap call [ drop f ] unless
+ ] [
+ drop
+ ] if ; inline
M: semantic-parser (compile) ( parser -- quot )
- [ p1>> compiled-parser ] [ quot>> ] bi
- 2array { ?parser ?quot } semantic-pattern match-replace ;
+ [ p1>> compiled-parser 1quotation ] [ quot>> ] bi
+ '[ @ , check-semantic ] ;
TUPLE: ensure-parser p1 ;
From 247bf2137bbb785f644219f695388426bf05c389 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 18:30:11 +1300
Subject: [PATCH 162/288] Refactor ensure and ensure-not parsers
---
extra/peg/peg.factor | 24 ++++++------------------
1 file changed, 6 insertions(+), 18 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index ab70745b11..7970d761de 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -405,31 +405,19 @@ M: semantic-parser (compile) ( parser -- quot )
TUPLE: ensure-parser p1 ;
-: ensure-pattern ( -- quot )
- [
- input-slice ?quot [
- ignore <parse-result>
- ] [
- drop f
- ] if
- ] ;
+: check-ensure ( old-input result -- result )
+ [ ignore <parse-result> ] [ drop f ] if ;
M: ensure-parser (compile) ( parser -- quot )
- p1>> compiled-parser \ ?quot ensure-pattern match-replace ;
+ p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ;
-: ensure-not-pattern ( -- quot )
- [
- input-slice ?quot [
- drop f
- ] [
- ignore <parse-result>
- ] if
- ] ;
+: check-ensure-not ( old-input result -- result )
+ [ drop f ] [ ignore <parse-result> ] if ;
M: ensure-not-parser (compile) ( parser -- quot )
- p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ;
+ p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ;
From d93c7958fdad169d99dc1ddeb1ef01cae6594b0f Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 18:33:50 +1300
Subject: [PATCH 163/288] Refactor action peg parser
---
extra/peg/peg.factor | 17 ++++++++---------
1 file changed, 8 insertions(+), 9 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 7970d761de..fd41a67bfe 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -423,17 +423,16 @@ TUPLE: action-parser p1 quot ;
MATCH-VARS: ?action ;
-: action-pattern ( -- quot )
- [
- ?quot dup [
- dup ast>> ?action call
- >>ast
- ] when
- ] ;
+: check-action ( result quot -- result )
+ over [
+ over ast>> swap call >>ast
+ ] [
+ drop
+ ] if ; inline
M: action-parser (compile) ( parser -- quot )
- [ p1>> compiled-parser ] [ quot>> ] bi
- 2array { ?quot ?action } action-pattern match-replace ;
+ [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[
+ @ , check-action ] ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
From 2744313ac14679397be74f345b63b9264b53db3b Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 18:36:17 +1300
Subject: [PATCH 164/288] Refactor sp peg parser
---
extra/peg/peg.factor | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index fd41a67bfe..22405c9cbf 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -431,8 +431,7 @@ MATCH-VARS: ?action ;
] if ; inline
M: action-parser (compile) ( parser -- quot )
- [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[
- @ , check-action ] ;
+ [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
@@ -444,9 +443,9 @@ M: action-parser (compile) ( parser -- quot )
TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( parser -- quot )
- [
- \ input-slice , \ left-trim-slice , \ input-from , \ pos , \ set , p1>> compiled-parser ,
- ] [ ] make ;
+ p1>> compiled-parser 1quotation '[
+ input-slice left-trim-slice input-from pos set @
+ ] ;
TUPLE: delay-parser quot ;
From e00a392736161a3438476a7adc6a37fdc6482f6c Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 5 Apr 2008 18:41:28 +1300
Subject: [PATCH 165/288] Refactor delay parser
---
extra/peg/peg.factor | 6 +-----
1 file changed, 1 insertion(+), 5 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 22405c9cbf..8d5d1c1560 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -453,11 +453,7 @@ M: delay-parser (compile) ( parser -- quot )
#! For efficiency we memoize the quotation.
#! This way it is run only once and the
#! parser constructed once at run time.
- [
- quot>> % \ compile ,
- ] [ ] make
- { } { "word" } <effect> memoize-quot
- [ % \ execute , ] [ ] make ;
+ quot>> '[ @ compile ] { } { "word" } <effect> memoize-quot '[ @ execute ] ;
TUPLE: box-parser quot ;
From 9f16b80f3e3a8df70efaadf62f618522d440c6e4 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Sat, 5 Apr 2008 00:43:42 -0500
Subject: [PATCH 166/288] Fixing docs typo
---
extra/io/encodings/utf16/utf16-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor
index bc0e943415..1666219db5 100644
--- a/extra/io/encodings/utf16/utf16-docs.factor
+++ b/extra/io/encodings/utf16/utf16-docs.factor
@@ -23,7 +23,7 @@ HELP: utf16
{ $see-also "encodings-introduction" } ;
HELP: utf16n
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings in of wide_t*." }
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
{ $see-also "encodings-introduction" } ;
{ utf16 utf16le utf16be utf16n } related-words
From 6842a2829d1c8ff5e9937eae784481f3221f624a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 02:08:37 -0500
Subject: [PATCH 167/288] Fixing GC
---
vm/code_gc.c | 3 +--
vm/data_gc.c | 47 +++++++++++++++++++----------------------------
vm/data_gc.h | 31 +++++++++++++++++++------------
3 files changed, 39 insertions(+), 42 deletions(-)
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 54979b8a01..8a05daf570 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -181,7 +181,6 @@ void free_unmarked(F_HEAP *heap)
}
break;
case B_FREE:
- printf("RECLAIMED\n");
if(prev && prev->status == B_FREE)
prev->size += scan->size;
break;
@@ -290,7 +289,7 @@ DEFINE_PRIMITIVE(code_room)
void code_gc(void)
{
- garbage_collection(TENURED,true,false,0);
+ garbage_collection(TENURED,false,0);
}
DEFINE_PRIMITIVE(code_gc)
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 9f6b06a528..9b4f4fd583 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -1,10 +1,10 @@
#include "master.h"
-//#define GC_DEBUG 1
+#define GC_DEBUG 0
#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld\n"
-#define GC_REQUESTED "garbage_collection: code_gc=%d, growing_data_heap=%d, requested_bytes=%ld\n"
-#define BEGIN_GC "begin_gc: code_gc=%d, growing_data_heap=%d, collecting_gen=%ld\n"
+#define GC_REQUESTED "garbage_collection: growing_data_heap=%d, requested_bytes=%ld\n"
+#define BEGIN_GC "begin_gc: growing_data_heap=%d, collecting_gen=%ld\n"
#define END_GC "end_gc: gc_elapsed=%ld\n"
#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n"
#define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n"
@@ -29,7 +29,10 @@ void init_cards_offset(void)
- (data_heap->segment->start >> CARD_BITS);
}
-F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size)
+F_DATA_HEAP *alloc_data_heap(CELL gens,
+ CELL young_size,
+ CELL aging_size,
+ CELL tenured_size)
{
GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size);
@@ -405,7 +408,7 @@ void collect_stack_frame(F_STACK_FRAME *frame)
callstack snapshot */
void collect_callstack(F_CONTEXT *stacks)
{
- if(collecting_code)
+ if(collecting_gen == TENURED)
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
@@ -583,11 +586,8 @@ CELL collect_next(CELL scan)
{
do_slots(scan,copy_handle);
- if(collecting_code)
- {
- printf("do_code_slots\n");
+ if(collecting_gen == TENURED)
do_code_slots(scan);
- }
return scan + untagged_object_size(scan);
}
@@ -641,11 +641,11 @@ void begin_gc(CELL requested_bytes)
}
#ifdef GC_DEBUG
- //printf("\n");
+ printf("\n");
dump_generations();
printf("Newspace: ");
dump_zone(newspace);
- //printf("\n");
+ printf("\n");
#endif;
}
@@ -690,7 +690,7 @@ void end_gc(void)
nursery_collections++;
}
- if(collecting_code)
+ if(collecting_gen == TENURED)
{
/* now that all reachable code blocks have been marked,
deallocate the rest */
@@ -704,7 +704,6 @@ void end_gc(void)
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
void garbage_collection(CELL gen,
- bool code_gc,
bool growing_data_heap_,
CELL requested_bytes)
{
@@ -714,17 +713,14 @@ void garbage_collection(CELL gen,
return;
}
- GC_PRINT(GC_REQUESTED,code_gc,growing_data_heap_,requested_bytes);
+ GC_PRINT(GC_REQUESTED,growing_data_heap_,requested_bytes);
s64 start = current_millis();
performing_gc = true;
- collecting_code = code_gc;
growing_data_heap = growing_data_heap_;
collecting_gen = gen;
- //if(collecting_gen == TENURED) collecting_code = true;
-
/* we come back here if a generation is full */
if(setjmp(gc_jmp))
{
@@ -732,15 +728,10 @@ void garbage_collection(CELL gen,
resort to growing the data heap */
if(collecting_gen == TENURED)
{
- //if(collecting_code)
- {
- growing_data_heap = true;
+ growing_data_heap = true;
- /* see the comment in unmark_marked() */
- unmark_marked(&code_heap);
- }
- //else
- // collecting_code = true;
+ /* see the comment in unmark_marked() */
+ unmark_marked(&code_heap);
}
/* we try collecting AGING space twice before going on to
collect TENURED */
@@ -757,7 +748,7 @@ void garbage_collection(CELL gen,
}
}
- GC_PRINT(BEGIN_GC,collecting_code,growing_data_heap,collecting_gen);
+ GC_PRINT(BEGIN_GC,growing_data_heap,collecting_gen);
begin_gc(requested_bytes);
/* initialize chase pointer */
@@ -768,7 +759,7 @@ void garbage_collection(CELL gen,
/* collect objects referenced from older generations */
collect_cards();
- if(!collecting_code)
+ if(collecting_gen != TENURED)
{
/* don't scan code heap unless it has pointers to this
generation or younger */
@@ -800,7 +791,7 @@ void garbage_collection(CELL gen,
void data_gc(void)
{
- garbage_collection(TENURED,false,false,0);
+ garbage_collection(TENURED,false,0);
}
DEFINE_PRIMITIVE(data_gc)
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 77d54854d7..ee2e51b6f8 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -145,7 +145,6 @@ CELL cards_scanned;
/* only meaningful during a GC */
bool performing_gc;
CELL collecting_gen;
-bool collecting_code;
/* if true, we collecting AGING space for the second time, so if it is still
full, we go on to collect TENURED */
@@ -222,7 +221,6 @@ CELL heap_scan_ptr;
bool gc_off;
void garbage_collection(volatile CELL gen,
- bool code_gc,
bool growing_data_heap_,
CELL requested_bytes);
@@ -308,18 +306,27 @@ allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
+#define SUFFICIENT_ROOM(a) (nursery->here + ALLOT_BUFFER_ZONE + a <= nursery->end)
+
INLINE void maybe_gc(CELL a)
{
- /* If we are requesting a huge object, grow immediately */
- if(nursery->size - ALLOT_BUFFER_ZONE <= a)
- garbage_collection(TENURED,false,true,a);
- /* If we have enough space in the nursery, just return.
- Otherwise, perform a GC - this may grow the heap if
- tenured space cannot hold all live objects from the nursery
- even after a full GC */
- else if(a + ALLOT_BUFFER_ZONE + nursery->here > nursery->end)
- garbage_collection(NURSERY,false,false,0);
- /* There is now sufficient room in the nursery for 'a' */
+ /* If there is enough room, return */
+ if(SUFFICIENT_ROOM(a))
+ return;
+ /* If the object is bigger than the nursery, grow immediately */
+ else if(nursery->size - ALLOT_BUFFER_ZONE <= a)
+ garbage_collection(TENURED,true,a);
+ /* Otherwise, collect the nursery */
+ else
+ {
+ garbage_collection(NURSERY,false,0);
+
+ /* If there is still insufficient room, try growing the heap.
+ This can only happen if the number of generations is 1. */
+ if(SUFFICIENT_ROOM(a)) return;
+
+ garbage_collection(TENURED,true,a);
+ }
}
/*
From cfa1c0201330481f072d579f1af31bed300013af Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 02:08:45 -0500
Subject: [PATCH 168/288] Add test case for GC
---
core/memory/memory-tests.factor | 11 ++++++++++-
1 file changed, 10 insertions(+), 1 deletion(-)
diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor
index 0c46e307df..0a021d1978 100755
--- a/core/memory/memory-tests.factor
+++ b/core/memory/memory-tests.factor
@@ -1,8 +1,17 @@
USING: generic kernel kernel.private math memory prettyprint
sequences tools.test words namespaces layouts classes
-classes.builtin ;
+classes.builtin arrays quotations ;
IN: memory.tests
+! Code GC wasn't kicking in when needed
+: leak-step 800000 f <array> 1quotation call drop ;
+
+: leak-loop 100 [ leak-step ] times ;
+
+[ ] [ leak-step leak-step leak-step data-gc ] unit-test
+
+[ ] [ leak-loop ] unit-test
+
TUPLE: testing x y z ;
[ save-image-and-exit ] must-fail
From 4515588b98c7cd07bee80f2979a9ca2f1dd561d6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 02:14:44 -0500
Subject: [PATCH 169/288] Fix compile error
---
vm/data_gc.c | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 9b4f4fd583..010ceb49ad 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -31,8 +31,7 @@ void init_cards_offset(void)
F_DATA_HEAP *alloc_data_heap(CELL gens,
CELL young_size,
- CELL aging_size,
- CELL tenured_size)
+ CELL aging_size)
{
GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size);
From 48d31a2ca01989bb07ca75afafee4d4d3a2648cd Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Sat, 5 Apr 2008 02:44:54 -0500
Subject: [PATCH 170/288] More changes to delegate
---
extra/delegate/delegate-tests.factor | 11 +++--
extra/delegate/delegate.factor | 49 ++++++++++++++---------
extra/delegate/protocols/protocols.factor | 6 +--
3 files changed, 38 insertions(+), 28 deletions(-)
diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor
index 8563c12b75..497a6c5120 100644
--- a/extra/delegate/delegate-tests.factor
+++ b/extra/delegate/delegate-tests.factor
@@ -15,7 +15,8 @@ C: <goodbye> goodbye
GENERIC: foo ( x -- y )
GENERIC: bar ( a -- b )
-PROTOCOL: baz foo bar ;
+GENERIC# whoa 1 ( s t -- w )
+PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
: hello-test ( hello/goodbye -- array )
[ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
@@ -23,22 +24,26 @@ PROTOCOL: baz foo bar ;
CONSULT: baz goodbye goodbye-these ;
M: hello foo hello-this ;
M: hello bar hello-test ;
+M: hello whoa >r hello-this r> + ;
GENERIC: bing ( c -- d )
+PROTOCOL: bee bing ;
CONSULT: hello goodbye goodbye-those ;
M: hello bing hello-test ;
-MIMIC: bing goodbye hello
+MIMIC: bee goodbye hello
[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
[ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
+[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
+[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ V{ goodbye } ] [ baz protocol-users ] unit-test
-[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar ;\n" ]
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
[ [ baz see ] with-string-writer ] unit-test
! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index a32a44db0f..f8e238b7db 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
-vectors definitions prettyprint ;
+vectors definitions prettyprint combinators.lib math ;
IN: delegate
! Protocols
@@ -26,21 +26,27 @@ IN: delegate
seq-diff forget-all-methods ;
: define-protocol ( protocol wordlist -- )
- 2dup forget-old-definitions
+ ! 2dup forget-old-definitions
{ } like "protocol-words" set-word-prop ;
+: fill-in-depth ( wordlist -- wordlist' )
+ [ dup word? [ 0 2array ] when ] map ;
+
: PROTOCOL:
CREATE-WORD
dup define-symbol
dup f "inline" set-word-prop
- parse-definition define-protocol ; parsing
+ parse-definition fill-in-depth define-protocol ; parsing
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol forget*
[ users-and-words forget-all-methods ] [ call-next-method ] bi ;
-M: protocol definition protocol-words ;
+: show-words ( wordlist' -- wordlist )
+ [ dup second zero? [ first ] when ] map ;
+
+M: protocol definition protocol-words show-words ;
M: protocol definer drop \ PROTOCOL: \ ; ;
@@ -51,18 +57,17 @@ GENERIC: group-words ( group -- words )
M: protocol group-words
"protocol-words" word-prop ;
-M: generic group-words
- 1array ;
-
M: tuple-class group-words
- "slots" word-prop
- [ [ slot-spec-reader ] map ]
- [ [ slot-spec-writer ] map ] bi append ;
+ "slot-names" word-prop [
+ [ reader-word ] [ writer-word ] bi
+ 2array [ 0 2array ] map
+ ] map concat ;
! Consultation
: define-consult-method ( word class quot -- )
- pick suffix >r swap create-method r> define ;
+ [ drop swap first create-method ]
+ [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
: change-word-prop ( word prop quot -- )
>r swap word-props r> change-at ; inline
@@ -70,24 +75,28 @@ M: tuple-class group-words
: add ( item vector/f -- vector )
2dup member? [ nip ] [ ?push ] if ;
-: declare-consult ( class group -- )
+: use-protocol ( class group -- )
"protocol-users" [ add ] change-word-prop ;
-: define-consult ( class group quot -- )
- >r 2dup declare-consult group-words swap r>
+: define-consult ( group class quot -- )
+ swapd >r 2dup use-protocol group-words swap r>
[ define-consult-method ] 2curry each ;
: CONSULT:
- scan-word scan-word parse-definition swapd define-consult ; parsing
+ scan-word scan-word parse-definition define-consult ; parsing
! Mimic still needs to be updated
+: mimic-method ( mimicker mimicked generic -- )
+ tuck method
+ [ [ create-method-in ] [ word-def ] bi* define ]
+ [ 2drop ] if* ;
+
: define-mimic ( group mimicker mimicked -- )
- rot group-words -rot [
- pick "methods" word-prop at dup
- [ >r swap create-method-in r> word-def define ]
- [ 3drop ] if
- ] 2curry each ;
+ [ drop swap use-protocol ] [
+ rot group-words -rot
+ [ rot first mimic-method ] 2curry each
+ ] 3bi ;
: MIMIC:
scan-word scan-word scan-word define-mimic ; parsing
diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor
index f9b4c8648d..b1435e0dbc 100755
--- a/extra/delegate/protocols/protocols.factor
+++ b/extra/delegate/protocols/protocols.factor
@@ -9,10 +9,8 @@ PROTOCOL: sequence-protocol
set-nth set-nth-unsafe length set-length lengthen ;
PROTOCOL: assoc-protocol
- at* assoc-size >alist set-at assoc-clone-like
+ at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 }
delete-at clear-assoc new-assoc assoc-like ;
- ! assoc-find excluded because GENERIC# 1
- ! everything should work, just slower (with >alist)
PROTOCOL: stream-protocol
stream-read1 stream-read stream-read-until dispose
@@ -28,5 +26,3 @@ PROTOCOL: prettyprint-section-protocol
section-fits? indent-section? unindent-first-line?
newline-after? short-section? short-section long-section
<section> delegate>block add-section ;
-
-
From b2cb88f49709125aa556963f8be06868743b6bbc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 04:01:46 -0500
Subject: [PATCH 171/288] GC: allocate large objects directly into tenured
space
---
core/alien/alien-docs.factor | 2 +-
core/alien/compiler/compiler-tests.factor | 14 ++--
core/bootstrap/primitives.factor | 3 +-
core/compiler/tests/float.factor | 2 +-
core/compiler/tests/simple.factor | 2 +-
core/continuations/continuations-tests.factor | 4 +-
core/inference/known-words/known-words.factor | 4 +-
core/memory/memory-docs.factor | 5 +-
core/memory/memory-tests.factor | 2 -
vm/code_gc.c | 12 +--
vm/code_gc.h | 2 -
vm/code_heap.c | 2 +-
vm/data_gc.c | 73 ++++++++---------
vm/data_gc.h | 81 +++++++++++--------
vm/debug.c | 2 +-
vm/factor.c | 10 ++-
vm/image.c | 12 ++-
vm/image.h | 2 +-
vm/primitives.c | 3 +-
vm/profiler.c | 7 +-
20 files changed, 119 insertions(+), 125 deletions(-)
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index fcafe3441c..136af91bb2 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -204,7 +204,7 @@ ARTICLE: "alien-callback-gc" "Callbacks and code GC"
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
$nl
"This is the safest approach, however it can lead to code heap leaks when repeatedly reloading code which defines callbacks. If you are " { $emphasis "completely sure" } " that no running C code is holding a reference to any callbacks, you can blow them all away:"
-{ $code "USE: alien callbacks get clear-hash code-gc" }
+{ $code "USE: alien callbacks get clear-hash gc" }
"This will reclaim all callback bodies which are otherwise unreachable from the dictionary (that is, their associated callback words have since been redefined, recompiled or forgotten)." ;
ARTICLE: "alien-callback" "Calling Factor from C"
diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor
index f9dc426de1..dd2d9587cb 100755
--- a/core/alien/compiler/compiler-tests.factor
+++ b/core/alien/compiler/compiler-tests.factor
@@ -87,7 +87,7 @@ FUNCTION: tiny ffi_test_17 int x ;
[ -1 indirect-test-1 ] must-fail
: indirect-test-2
- "int" { "int" "int" } "cdecl" alien-indirect data-gc ;
+ "int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
@@ -97,7 +97,7 @@ unit-test
: indirect-test-3
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
- data-gc ;
+ gc ;
<< "f-stdcall" f "stdcall" add-library >>
@@ -106,13 +106,13 @@ unit-test
: ffi_test_18 ( w x y z -- int )
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
- alien-invoke data-gc ;
+ alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
- alien-invoke data-gc ;
+ alien-invoke gc ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
@@ -143,7 +143,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
"void"
f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
- alien-invoke code-gc 3 ;
+ alien-invoke gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
@@ -312,14 +312,14 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
: callback-4
"void" { } "cdecl" [ "Hello world" write ] alien-callback
- data-gc ;
+ gc ;
[ "Hello world" ] [
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
: callback-5
- "void" { } "cdecl" [ data-gc ] alien-callback ;
+ "void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 516ff7ed74..a5348db973 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -640,8 +640,7 @@ define-builtin
{ "setenv" "kernel.private" }
{ "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" }
- { "data-gc" "memory" }
- { "code-gc" "memory" }
+ { "gc" "memory" }
{ "gc-time" "memory" }
{ "save-image" "memory" }
{ "save-image-and-exit" "memory" }
diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor
index 0d457a8310..81ab750305 100755
--- a/core/compiler/tests/float.factor
+++ b/core/compiler/tests/float.factor
@@ -2,7 +2,7 @@ IN: compiler.tests
USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ;
-[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
+[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test
diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor
index 13b7de6987..09b0c190e6 100755
--- a/core/compiler/tests/simple.factor
+++ b/core/compiler/tests/simple.factor
@@ -48,7 +48,7 @@ IN: compiler.tests
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
-[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
+[ 2 3 ] [ 1 [ { [ gc 1 ] [ gc 2 ] } dispatch 3 ] compile-call ] unit-test
! Labels
diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor
index d5ede60086..8b396763e1 100755
--- a/core/continuations/continuations-tests.factor
+++ b/core/continuations/continuations-tests.factor
@@ -46,8 +46,8 @@ IN: continuations.tests
! Weird PowerPC bug.
[ ] [
[ "4" throw ] ignore-errors
- data-gc
- data-gc
+ gc
+ gc
] unit-test
[ f ] [ { } kernel-error? ] unit-test
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 5092b86a4d..99737e0ac5 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -358,9 +358,7 @@ M: object infer-call
\ (directory) { string } { array } <effect> set-primitive-effect
-\ data-gc { } { } <effect> set-primitive-effect
-
-\ code-gc { } { } <effect> set-primitive-effect
+\ gc { } { } <effect> set-primitive-effect
\ gc-time { } { integer } <effect> set-primitive-effect
diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor
index e29844dc89..75876a3c8f 100755
--- a/core/memory/memory-docs.factor
+++ b/core/memory/memory-docs.factor
@@ -37,12 +37,9 @@ HELP: instances
{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." }
{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ;
-HELP: data-gc ( -- )
+HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ;
-HELP: code-gc ( -- )
-{ $description "Collects all generations up to and including tenured space, and also collects the code heap." } ;
-
HELP: gc-time ( -- n )
{ $values { "n" "a timestamp in milliseconds" } }
{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor
index 0a021d1978..2b5b1333c0 100755
--- a/core/memory/memory-tests.factor
+++ b/core/memory/memory-tests.factor
@@ -8,8 +8,6 @@ IN: memory.tests
: leak-loop 100 [ leak-step ] times ;
-[ ] [ leak-step leak-step leak-step data-gc ] unit-test
-
[ ] [ leak-loop ] unit-test
TUPLE: testing x y z ;
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 8a05daf570..93eb49c1be 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -287,16 +287,6 @@ DEFINE_PRIMITIVE(code_room)
dpush(tag_fixnum((code_heap.segment->size) / 1024));
}
-void code_gc(void)
-{
- garbage_collection(TENURED,false,0);
-}
-
-DEFINE_PRIMITIVE(code_gc)
-{
- code_gc();
-}
-
/* Dump all code blocks for debugging */
void dump_heap(F_HEAP *heap)
{
@@ -444,7 +434,7 @@ critical here */
void compact_code_heap(void)
{
/* Free all unreachable code blocks */
- code_gc();
+ gc();
fprintf(stderr,"*** Code heap compaction...\n");
fflush(stderr);
diff --git a/vm/code_gc.h b/vm/code_gc.h
index 4341d8ce64..32f304c16c 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -85,8 +85,6 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter);
void collect_literals(void);
void recursive_mark(F_BLOCK *block);
void dump_heap(F_HEAP *heap);
-void code_gc(void);
void compact_code_heap(void);
DECLARE_PRIMITIVE(code_room);
-DECLARE_PRIMITIVE(code_gc);
diff --git a/vm/code_heap.c b/vm/code_heap.c
index e55188c6a8..ec63441bcb 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -224,7 +224,7 @@ CELL allot_code_block(CELL size)
/* If allocation failed, do a code GC */
if(start == 0)
{
- code_gc();
+ gc();
start = heap_allot(&code_heap,size);
/* Insufficient room even after code GC, give up */
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 010ceb49ad..c43fe69bd1 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -1,8 +1,6 @@
#include "master.h"
-#define GC_DEBUG 0
-
-#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld\n"
+#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld, tenured_size=%ld\n"
#define GC_REQUESTED "garbage_collection: growing_data_heap=%d, requested_bytes=%ld\n"
#define BEGIN_GC "begin_gc: growing_data_heap=%d, collecting_gen=%ld\n"
#define END_GC "end_gc: gc_elapsed=%ld\n"
@@ -31,25 +29,28 @@ void init_cards_offset(void)
F_DATA_HEAP *alloc_data_heap(CELL gens,
CELL young_size,
- CELL aging_size)
+ CELL aging_size,
+ CELL tenured_size)
{
- GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size);
+ GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size);
young_size = align_page(young_size);
aging_size = align_page(aging_size);
+ tenured_size = align_page(tenured_size);
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
data_heap->young_size = young_size;
data_heap->aging_size = aging_size;
+ data_heap->tenured_size = tenured_size;
data_heap->gen_count = gens;
CELL total_size;
if(data_heap->gen_count == 1)
- total_size = 2 * aging_size;
+ total_size = 2 * tenured_size;
else if(data_heap->gen_count == 2)
- total_size = (gens - 1) * young_size + 2 * aging_size;
+ total_size = young_size + 2 * tenured_size;
else if(data_heap->gen_count == 3)
- total_size = gens * young_size + 2 * aging_size;
+ total_size = young_size + 2 * aging_size + 2 * tenured_size;
else
{
fatal_error("Invalid number of generations",data_heap->gen_count);
@@ -58,8 +59,8 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
data_heap->segment = alloc_segment(total_size);
- data_heap->generations = safe_malloc(sizeof(F_ZONE) * gens);
- data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * gens);
+ data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
+ data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
CELL cards_size = total_size / CARD_SIZE;
data_heap->cards = safe_malloc(cards_size);
@@ -67,31 +68,19 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
CELL alloter = data_heap->segment->start;
- alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
+ alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
- alloter = init_zone(&data_heap->generations[TENURED],aging_size,alloter);
- alloter = init_zone(&data_heap->semispaces[TENURED],aging_size,alloter);
-
- int i;
-
- if(data_heap->gen_count > 2)
+ if(data_heap->gen_count == 3)
{
- alloter = init_zone(&data_heap->generations[AGING],young_size,alloter);
- alloter = init_zone(&data_heap->semispaces[AGING],young_size,alloter);
-
- for(i = gens - 3; i >= 0; i--)
- {
- alloter = init_zone(&data_heap->generations[i],
- young_size,alloter);
- }
+ alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
}
- else
+
+ if(data_heap->gen_count >= 2)
{
- for(i = gens - 2; i >= 0; i--)
- {
- alloter = init_zone(&data_heap->generations[i],
- young_size,alloter);
- }
+ alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
}
if(alloter != data_heap->segment->end)
@@ -104,10 +93,12 @@ F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
{
CELL new_young_size = (data_heap->young_size * 2) + requested_bytes;
CELL new_aging_size = (data_heap->aging_size * 2) + requested_bytes;
+ CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
return alloc_data_heap(data_heap->gen_count,
new_young_size,
- new_aging_size);
+ new_aging_size,
+ new_tenured_size);
}
void dealloc_data_heap(F_DATA_HEAP *data_heap)
@@ -141,9 +132,10 @@ void set_data_heap(F_DATA_HEAP *data_heap_)
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
+ CELL tenured_size,
bool secure_gc_)
{
- set_data_heap(alloc_data_heap(gens,young_size,aging_size));
+ set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
gc_locals_region = alloc_segment(getpagesize());
gc_locals = gc_locals_region->start - CELLS;
@@ -258,7 +250,7 @@ void begin_scan(void)
DEFINE_PRIMITIVE(begin_scan)
{
- data_gc();
+ gc();
begin_scan();
}
@@ -645,7 +637,7 @@ void begin_gc(CELL requested_bytes)
printf("Newspace: ");
dump_zone(newspace);
printf("\n");
-#endif;
+#endif
}
void end_gc(void)
@@ -788,14 +780,14 @@ void garbage_collection(CELL gen,
performing_gc = false;
}
-void data_gc(void)
+void gc(void)
{
garbage_collection(TENURED,false,0);
}
-DEFINE_PRIMITIVE(data_gc)
+DEFINE_PRIMITIVE(gc)
{
- data_gc();
+ gc();
}
/* Push total time spent on GC */
@@ -806,7 +798,8 @@ DEFINE_PRIMITIVE(gc_time)
void simple_gc(void)
{
- maybe_gc(0);
+ if(nursery->here + ALLOT_BUFFER_ZONE > nursery->end)
+ garbage_collection(NURSERY,false,0);
}
DEFINE_PRIMITIVE(become)
@@ -828,5 +821,5 @@ DEFINE_PRIMITIVE(become)
forward_object(old_obj,new_obj);
}
- data_gc();
+ gc();
}
diff --git a/vm/data_gc.h b/vm/data_gc.h
index ee2e51b6f8..acbc38a6cb 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -19,6 +19,8 @@ DECLARE_PRIMITIVE(begin_scan);
DECLARE_PRIMITIVE(next_object);
DECLARE_PRIMITIVE(end_scan);
+void gc(void);
+
/* generational copying GC divides memory into zones */
typedef struct {
/* allocation pointer is 'here'; its offset is hardcoded in the
@@ -34,6 +36,7 @@ typedef struct {
CELL young_size;
CELL aging_size;
+ CELL tenured_size;
CELL gen_count;
@@ -134,6 +137,7 @@ CELL init_zone(F_ZONE *z, CELL size, CELL base);
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
+ CELL tenured_size,
bool secure_gc_);
/* statistics */
@@ -186,10 +190,7 @@ INLINE void do_slots(CELL obj, void (* iter)(CELL *))
}
}
-/* test if the pointer is in generation being collected, or a younger one.
-init_data_heap() arranges things so that the older generations are first,
-so we have to check that the pointer occurs after the beginning of
-the requested generation. */
+/* test if the pointer is in generation being collected, or a younger one. */
INLINE bool should_copy(CELL untagged)
{
if(in_zone(newspace,untagged))
@@ -306,37 +307,53 @@ allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
-#define SUFFICIENT_ROOM(a) (nursery->here + ALLOT_BUFFER_ZONE + a <= nursery->end)
-
-INLINE void maybe_gc(CELL a)
-{
- /* If there is enough room, return */
- if(SUFFICIENT_ROOM(a))
- return;
- /* If the object is bigger than the nursery, grow immediately */
- else if(nursery->size - ALLOT_BUFFER_ZONE <= a)
- garbage_collection(TENURED,true,a);
- /* Otherwise, collect the nursery */
- else
- {
- garbage_collection(NURSERY,false,0);
-
- /* If there is still insufficient room, try growing the heap.
- This can only happen if the number of generations is 1. */
- if(SUFFICIENT_ROOM(a)) return;
-
- garbage_collection(TENURED,true,a);
- }
-}
-
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
-INLINE void* allot_object(CELL type, CELL length)
+INLINE void* allot_object(CELL type, CELL a)
{
- maybe_gc(length);
- CELL* object = allot_zone(nursery,length);
+ CELL *object;
+
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ if(nursery->size - ALLOT_BUFFER_ZONE > a)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
+ garbage_collection(NURSERY,false,0);
+
+ object = allot_zone(nursery,a);
+ }
+ else
+ {
+ F_ZONE *tenured = &data_heap->generations[TENURED];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + a > tenured->end)
+ {
+ gc();
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + a > tenured->end)
+ {
+ garbage_collection(TENURED,true,a);
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ object = allot_zone(tenured,a);
+
+ /* We have to do this */
+ allot_barrier((CELL)object);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier((CELL)object);
+ }
+
*object = tag_header(type);
return object;
}
@@ -345,8 +362,6 @@ CELL collect_next(CELL scan);
DLLEXPORT void simple_gc(void);
-void data_gc(void);
-
-DECLARE_PRIMITIVE(data_gc);
+DECLARE_PRIMITIVE(gc);
DECLARE_PRIMITIVE(gc_time);
DECLARE_PRIMITIVE(become);
diff --git a/vm/debug.c b/vm/debug.c
index 145004f113..840d252769 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -246,7 +246,7 @@ void dump_generations(void)
void dump_objects(F_FIXNUM type)
{
- data_gc();
+ gc();
begin_scan();
CELL obj;
diff --git a/vm/factor.c b/vm/factor.c
index 5825f97bdd..c8791b8972 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -13,15 +13,17 @@ void default_parameters(F_PARAMETERS *p)
p->gen_count = 2;
p->code_size = 4;
p->young_size = 1;
- p->aging_size = 6;
+ p->aging_size = 1;
+ p->tenured_size = 6;
#else
p->ds_size = 32 * CELLS;
p->rs_size = 32 * CELLS;
p->gen_count = 3;
p->code_size = 8 * CELLS;
- p->young_size = 2 * CELLS;
- p->aging_size = 4 * CELLS;
+ p->young_size = 2;
+ p->aging_size = 2;
+ p->tenured_size = 4 * CELLS;
#endif
p->secure_gc = false;
@@ -84,6 +86,7 @@ void init_factor(F_PARAMETERS *p)
/* Megabytes */
p->young_size <<= 20;
p->aging_size <<= 20;
+ p->tenured_size <<= 20;
p->code_size <<= 20;
/* Disable GC during init as a sanity check */
@@ -153,6 +156,7 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
else if(factor_arg(argv[i],STR_FORMAT("-generations=%d"),&p.gen_count));
else if(factor_arg(argv[i],STR_FORMAT("-young=%d"),&p.young_size));
else if(factor_arg(argv[i],STR_FORMAT("-aging=%d"),&p.aging_size));
+ else if(factor_arg(argv[i],STR_FORMAT("-tenured=%d"),&p.tenured_size));
else if(factor_arg(argv[i],STR_FORMAT("-codeheap=%d"),&p.code_size));
else if(STRCMP(argv[i],STR_FORMAT("-securegc")) == 0)
p.secure_gc = true;
diff --git a/vm/image.c b/vm/image.c
index 28c6c40c1d..653891fdfe 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -17,10 +17,14 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
{
CELL good_size = h->data_size + (1 << 20);
- if(good_size > p->aging_size)
- p->aging_size = good_size;
+ if(good_size > p->tenured_size)
+ p->tenured_size = good_size;
- init_data_heap(p->gen_count,p->young_size,p->aging_size,p->secure_gc);
+ init_data_heap(p->gen_count,
+ p->young_size,
+ p->aging_size,
+ p->tenured_size,
+ p->secure_gc);
F_ZONE *tenured = &data_heap->generations[TENURED];
@@ -145,7 +149,7 @@ void save_image(const F_CHAR *filename)
DEFINE_PRIMITIVE(save_image)
{
/* do a full GC to push everything into tenured space */
- code_gc();
+ gc();
save_image(unbox_native_string());
}
diff --git a/vm/image.h b/vm/image.h
index a57d1f5539..9b7df4e3a8 100755
--- a/vm/image.h
+++ b/vm/image.h
@@ -28,7 +28,7 @@ typedef struct {
typedef struct {
const F_CHAR* image;
CELL ds_size, rs_size;
- CELL gen_count, young_size, aging_size;
+ CELL gen_count, young_size, aging_size, tenured_size;
CELL code_size;
bool secure_gc;
bool fep;
diff --git a/vm/primitives.c b/vm/primitives.c
index 6a6aeb9d46..038a7d84a5 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -90,8 +90,7 @@ void *primitives[] = {
primitive_setenv,
primitive_existsp,
primitive_read_dir,
- primitive_data_gc,
- primitive_code_gc,
+ primitive_gc,
primitive_gc_time,
primitive_save_image,
primitive_save_image_and_exit,
diff --git a/vm/profiler.c b/vm/profiler.c
index 72c9046eab..407fefaace 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -57,10 +57,9 @@ void set_profiling(bool profiling)
profiling_p = profiling;
- /* Push everything to tenured space so that we can heap scan,
- also code GC so that we can allocate profiling blocks if
- necessary */
- code_gc();
+ /* Push everything to tenured space so that we can heap scan
+ and allocate profiling blocks if necessary */
+ gc();
/* Update word XTs and saved callstack objects */
begin_scan();
From b3a41fd79696d4ce878c4d42e9ced0df610bd7e4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 04:26:46 -0500
Subject: [PATCH 172/288] Merged code-gc, data-gc primitives into a gc
primitive
---
extra/cocoa/cocoa-tests.factor | 2 +-
extra/tools/memory/memory-docs.factor | 3 +--
extra/tools/profiler/profiler-tests.factor | 2 +-
3 files changed, 3 insertions(+), 4 deletions(-)
diff --git a/extra/cocoa/cocoa-tests.factor b/extra/cocoa/cocoa-tests.factor
index 20b7e2a02d..4b56d81626 100644
--- a/extra/cocoa/cocoa-tests.factor
+++ b/extra/cocoa/cocoa-tests.factor
@@ -10,7 +10,7 @@ CLASS: {
"foo:"
"void"
{ "id" "SEL" "NSRect" }
- [ data-gc "x" set 2drop ]
+ [ gc "x" set 2drop ]
} ;
: test-foo
diff --git a/extra/tools/memory/memory-docs.factor b/extra/tools/memory/memory-docs.factor
index 11bb8d859b..28c219ee4d 100755
--- a/extra/tools/memory/memory-docs.factor
+++ b/extra/tools/memory/memory-docs.factor
@@ -15,8 +15,7 @@ ARTICLE: "tools.memory" "Object memory tools"
"You can check an object's the heap memory usage:"
{ $subsection size }
"The garbage collector can be invoked manually:"
-{ $subsection data-gc }
-{ $subsection code-gc }
+{ $subsection gc }
{ $see-also "images" } ;
ABOUT: "tools.memory"
diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor
index e33201e22c..450a024a1e 100755
--- a/extra/tools/profiler/profiler-tests.factor
+++ b/extra/tools/profiler/profiler-tests.factor
@@ -8,7 +8,7 @@ alien tools.profiler.private sequences ;
\ length profile-counter =
] unit-test
-[ ] [ [ 10 [ data-gc ] times ] profile ] unit-test
+[ ] [ [ 10 [ gc ] times ] profile ] unit-test
[ ] [ [ 1000 sleep ] profile ] unit-test
From 57268bcc7b644d8b0030f85c7adf6eb7f9197ccc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 04:26:58 -0500
Subject: [PATCH 173/288] Launcher wait cleanup, don't use kqueue anymore
---
extra/io/launcher/launcher.factor | 21 ++++++++++++++++-----
extra/io/unix/bsd/bsd.factor | 21 +++------------------
extra/io/unix/freebsd/freebsd.factor | 2 +-
extra/io/unix/launcher/launcher.factor | 6 +-----
extra/io/unix/linux/linux.factor | 2 --
extra/io/unix/macosx/macosx.factor | 2 +-
extra/io/unix/openbsd/openbsd.factor | 2 +-
extra/io/unix/unix.factor | 2 +-
extra/io/windows/launcher/launcher.factor | 20 ++------------------
9 files changed, 26 insertions(+), 52 deletions(-)
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 20c5bb92c9..fa4bdcaaea 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -3,7 +3,7 @@
USING: io io.backend io.timeouts system kernel namespaces
strings hashtables sequences assocs combinators vocabs.loader
init threads continuations math io.encodings io.streams.duplex
-io.nonblocking accessors ;
+io.nonblocking accessors concurrency.flags ;
IN: io.launcher
TUPLE: process < identity-tuple
@@ -56,14 +56,25 @@ SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
-HOOK: register-process io-backend ( process -- )
+HOOK: wait-for-processes io-backend ( -- ? )
-M: object register-process drop ;
+SYMBOL: wait-flag
+
+: wait-loop ( -- )
+ processes get assoc-empty?
+ [ wait-flag get-global lower-flag ]
+ [ wait-for-processes [ 100 sleep ] when ] if ;
+
+: start-wait-thread ( -- )
+ <flag> wait-flag set-global
+ [ wait-loop t ] "Process wait" spawn-server drop ;
+
+[ start-wait-thread ] "io.launcher" add-init-hook
: process-started ( process handle -- )
>>handle
- V{ } clone over processes get set-at
- register-process ;
+ V{ } clone swap processes get set-at
+ wait-flag get-global raise-flag ;
M: process hashcode* process-handle hashcode* ;
diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor
index 6f6517868e..12a64a41f9 100755
--- a/extra/io/unix/bsd/bsd.factor
+++ b/extra/io/unix/bsd/bsd.factor
@@ -1,23 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.bsd
-USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
-io.launcher io.unix.launcher namespaces kernel assocs
-threads continuations system ;
-
-! On Mac OS X, we use select() for the top-level
-! multiplexer, and we hang a kqueue off of it for process exit
-! notification.
-
-! kqueue is buggy with files and ptys so we can't use it as the
-! main multiplexer.
+USING: io.backend io.unix.backend io.unix.select
+namespaces system ;
M: bsd init-io ( -- )
- <select-mx> mx set-global
- <kqueue-mx> kqueue-mx set-global
- kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
- 2dup mx get-global mx-reads set-at
- mx get-global mx-writes set-at ;
-
-M: bsd register-process ( process -- )
- process-handle kqueue-mx get-global add-pid-task ;
+ <select-mx> mx set-global ;
diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor
index 49fbc9af7e..65a208c556 100644
--- a/extra/io/unix/freebsd/freebsd.factor
+++ b/extra/io/unix/freebsd/freebsd.factor
@@ -1,3 +1,3 @@
-USING: io.unix.bsd io.backend system ;
+USING: io.backend system ;
freebsd set-io-backend
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 9abedf38ac..ef0107beb1 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -108,7 +108,7 @@ M: unix (process-stream)
! Inefficient process wait polling, used on Linux and Solaris.
! On BSD and Mac OS X, we use kqueue() which scales better.
-: wait-for-processes ( -- ? )
+M: unix wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid
dup 0 <= [
2drop t
@@ -119,7 +119,3 @@ M: unix (process-stream)
2drop f
] if
] if ;
-
-: start-wait-thread ( -- )
- [ wait-for-processes [ 250 sleep ] when t ]
- "Process reaper" spawn-server drop ;
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 78af0dd50d..30c61f6d21 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -123,5 +123,3 @@ M: linux init-io ( -- )
[ init-inotify ] bi ;
linux set-io-backend
-
-[ start-wait-thread ] "io.unix.linux" add-init-hook
diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor
index c1c73ea018..277a38080c 100644
--- a/extra/io/unix/macosx/macosx.factor
+++ b/extra/io/unix/macosx/macosx.factor
@@ -1,4 +1,4 @@
-USING: io.unix.bsd io.backend io.monitors io.monitors.private
+USING: io.backend io.monitors io.monitors.private
continuations kernel core-foundation.fsevents sequences
namespaces arrays system ;
IN: io.unix.macosx
diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor
index 9b3021646d..1907471263 100644
--- a/extra/io/unix/openbsd/openbsd.factor
+++ b/extra/io/unix/openbsd/openbsd.factor
@@ -1,3 +1,3 @@
-USING: io.unix.bsd io.backend core-foundation.fsevents system ;
+USING: io.backend core-foundation.fsevents system ;
openbsd set-io-backend
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index b4328f31b3..1e5638fb4a 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -1,5 +1,5 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
-system vocabs.loader sequences words ;
+system vocabs.loader sequences words init ;
"io.unix." os word-name append require
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 6185159ddc..410e13d266 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -144,26 +144,10 @@ M: windows kill-process* ( handle -- )
over process-handle dispose-process
notify-exit ;
-: wait-for-processes ( processes -- ? )
- keys dup
+M: windows wait-for-processes ( -- ? )
+ processes get keys dup
[ process-handle PROCESS_INFORMATION-hProcess ] map
dup length swap >c-void*-array 0 0
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
-
-SYMBOL: wait-flag
-
-: wait-loop ( -- )
- processes get dup assoc-empty?
- [ drop wait-flag get-global lower-flag ]
- [ wait-for-processes [ 100 sleep ] when ] if ;
-
-: start-wait-thread ( -- )
- <flag> wait-flag set-global
- [ wait-loop t ] "Process wait" spawn-server drop ;
-
-M: windows register-process
- drop wait-flag get-global raise-flag ;
-
-[ start-wait-thread ] "io.windows.launcher" add-init-hook
From 545b8a3d0525e79b84269287b2a5967bd2b55097 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 04:36:13 -0500
Subject: [PATCH 174/288] Default nursery size is 1mb; don't double nursery and
accumulation when growing data heap
---
vm/data_gc.c | 6 ++----
vm/factor.c | 2 +-
2 files changed, 3 insertions(+), 5 deletions(-)
diff --git a/vm/data_gc.c b/vm/data_gc.c
index c43fe69bd1..b7bba4997e 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -91,13 +91,11 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
{
- CELL new_young_size = (data_heap->young_size * 2) + requested_bytes;
- CELL new_aging_size = (data_heap->aging_size * 2) + requested_bytes;
CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
return alloc_data_heap(data_heap->gen_count,
- new_young_size,
- new_aging_size,
+ data_heap->young_size,
+ data_heap->aging_size,
new_tenured_size);
}
diff --git a/vm/factor.c b/vm/factor.c
index c8791b8972..49f85c3485 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -21,7 +21,7 @@ void default_parameters(F_PARAMETERS *p)
p->gen_count = 3;
p->code_size = 8 * CELLS;
- p->young_size = 2;
+ p->young_size = 1;
p->aging_size = 2;
p->tenured_size = 4 * CELLS;
#endif
From a30c60ea6309d3482560f707938e747e909705d9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 04:58:22 -0500
Subject: [PATCH 175/288] Fix UI breakage
---
extra/ui/gadgets/gadgets.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index c4f11f2e87..3ad76b0a16 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -396,10 +396,10 @@ M: gadget request-focus-on gadget-parent request-focus-on ;
M: f request-focus-on 2drop ;
: request-focus ( gadget -- )
- dup focusable-child swap request-focus-on ;
+ [ focusable-child ] keep request-focus-on ;
: focus-path ( world -- seq )
- [ gadget-parent ] follow ;
+ [ gadget-focus ] follow ;
: make-gadget ( quot gadget -- gadget )
[ \ make-gadget rot with-variable ] keep ; inline
From e545c90453d263e1a7df74794e9eb5c6048a50e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 04:58:34 -0500
Subject: [PATCH 176/288] Bigger nursery/aging spaces on 64 bit
---
vm/factor.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/vm/factor.c b/vm/factor.c
index 49f85c3485..c3d85eff5e 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -21,8 +21,8 @@ void default_parameters(F_PARAMETERS *p)
p->gen_count = 3;
p->code_size = 8 * CELLS;
- p->young_size = 1;
- p->aging_size = 2;
+ p->young_size = CELLS / 4;
+ p->aging_size = CELLS / 2;
p->tenured_size = 4 * CELLS;
#endif
From 1d3205c69ef589ce75533490a4eca6f6b7a9c220 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 05:50:39 -0500
Subject: [PATCH 177/288] Fix BSD I/O
---
extra/io/unix/freebsd/freebsd.factor | 2 +-
extra/io/unix/macosx/macosx.factor | 2 +-
extra/io/unix/netbsd/netbsd.factor | 2 +-
extra/io/unix/openbsd/openbsd.factor | 2 +-
4 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor
index 65a208c556..49fbc9af7e 100644
--- a/extra/io/unix/freebsd/freebsd.factor
+++ b/extra/io/unix/freebsd/freebsd.factor
@@ -1,3 +1,3 @@
-USING: io.backend system ;
+USING: io.unix.bsd io.backend system ;
freebsd set-io-backend
diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor
index 277a38080c..c1c73ea018 100644
--- a/extra/io/unix/macosx/macosx.factor
+++ b/extra/io/unix/macosx/macosx.factor
@@ -1,4 +1,4 @@
-USING: io.backend io.monitors io.monitors.private
+USING: io.unix.bsd io.backend io.monitors io.monitors.private
continuations kernel core-foundation.fsevents sequences
namespaces arrays system ;
IN: io.unix.macosx
diff --git a/extra/io/unix/netbsd/netbsd.factor b/extra/io/unix/netbsd/netbsd.factor
index c5771c8ffc..ed134788b6 100644
--- a/extra/io/unix/netbsd/netbsd.factor
+++ b/extra/io/unix/netbsd/netbsd.factor
@@ -1,3 +1,3 @@
-USING: io.backend system ;
+USING: io.unix.bsd io.backend system ;
netbsd set-io-backend
diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor
index 1907471263..dfc466f94b 100644
--- a/extra/io/unix/openbsd/openbsd.factor
+++ b/extra/io/unix/openbsd/openbsd.factor
@@ -1,3 +1,3 @@
-USING: io.backend core-foundation.fsevents system ;
+USING: io.unix.bsd io.backend system ;
openbsd set-io-backend
From f7f43fa689c6999394317018e1866da75c52b723 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 07:00:09 -0500
Subject: [PATCH 178/288] ABOUT: updates vocabulary
---
core/bootstrap/primitives.factor | 2 +-
core/classes/tuple/tuple.factor | 2 +-
core/compiler/units/units.factor | 10 +++++-----
core/definitions/definitions.factor | 7 +++++++
core/words/words.factor | 9 +--------
extra/help/syntax/syntax.factor | 7 +++++--
6 files changed, 20 insertions(+), 17 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index a5348db973..5836b4d3c5 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -30,7 +30,7 @@ crossref off
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
-H{ } clone changed-words set
+H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 8b5972417d..1aa283a675 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -174,7 +174,7 @@ M: tuple-class update-class
2drop
[
[ update-tuples-after ]
- [ changed-word ]
+ [ changed-definition ]
[ redefined ]
tri
] each-subclass
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index f87c1ec985..a780e0a745 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -56,12 +56,12 @@ GENERIC: definitions-changed ( assoc obj -- )
[ drop word? ] assoc-subset
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
-: changed-definitions ( -- assoc )
+: updated-definitions ( -- assoc )
H{ } clone
dup forgotten-definitions get update
dup new-definitions get first update
dup new-definitions get second update
- dup changed-words get update
+ dup changed-definitions get update
dup dup changed-vocabs update ;
: compile ( words -- )
@@ -73,7 +73,7 @@ SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
- changed-words get keys
+ changed-definitions get keys [ word? ] subset
compiled-usages recompile-hook get call ;
: call-update-tuples-hook ( -- )
@@ -83,11 +83,11 @@ SYMBOL: update-tuples-hook
call-recompile-hook
call-update-tuples-hook
dup [ drop crossref? ] assoc-contains? modify-code-heap
- changed-definitions notify-definition-observers ;
+ updated-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )
[
- H{ } clone changed-words set
+ H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
<definitions> new-definitions set
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 6ee21fc016..459512b83a 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -5,6 +5,13 @@ USING: kernel sequences namespaces assocs graphs ;
ERROR: no-compilation-unit definition ;
+SYMBOL: changed-definitions
+
+: changed-definition ( defspec -- )
+ dup changed-definitions get
+ [ no-compilation-unit ] unless*
+ set-at ;
+
GENERIC: where ( defspec -- loc )
M: object where drop f ;
diff --git a/core/words/words.factor b/core/words/words.factor
index 2510c50347..7794a7f41f 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -144,19 +144,12 @@ PRIVATE>
: redefined ( word -- )
H{ } clone visited [ (redefined) ] with-variable ;
-SYMBOL: changed-words
-
-: changed-word ( word -- )
- dup changed-words get
- [ no-compilation-unit ] unless*
- set-at ;
-
: define ( word def -- )
[ ] like
over unxref
over redefined
over set-word-def
- dup changed-word
+ dup changed-definition
dup crossref? [ dup xref ] when drop ;
: define-declared ( word def effect -- )
diff --git a/extra/help/syntax/syntax.factor b/extra/help/syntax/syntax.factor
index 9450f87215..65120a5d01 100755
--- a/extra/help/syntax/syntax.factor
+++ b/extra/help/syntax/syntax.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel parser sequences words help help.topics
namespaces vocabs definitions compiler.units ;
@@ -16,4 +16,7 @@ IN: help.syntax
over add-article >link r> remember-definition ; parsing
: ABOUT:
- scan-object in get vocab set-vocab-help ; parsing
+ scan-object
+ in get vocab
+ dup changed-definition
+ set-vocab-help ; parsing
From d8ffc1124221c54bd2eeb34c574cad75f9abd766 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 07:00:59 -0500
Subject: [PATCH 179/288] Remove unnecessary dependency
---
extra/locals/locals.factor | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index fe4bd65c14..a961dec3bd 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -3,9 +3,8 @@
USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
-definitions prettyprint hashtables combinators.lib
-prettyprint.sections sequences.private effects generic
-compiler.units accessors ;
+definitions prettyprint hashtables prettyprint.sections
+sequences.private effects generic compiler.units accessors ;
IN: locals
! Inspired by
From 1cc72a386e12f0c32ac0a22657afbe0cd1adb0b1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 07:35:36 -0500
Subject: [PATCH 180/288] Faster bootstrap
---
core/bootstrap/compiler/compiler.factor | 4 +++-
core/bootstrap/stage2.factor | 12 ++++--------
2 files changed, 7 insertions(+), 9 deletions(-)
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 618c62f332..9e101126e6 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -19,7 +19,7 @@ IN: bootstrap.compiler
enable-compiler
nl
-"Compiling some words to speed up bootstrap..." write flush
+"Compiling..." write flush
! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically
@@ -74,4 +74,6 @@ nl
malloc calloc free memcpy
} compile
+vocabs [ words [ compiled? not ] subset compile "." write flush ] each
+
" done" print flush
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index c82ebbe9f8..a75b111e78 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -27,9 +27,9 @@ SYMBOL: bootstrap-time
seq-diff
[ "bootstrap." prepend require ] each ;
-: compile-remaining ( -- )
- "Compiling remaining words..." print flush
- vocabs [ words [ compiled? not ] subset compile ] each ;
+! : compile-remaining ( -- )
+! "Compiling remaining words..." print flush
+! vocabs [ words [ compiled? not ] subset compile ] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;
@@ -57,7 +57,7 @@ millis >r
default-image-name "output-image" set-global
-"math help handbook compiler random tools ui ui.tools io" "include" set-global
+"math compiler help random tools ui ui.tools io handbook" "include" set-global
"" "exclude" set-global
parse-command-line
@@ -79,10 +79,6 @@ os winnt? [ "windows.nt" require ] when
load-components
run-bootstrap-init
-
- "bootstrap.compiler" vocab [
- compile-remaining
- ] when
] with-compiler-errors
:errors
From d5667fd4b19f9ec79ecff7838346dc4506968723 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 07:35:51 -0500
Subject: [PATCH 181/288] Better hashcodes
---
core/classes/tuple/tuple.factor | 7 ++++---
core/kernel/kernel.factor | 2 ++
2 files changed, 6 insertions(+), 3 deletions(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 1aa283a675..608fb8cf6c 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -225,9 +225,10 @@ M: tuple equal?
M: tuple hashcode*
[
- dup tuple-size -rot 0 -rot [
- swapd array-nth hashcode* bitxor
- ] 2curry reduce
+ [ class hashcode ] [ tuple-size ] [ ] tri
+ >r rot r> [
+ swapd array-nth hashcode* sequence-hashcode-step
+ ] 2curry each
] recursive-hashcode ;
! Deprecated
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 2b1dd3cf9c..b54d0a7879 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -118,6 +118,8 @@ GENERIC: hashcode* ( depth obj -- code )
M: object hashcode* 2drop 0 ;
+M: f hashcode* 2drop 31337 ;
+
: hashcode ( obj -- code ) 3 swap hashcode* ; inline
GENERIC: equal? ( obj1 obj2 -- ? )
From c11ecef6237181c00ca64c78b414e55fc7a4c15a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 07:36:14 -0500
Subject: [PATCH 182/288] Vocab browser formatting fix
---
extra/tools/vocabs/browser/browser.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/tools/vocabs/browser/browser.factor b/extra/tools/vocabs/browser/browser.factor
index 69ad9272a7..6ecb0bc5ad 100755
--- a/extra/tools/vocabs/browser/browser.factor
+++ b/extra/tools/vocabs/browser/browser.factor
@@ -79,7 +79,7 @@ C: <vocab-author> vocab-author
: describe-help ( vocab -- )
vocab-help [
- "Documentation" $heading nl ($link)
+ "Documentation" $heading ($link)
] when* ;
: describe-children ( vocab -- )
From b2fa4e2f077a8aa1977f6dea0d66c84dd13345ae Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 07:57:26 -0500
Subject: [PATCH 183/288] unicode no longer depends on *.lib
---
extra/unicode/breaks/breaks.factor | 6 +++---
extra/unicode/case/case.factor | 4 +++-
extra/unicode/data/data.factor | 4 ++--
extra/unicode/normalize/normalize.factor | 5 ++---
4 files changed, 10 insertions(+), 9 deletions(-)
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index 4c8c6491ca..7bb5776e78 100644
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -1,6 +1,6 @@
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
-combinators.lib assocs.lib math.ranges unicode.normalize
+math.ranges unicode.normalize
unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ;
IN: unicode.breaks
@@ -27,7 +27,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
[ "#" split1 drop ";" split1 drop trim-blank ] map
[ empty? not ] subset
[ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
- concat >set ;
+ concat [ dup ] H{ } map>assoc ;
: other-extend-lines ( -- lines )
"extra/unicode/PropList.txt" resource-path ascii file-lines ;
@@ -36,7 +36,7 @@ VALUE: other-extend
CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? )
- [ (extend)? ] [ other-extend key? ] either ;
+ dup (extend)? [ ] [ other-extend key? ] ?if ;
: grapheme-class ( ch -- class )
{
diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor
index 092a247204..06d22f0f63 100755
--- a/extra/unicode/case/case.factor
+++ b/extra/unicode/case/case.factor
@@ -1,8 +1,10 @@
USING: kernel unicode.data sequences sequences.next namespaces
-assocs.lib unicode.normalize math unicode.categories combinators
+unicode.normalize math unicode.categories combinators
assocs strings splitting ;
IN: unicode.case
+: at-default ( key assoc -- value/key ) over >r at r> or ;
+
: ch>lower ( ch -- lower ) simple-lower at-default ;
: ch>upper ( ch -- upper ) simple-upper at-default ;
: ch>title ( ch -- title ) simple-title at-default ;
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index d8e1e8937a..ba9c0370cc 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,5 +1,5 @@
USING: assocs math kernel sequences io.files hashtables
-quotations splitting arrays math.parser combinators.lib hash2
+quotations splitting arrays math.parser hash2
byte-arrays words namespaces words compiler.units parser io.encodings.ascii ;
IN: unicode.data
@@ -44,7 +44,7 @@ IN: unicode.data
dup [ swap (chain-decomposed) ] curry assoc-map ;
: first* ( seq -- ? )
- second [ empty? ] [ first ] either ;
+ second dup empty? [ ] [ first ] ?if ;
: (process-decomposed) ( data -- alist )
5 swap (process-data)
diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor
index d62beb1a2c..951430b2b5 100644
--- a/extra/unicode/normalize/normalize.factor
+++ b/extra/unicode/normalize/normalize.factor
@@ -1,5 +1,4 @@
-USING: sequences namespaces unicode.data kernel combinators.lib
-math arrays ;
+USING: sequences namespaces unicode.data kernel math arrays ;
IN: unicode.normalize
! Conjoining Jamo behavior
@@ -19,7 +18,7 @@ IN: unicode.normalize
! These numbers come from UAX 29
: initial? ( ch -- ? )
- [ HEX: 1100 HEX: 1159 ?between? ] [ HEX: 115F = ] either ;
+ dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ;
: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ;
: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ;
From b886718609ad94b834051d7780505a81f15c4697 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 07:57:40 -0500
Subject: [PATCH 184/288] opengl no longer depends on *.lib
---
extra/opengl/gl/extensions/extensions.factor | 6 +++---
extra/opengl/opengl-docs.factor | 2 +-
2 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor
index b0a683dac6..b8ac396c2f 100644
--- a/extra/opengl/gl/extensions/extensions.factor
+++ b/extra/opengl/gl/extensions/extensions.factor
@@ -1,6 +1,6 @@
USING: alien alien.syntax combinators kernel parser sequences
-system words namespaces hashtables init math arrays assocs
-sequences.lib continuations ;
+system words namespaces hashtables init math arrays assocs
+continuations ;
ERROR: unknown-gl-platform ;
<< {
@@ -30,7 +30,7 @@ reset-gl-function-number-counter
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
[ 2nip ] [
- >r [ gl-function-address ] attempt-each
+ >r [ gl-function-address ] map [ ] find nip
dup [ "OpenGL function not available" throw ] unless
dup r>
+gl-function-pointers+ get-global set-at
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index 5b1ee0d565..2788ebdfc2 100644
--- a/extra/opengl/opengl-docs.factor
+++ b/extra/opengl/opengl-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs vocabs.loader sequences ;
+opengl.gl assocs vocabs.loader sequences ;
IN: opengl
HELP: gl-color
From f94596af576070c03acc34d0fbc95ef64c8da59a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 07:57:51 -0500
Subject: [PATCH 185/288] ui no longer depends on *.lib
---
extra/ui/gestures/gestures.factor | 16 ++++++++--------
extra/ui/tools/interactor/interactor.factor | 5 +++--
2 files changed, 11 insertions(+), 10 deletions(-)
diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor
index 412a61bcb5..e52eff453a 100755
--- a/extra/ui/gestures/gestures.factor
+++ b/extra/ui/gestures/gestures.factor
@@ -2,9 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes ui.gadgets combinators.lib
-boxes
-calendar alarms symbols ;
+math.vectors classes.tuple classes ui.gadgets boxes
+calendar alarms symbols combinators ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
@@ -188,11 +187,12 @@ SYMBOL: drag-timer
: multi-click? ( button -- ? )
{
- [ multi-click-timeout? ]
- [ multi-click-button? ]
- [ multi-click-position? ]
- [ multi-click-position? ]
- } && nip ;
+ { [ multi-click-timeout? not ] [ f ] }
+ { [ multi-click-button? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ { [ t ] [ t ] }
+ } cond nip ;
: update-click# ( button -- )
global [
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index c760867d71..8232094e76 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -3,7 +3,7 @@
USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math
math.vectors models namespaces parser prettyprint quotations
-sequences sequences.lib strings threads listener
+sequences strings threads listener
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions boxes calendar concurrency.flags ui.tools.workspace
@@ -105,7 +105,8 @@ M: interactor model-changed
] curry "input" suspend ;
M: interactor stream-readln
- [ interactor-yield ] keep interactor-finish ?first ;
+ [ interactor-yield ] keep interactor-finish
+ dup [ first ] when ;
: interactor-call ( quot interactor -- )
dup interactor-busy? [
From 2c76171c8a7b6fb4a502b7a8573bff4250f7d813 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 08:27:07 -0500
Subject: [PATCH 186/288] Fix profiler crash with large heap
---
vm/data_gc.c | 21 +++++++++++++++++++++
vm/data_gc.h | 2 ++
vm/factor.c | 15 +--------------
vm/profiler.c | 16 +++++++++-------
4 files changed, 33 insertions(+), 21 deletions(-)
diff --git a/vm/data_gc.c b/vm/data_gc.c
index b7bba4997e..86552d6401 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -821,3 +821,24 @@ DEFINE_PRIMITIVE(become)
gc();
}
+
+CELL find_all_words(void)
+{
+ GROWABLE_ARRAY(words);
+
+ begin_scan();
+
+ CELL obj;
+ while((obj = next_object()) != F)
+ {
+ if(type_of(obj) == WORD_TYPE)
+ GROWABLE_ADD(words,obj);
+ }
+
+ /* End heap scan */
+ gc_off = false;
+
+ GROWABLE_TRIM(words);
+
+ return words;
+}
diff --git a/vm/data_gc.h b/vm/data_gc.h
index acbc38a6cb..0adcf0ca39 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -365,3 +365,5 @@ DLLEXPORT void simple_gc(void);
DECLARE_PRIMITIVE(gc);
DECLARE_PRIMITIVE(gc_time);
DECLARE_PRIMITIVE(become);
+
+CELL find_all_words(void);
diff --git a/vm/factor.c b/vm/factor.c
index c3d85eff5e..073b3e2e34 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -38,21 +38,8 @@ void do_stage1_init(void)
fprintf(stderr,"*** Stage 2 early init... ");
fflush(stderr);
- GROWABLE_ARRAY(words);
+ CELL words = find_all_words();
- begin_scan();
-
- CELL obj;
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- GROWABLE_ADD(words,obj);
- }
-
- /* End heap scan */
- gc_off = false;
-
- GROWABLE_TRIM(words);
REGISTER_ROOT(words);
CELL i;
diff --git a/vm/profiler.c b/vm/profiler.c
index 407fefaace..08bb846c85 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -61,17 +61,19 @@ void set_profiling(bool profiling)
and allocate profiling blocks if necessary */
gc();
- /* Update word XTs and saved callstack objects */
- begin_scan();
+ CELL words = find_all_words();
- CELL obj;
- while((obj = next_object()) != F)
+ REGISTER_ROOT(words);
+
+ CELL i;
+ CELL length = array_capacity(untag_object(words));
+ for(i = 0; i < length; i++)
{
- if(type_of(obj) == WORD_TYPE)
- update_word_xt(untag_object(obj));
+ F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ update_word_xt(word);
}
- gc_off = false; /* end heap scan */
+ UNREGISTER_ROOT(words);
/* Update XTs in code heap */
iterate_code_heap(relocate_code_block);
From 6f1d3d9174a95f3437366882bb86810c0d1e7b8a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 08:30:02 -0500
Subject: [PATCH 187/288] cocoa no longer depends on xml
---
extra/cocoa/cocoa.factor | 2 ++
extra/cocoa/plists/plists.factor | 32 +++++++++++--------------
extra/tools/deploy/macosx/macosx.factor | 23 +++++++++---------
3 files changed, 27 insertions(+), 30 deletions(-)
diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor
index c94984f00b..f4cfb20591 100755
--- a/extra/cocoa/cocoa.factor
+++ b/extra/cocoa/cocoa.factor
@@ -42,11 +42,13 @@ SYMBOL: super-sent-messages
"NSArray"
"NSAutoreleasePool"
"NSBundle"
+ "NSDictionary"
"NSError"
"NSEvent"
"NSException"
"NSMenu"
"NSMenuItem"
+ "NSMutableDictionary"
"NSNib"
"NSNotification"
"NSNotificationCenter"
diff --git a/extra/cocoa/plists/plists.factor b/extra/cocoa/plists/plists.factor
index 5965c74af8..9e05773f53 100644
--- a/extra/cocoa/plists/plists.factor
+++ b/extra/cocoa/plists/plists.factor
@@ -1,23 +1,19 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: strings arrays hashtables assocs sequences
-xml.writer xml.utilities kernel namespaces ;
+cocoa.messages cocoa.classes cocoa.application cocoa kernel
+namespaces io.backend ;
IN: cocoa.plists
-GENERIC: >plist ( obj -- tag )
+: assoc>NSDictionary ( assoc -- alien )
+ NSMutableDictionary over assoc-size -> dictionaryWithCapacity:
+ [
+ [
+ spin [ <NSString> ] bi@ -> setObject:forKey:
+ ] curry assoc-each
+ ] keep ;
-M: string >plist "string" build-tag ;
-
-M: array >plist
- [ >plist ] map "array" build-tag* ;
-
-M: hashtable >plist
- >alist [ >r "key" build-tag r> >plist ] assoc-map concat
- "dict" build-tag* ;
-
-: build-plist ( obj -- tag )
- >plist 1array "plist" build-tag*
- dup { { "version" "1.0" } } update ;
-
-: plist>string ( obj -- string )
- build-plist build-xml xml>string ;
+: write-plist ( assoc path -- )
+ >r assoc>NSDictionary
+ r> normalize-path <NSString> 0 -> writeToFile:atomically:
+ [ "write-plist failed" throw ] unless ;
diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor
index 3a7f8e5d03..3121866d94 100755
--- a/extra/tools/deploy/macosx/macosx.factor
+++ b/extra/tools/deploy/macosx/macosx.factor
@@ -3,7 +3,8 @@
USING: io io.files kernel namespaces sequences
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
-cocoa.application cocoa.classes cocoa.plists qualified ;
+io.backend cocoa.application cocoa.classes cocoa.plists
+qualified ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
@@ -20,23 +21,21 @@ IN: tools.deploy.macosx
"fonts/" resource-path
swap "Contents/Resources/" append-path copy-tree-into ;
-: app-plist ( executable bundle-name -- string )
+: app-plist ( executable bundle-name -- assoc )
[
- namespace {
- { "CFBundleInfoDictionaryVersion" "6.0" }
- { "CFBundlePackageType" "APPL" }
- } update
+ "6.0" "CFBundleInfoDictionaryVersion" set
+ "APPL" "CFBundlePackageType" set
file-name "CFBundleName" set
- dup "CFBundleExecutable" set
- "org.factor." prepend "CFBundleIdentifier" set
- ] H{ } make-assoc plist>string ;
+ [ "CFBundleExecutable" set ]
+ [ "org.factor." prepend "CFBundleIdentifier" set ] bi
+ ] H{ } make-assoc ;
-: create-app-plist ( vocab bundle-name -- )
+: create-app-plist ( executable bundle-name -- )
[ app-plist ] keep
"Contents/Info.plist" append-path
- utf8 set-file-contents ;
+ write-plist ;
: create-app-dir ( vocab bundle-name -- vm )
dup "Frameworks" copy-bundle-dir
@@ -64,6 +63,6 @@ M: macosx deploy* ( vocab -- )
[ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep
namespace make-deploy-image
- bundle-name show-in-finder
+ bundle-name normalize-path show-in-finder
] bind
] with-directory ;
From 5f04c49d18ad3af6fa71e18789381485cd619d17 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 08:31:29 -0500
Subject: [PATCH 188/288] Fix windows deploy
---
extra/tools/deploy/windows/windows.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor
index 33ab877ee1..68b106663c 100755
--- a/extra/tools/deploy/windows/windows.factor
+++ b/extra/tools/deploy/windows/windows.factor
@@ -31,6 +31,6 @@ M: winnt deploy*
[ deploy-name get create-exe-dir ] keep
[ deploy-name get image-name ] keep
[ namespace make-deploy-image ] keep
- open-in-explorer
+ (normalize-path) open-in-explorer
] bind
] with-directory ;
From 871831fdae1364b58d87fc5b56f703250accc646 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 20:07:30 -0500
Subject: [PATCH 189/288] Fixing hook stack effects
---
core/generic/generic-tests.factor | 11 ----
core/generic/generic.factor | 5 +-
core/generic/standard/engines/engines.factor | 2 +
.../standard/engines/tuple/tuple.factor | 4 +-
core/generic/standard/standard-tests.factor | 39 ++++++++++++-
core/generic/standard/standard.factor | 55 ++++++++++---------
core/inference/backend/backend.factor | 4 +-
7 files changed, 79 insertions(+), 41 deletions(-)
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index 524835f461..bbd7186a11 100755
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -123,17 +123,6 @@ M: integer wii drop 6 ;
[ 3 ] [ T{ first-one } wii ] unit-test
-! Hooks
-SYMBOL: my-var
-HOOK: my-hook my-var ( -- x )
-
-M: integer my-hook "an integer" ;
-M: string my-hook "a string" ;
-
-[ "an integer" ] [ 3 my-var set my-hook ] unit-test
-[ "a string" ] [ my-hook my-var set my-hook ] unit-test
-[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
-
GENERIC: tag-and-f ( x -- x x )
M: fixnum tag-and-f 1 ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index f41f3ebcd0..cd08e80512 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -38,7 +38,10 @@ GENERIC: effective-method ( ... generic -- method )
: next-method ( class generic -- class/f )
[ next-method-class ] keep method ;
-GENERIC: next-method-quot ( class generic -- quot )
+GENERIC: next-method-quot* ( class generic -- quot )
+
+: next-method-quot ( class generic -- quot )
+ dup "combination" word-prop next-method-quot* ;
: (call-next-method) ( class generic -- )
next-method-quot call ;
diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor
index bf8d4fb67a..ccd64d1291 100644
--- a/core/generic/standard/engines/engines.factor
+++ b/core/generic/standard/engines/engines.factor
@@ -47,3 +47,5 @@ SYMBOL: (dispatch#)
} case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ;
+
+GENERIC: extra-values ( method generic -- n )
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 40e749f473..69d73aa872 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -66,7 +66,9 @@ PREDICATE: tuple-dispatch-engine-word < word
"tuple-dispatch-engine" word-prop ;
M: tuple-dispatch-engine-word stack-effect
- "tuple-dispatch-generic" word-prop stack-effect ;
+ "tuple-dispatch-generic" word-prop
+ [ extra-values ] [ stack-effect clone ] bi
+ [ length + ] change-in ;
M: tuple-dispatch-engine-word crossref?
drop t ;
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index 2f58770b1a..a906acd324 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -1,7 +1,8 @@
IN: generic.standard.tests
USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
-words float-arrays byte-arrays bit-arrays parser namespaces ;
+words float-arrays byte-arrays bit-arrays parser namespaces
+quotations inference vectors growable ;
GENERIC: lo-tag-test
@@ -194,7 +195,7 @@ M: ceo salary
[ 102000 ] [ executive construct-boa salary ] unit-test
[ ceo construct-boa salary ]
-[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with
+[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
[ intern construct-boa salary ]
[ T{ no-next-method f intern salary } = ] must-fail-with
@@ -233,3 +234,37 @@ M: c funky* "c" , call-next-method ;
T{ a } funky
{ { "a" "x" "z" } { "a" "y" "z" } } member?
] unit-test
+
+! Hooks
+SYMBOL: my-var
+HOOK: my-hook my-var ( -- x )
+
+M: integer my-hook "an integer" ;
+M: string my-hook "a string" ;
+
+[ "an integer" ] [ 3 my-var set my-hook ] unit-test
+[ "a string" ] [ my-hook my-var set my-hook ] unit-test
+[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
+
+HOOK: my-tuple-hook my-var ( -- x )
+
+M: sequence my-tuple-hook my-hook ;
+
+[ f ] [
+ \ my-tuple-hook [ "engines" word-prop ] keep prefix
+ [ 1quotation infer ] map all-equal?
+] unit-test
+
+HOOK: call-next-hooker my-var ( -- x )
+
+M: sequence call-next-hooker "sequence" ;
+
+M: array call-next-hooker call-next-method "array " prepend ;
+
+M: vector call-next-hooker call-next-method "vector " prepend ;
+
+M: growable call-next-hooker call-next-method "growable " prepend ;
+
+[ "vector growable sequence" ] [
+ V{ } my-var [ call-next-hooker ] with-variable
+] unit-test
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 9f9a892fd4..ed5134a624 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -67,7 +67,9 @@ ERROR: no-method object generic ;
drop generic get "default-method" word-prop 1quotation
] unless ;
-GENERIC: mangle-method ( method generic -- quot )
+: mangle-method ( method generic -- quot )
+ [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
+ prepend [ ] like ;
: single-combination ( word -- quot )
[
@@ -91,6 +93,23 @@ GENERIC: mangle-method ( method generic -- quot )
} cleave
] with-scope ;
+ERROR: inconsistent-next-method class generic ;
+
+ERROR: no-next-method class generic ;
+
+: single-next-method-quot ( class generic -- quot )
+ [
+ [ drop [ instance? ] curry % ]
+ [
+ 2dup next-method
+ [ 2nip 1quotation ]
+ [ [ no-next-method ] 2curry ] if* ,
+ ]
+ [ [ inconsistent-next-method ] 2curry , ]
+ 2tri
+ \ if ,
+ ] [ ] make ;
+
TUPLE: standard-combination # ;
C: <standard-combination> standard-combination
@@ -107,8 +126,7 @@ PREDICATE: simple-generic < standard-generic
: with-standard ( combination quot -- quot' )
>r #>> (dispatch#) r> with-variable ; inline
-M: standard-generic mangle-method
- drop 1quotation ;
+M: standard-generic extra-values drop 0 ;
M: standard-combination make-default-method
[ empty-method ] with-standard ;
@@ -118,30 +136,15 @@ M: standard-combination perform-combination
M: standard-combination dispatch# #>> ;
+M: standard-combination next-method-quot*
+ [
+ single-next-method-quot picker prepend
+ ] with-standard ;
+
M: standard-generic effective-method
[ dispatch# (picker) call ] keep
[ order [ instance? ] with find-last nip ] keep method ;
-ERROR: inconsistent-next-method object class generic ;
-
-ERROR: no-next-method class generic ;
-
-M: standard-generic next-method-quot
- [
- [
- [ [ instance? ] curry ]
- [ dispatch# (picker) ] bi* prepend %
- ]
- [
- 2dup next-method
- [ 2nip 1quotation ]
- [ [ no-next-method ] 2curry ] if* ,
- ]
- [ [ inconsistent-next-method ] 2curry , ]
- 2tri
- \ if ,
- ] [ ] make ;
-
TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
@@ -156,8 +159,7 @@ PREDICATE: hook-generic < generic
M: hook-combination dispatch# drop 0 ;
-M: hook-generic mangle-method
- drop 1quotation [ drop ] prepend ;
+M: hook-generic extra-values drop 1 ;
M: hook-combination make-default-method
[ error-method ] with-hook ;
@@ -165,6 +167,9 @@ M: hook-combination make-default-method
M: hook-combination perform-combination
[ drop ] [ [ single-combination ] with-hook ] 2bi define ;
+M: hook-combination next-method-quot*
+ [ single-next-method-quot ] with-hook ;
+
M: simple-generic definer drop \ GENERIC: f ;
M: standard-generic definer drop \ GENERIC# f ;
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index c0de217bd1..3dcb1d2360 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -36,6 +36,8 @@ TUPLE: inference-error error type rstate ;
M: inference-error compiler-error-type type>> ;
+M: inference-error error-help error>> error-help ;
+
: (inference-error) ( ... class type -- * )
>r construct-boa r>
recursive-state get
@@ -359,7 +361,7 @@ TUPLE: effect-error word effect ;
\ effect-error inference-error ;
: check-effect ( word effect -- )
- dup pick "declared-effect" word-prop effect<=
+ dup pick stack-effect effect<=
[ 2drop ] [ effect-error ] if ;
: finish-word ( word -- )
From 1f838811e8a2a9e6d3a94337320109bc99439021 Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Sat, 5 Apr 2008 19:15:35 -0500
Subject: [PATCH 190/288] Fix X11 UI
---
extra/ui/x11/x11.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor
index 9445486656..3ad10a6991 100755
--- a/extra/ui/x11/x11.factor
+++ b/extra/ui/x11/x11.factor
@@ -4,8 +4,9 @@ USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
namespaces opengl sequences strings x11.xlib x11.events x11.xim
x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
-io.encodings.utf8 combinators debugger system command-line
+io.encodings.utf8 combinators debugger command-line qualified
ui.render math.vectors classes.tuple opengl.gl threads ;
+QUALIFIED: system
IN: ui.x11
SINGLETON: x11-ui-backend
@@ -261,5 +262,5 @@ M: x11-ui-backend ui ( -- )
x11-ui-backend ui-backend set-global
-[ "DISPLAY" os-env "ui" "listener" ? ]
+[ "DISPLAY" system:os-env "ui" "listener" ? ]
main-vocab-hook set-global
From ec620ef0c829f2955d9a685270bd5b55c91ccabc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 5 Apr 2008 20:22:33 -0500
Subject: [PATCH 191/288] inheritance with postgresql
---
extra/db/db.factor | 52 ++++++++++++++---------
extra/db/postgresql/postgresql.factor | 59 +++++++++++++--------------
2 files changed, 61 insertions(+), 50 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 55e672ec80..3cade1a895 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -11,14 +11,19 @@ TUPLE: db
update-statements
delete-statements ;
-: <db> ( handle -- obj )
- H{ } clone H{ } clone H{ } clone
- db construct-boa ;
+: construct-db ( class -- obj )
+ construct-empty
+ H{ } clone >>insert-statements
+ H{ } clone >>update-statements
+ H{ } clone >>delete-statements ;
GENERIC: make-db* ( seq class -- db )
-GENERIC: db-open ( db -- )
+
+: make-db ( seq class -- db )
+ construct-db make-db* ;
+
+GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
-: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
@@ -30,10 +35,12 @@ HOOK: db-close db ( handle -- )
handle>> db-close
] with-variable ;
+! TUPLE: sql sql in-params out-params ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
-TUPLE: simple-statement ;
-TUPLE: prepared-statement ;
-TUPLE: nonthrowable-statement ;
+TUPLE: simple-statement < statement ;
+TUPLE: prepared-statement < statement ;
+TUPLE: nonthrowable-statement < statement ;
+TUPLE: throwable-statement < statement ;
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
@@ -41,14 +48,12 @@ TUPLE: nonthrowable-statement ;
nonthrowable-statement construct-delegate
] if ;
-MIXIN: throwable-statement
-INSTANCE: statement throwable-statement
-INSTANCE: simple-statement throwable-statement
-INSTANCE: prepared-statement throwable-statement
-
TUPLE: result-set sql in-params out-params handle n max ;
-: <statement> ( sql in out -- statement )
- { (>>sql) (>>in-params) (>>out-params) } statement construct ;
+: construct-statement ( sql in out class -- statement )
+ construct-empty
+ swap >>out-params
+ swap >>in-params
+ swap >>sql ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
@@ -88,10 +93,17 @@ M: nonthrowable-statement execute-statement ( statement -- )
dup #rows >>max
0 >>n drop ;
-: <result-set> ( query handle tuple -- result-set )
- >r >r { sql>> in-params>> out-params>> } get-slots r>
- { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
- construct r> construct-delegate ;
+: construct-result-set ( query handle class -- result-set )
+ construct-empty
+ swap >>handle
+ >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
+ swap >>out-params
+ swap >>in-params
+ swap >>sql ;
+
+ ! >r >r { sql>> in-params>> out-params>> } get-slots r>
+ ! { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
+ ! construct r> construct-delegate ;
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
@@ -110,7 +122,7 @@ M: nonthrowable-statement execute-statement ( statement -- )
accumulator >r query-each r> { } like ; inline
: with-db ( db seq quot -- )
- >r make-db dup db-open db r>
+ >r make-db db-open db r>
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
: default-query ( query -- result-set )
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index f9805560ad..322143e7a2 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -5,40 +5,39 @@ kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
-namespaces.lib ;
+namespaces.lib accessors ;
IN: db.postgresql
-TUPLE: postgresql-db host port pgopts pgtty db user pass ;
-TUPLE: postgresql-statement ;
-INSTANCE: postgresql-statement throwable-statement
-TUPLE: postgresql-result-set ;
+TUPLE: postgresql-db < db
+ host port pgopts pgtty db user pass ;
+
+TUPLE: postgresql-statement < throwable-statement ;
+
+TUPLE: postgresql-result-set < result-set ;
+
: <postgresql-statement> ( statement in out -- postgresql-statement )
- <statement>
- postgresql-statement construct-delegate ;
+ postgresql-statement construct-statement ;
M: postgresql-db make-db* ( seq tuple -- db )
- >r first4 r> [
- {
- set-postgresql-db-host
- set-postgresql-db-user
- set-postgresql-db-pass
- set-postgresql-db-db
- } set-slots
- ] keep ;
+ >r first4 r>
+ swap >>db
+ swap >>pass
+ swap >>user
+ swap >>host ;
-M: postgresql-db db-open ( db -- )
- dup {
- postgresql-db-host
- postgresql-db-port
- postgresql-db-pgopts
- postgresql-db-pgtty
- postgresql-db-db
- postgresql-db-user
- postgresql-db-pass
- } get-slots connect-postgres <db> swap set-delegate ;
+M: postgresql-db db-open ( db -- db )
+ dup {
+ [ host>> ]
+ [ port>> ]
+ [ pgopts>> ]
+ [ pgtty>> ]
+ [ db>> ]
+ [ user>> ]
+ [ pass>> ]
+ } cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- )
- db-handle PQfinish ;
+ handle>> PQfinish ;
M: postgresql-statement bind-statement* ( statement -- )
drop ;
@@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- )
] keep set-statement-bind-params ;
M: postgresql-result-set #rows ( result-set -- n )
- result-set-handle PQntuples ;
+ handle>> PQntuples ;
M: postgresql-result-set #columns ( result-set -- n )
- result-set-handle PQnfields ;
+ handle>> PQnfields ;
M: postgresql-result-set row-column ( result-set column -- obj )
>r dup result-set-handle swap result-set-n r> pq-get-string ;
@@ -69,7 +68,7 @@ M: postgresql-statement query-results ( query -- result-set )
] [
dup do-postgresql-statement
] if*
- postgresql-result-set <result-set>
+ postgresql-result-set construct-result-set
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
@@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
- >r db get db-handle "" r>
+ >r db get handle>> "" r>
dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
From 29406f07ebb0ae91d5c488c12b4cc3df9efa0e4b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 21:30:16 -0500
Subject: [PATCH 192/288] Fix declaration
---
core/generic/standard/engines/engines.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor
index ccd64d1291..1f0b80e016 100644
--- a/core/generic/standard/engines/engines.factor
+++ b/core/generic/standard/engines/engines.factor
@@ -48,4 +48,4 @@ SYMBOL: (dispatch#)
: picker ( -- quot ) \ (dispatch#) get (picker) ;
-GENERIC: extra-values ( method generic -- n )
+GENERIC: extra-values ( generic -- n )
From f1bacc2110e1f8d64d5e59ecccc941e76b91d1d4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 22:59:31 -0500
Subject: [PATCH 193/288] Smarter breakpoint word
---
extra/tools/annotations/annotations.factor | 22 ++++++++++++++++++----
1 file changed, 18 insertions(+), 4 deletions(-)
diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor
index 07038ceadf..ef710ea57d 100755
--- a/extra/tools/annotations/annotations.factor
+++ b/extra/tools/annotations/annotations.factor
@@ -2,10 +2,16 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
prettyprint continuations effects definitions compiler.units
-namespaces assocs tools.walker ;
+namespaces assocs tools.walker generic ;
IN: tools.annotations
-: reset ( word -- )
+GENERIC: reset ( word -- )
+
+M: generic reset
+ [ call-next-method ]
+ [ subwords [ reset ] each ] bi ;
+
+M: word reset
dup "unannotated-def" word-prop [
[
dup dup "unannotated-def" word-prop define
@@ -60,8 +66,16 @@ IN: tools.annotations
: watch-vars ( word vars -- )
dupd [ (watch-vars) ] 2curry annotate ;
+GENERIC# annotate-methods 1 ( word quot -- )
+
+M: generic annotate-methods
+ >r "methods" word-prop values r> [ annotate ] curry each ;
+
+M: word annotate-methods
+ annotate ;
+
: breakpoint ( word -- )
- [ add-breakpoint ] annotate ;
+ [ add-breakpoint ] annotate-methods ;
: breakpoint-if ( word quot -- )
- [ [ [ break ] when ] rot 3append ] curry annotate ;
+ [ [ [ break ] when ] rot 3append ] curry annotate-methods ;
From ab5ebd0f5a26f289539910c7cb9585ce885c22c6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 23:26:33 -0500
Subject: [PATCH 194/288] Fix buffering issue
---
extra/io/unix/launcher/launcher.factor | 2 +-
extra/unix/unix.factor | 1 +
2 files changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index ef0107beb1..c104587c77 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -77,7 +77,7 @@ USE: unix
get-arguments exec-args-with-path
(io-error)
- ] [ 255 exit ] recover ;
+ ] [ 255 _exit "Exit failed" throw ] recover ;
M: unix current-process-handle ( -- handle ) getpid ;
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index e911a5c039..3d4ce3cd48 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -43,6 +43,7 @@ FUNCTION: int dup2 ( int oldd, int newd ) ;
FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
+FUNCTION: int _exit ( int status ) ;
FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
From d2468ad9ed38e6aca0fc80691a5f662208de4a7f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Apr 2008 23:31:41 -0500
Subject: [PATCH 195/288] Add launcher error codes
---
extra/io/unix/launcher/launcher.factor | 22 +++++++++++-----------
extra/unix/unix.factor | 4 +++-
2 files changed, 14 insertions(+), 12 deletions(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index c104587c77..2736764665 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -66,18 +66,18 @@ USE: unix
?closed write-flags 2 redirect
] if ;
-: spawn-process ( process -- * )
- [
- setup-priority
- setup-redirection
- current-directory get (normalize-path) cd
- dup pass-environment? [
- dup get-environment set-os-envs
- ] when
+: setup-environment ( process -- process )
+ dup pass-environment? [
+ dup get-environment set-os-envs
+ ] when ;
- get-arguments exec-args-with-path
- (io-error)
- ] [ 255 _exit "Exit failed" throw ] recover ;
+: spawn-process ( process -- * )
+ [ setup-priority ] [ 250 _exit ] recover
+ [ setup-redirection ] [ 251 _exit ] recover
+ [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover
+ [ setup-environment ] [ 253 _exit ] recover
+ [ get-arguments exec-args-with-path ] [ 254 _exit ] recover
+ 255 _exit ;
M: unix current-process-handle ( -- handle ) getpid ;
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index 3d4ce3cd48..9005cd2b2a 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -43,7 +43,9 @@ FUNCTION: int dup2 ( int oldd, int newd ) ;
FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
-FUNCTION: int _exit ( int status ) ;
+: _exit ( status -- * )
+ #! We throw to give this a terminating stack effect.
+ "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
From aade46d44874b2223a3d81eff411e1e80de98b05 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 6 Apr 2008 00:37:12 -0500
Subject: [PATCH 196/288] sqlite inheritance
---
extra/db/sqlite/sqlite.factor | 44 +++++++++++++----------------------
1 file changed, 16 insertions(+), 28 deletions(-)
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 9b3185bcf2..d14403648d 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -5,61 +5,49 @@ hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
-io namespaces.lib ;
-USE: tools.walker
+io namespaces.lib accessors ;
IN: db.sqlite
-TUPLE: sqlite-db path ;
+TUPLE: sqlite-db < db path ;
M: sqlite-db make-db* ( path db -- db )
- [ set-sqlite-db-path ] keep ;
+ swap >>path ;
-M: sqlite-db db-open ( db -- )
- dup sqlite-db-path sqlite-open <db>
- swap set-delegate ;
+M: sqlite-db db-open ( db -- db )
+ [ path>> sqlite-open ] [ swap >>handle ] bi ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
-: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
-TUPLE: sqlite-statement ;
-INSTANCE: sqlite-statement throwable-statement
+TUPLE: sqlite-statement < throwable-statement ;
+! INSTANCE: sqlite-statement throwable-statement
-TUPLE: sqlite-result-set has-more? ;
+TUPLE: sqlite-result-set < result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str in out -- obj )
- {
- set-statement-sql
- set-statement-in-params
- set-statement-out-params
- } statement construct
- sqlite-statement construct-delegate ;
+ sqlite-statement construct-statement ;
: sqlite-maybe-prepare ( statement -- statement )
- dup statement-handle [
- [
- delegate
- db get db-handle over statement-sql sqlite-prepare
- swap set-statement-handle
- ] keep
+ dup handle>> [
+ db get handle>> over sql>> sqlite-prepare
+ >>handle
] unless ;
M: sqlite-statement dispose ( statement -- )
- statement-handle
+ handle>>
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- )
- f swap set-result-set-handle ;
+ f >>handle drop ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- )
- sqlite-maybe-prepare
- statement-handle sqlite-reset ;
+ sqlite-maybe-prepare handle>> sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
@@ -104,7 +92,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare
- dup statement-handle sqlite-result-set <result-set>
+ dup statement-handle sqlite-result-set construct-result-set
dup advance-row ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
From 562ccb24f344789b0a1f9a3947803212bb745551 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 6 Apr 2008 00:53:50 -0500
Subject: [PATCH 197/288] Fix Windows launcher issue
---
extra/io/windows/launcher/launcher-tests.factor | 10 ++++++++++
extra/io/windows/launcher/launcher.factor | 15 ++++++++++++++-
2 files changed, 24 insertions(+), 1 deletion(-)
create mode 100755 extra/io/windows/launcher/launcher-tests.factor
diff --git a/extra/io/windows/launcher/launcher-tests.factor b/extra/io/windows/launcher/launcher-tests.factor
new file mode 100755
index 0000000000..1dba8bd0ec
--- /dev/null
+++ b/extra/io/windows/launcher/launcher-tests.factor
@@ -0,0 +1,10 @@
+IN: io.windows.launcher.tests
+USING: tools.test io.windows.launcher ;
+
+[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test
+
+[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test
+
+[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test
+
+[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 410e13d266..04e149d261 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -44,8 +44,21 @@ TUPLE: CreateProcess-args
lpProcessInformation>>
} get-slots CreateProcess win32-error=0/f ;
+: count-trailing-backslashes ( str n -- str n )
+ >r "\\" ?tail [
+ r> 1+ count-trailing-backslashes
+ ] [
+ r>
+ ] if ;
+
+: fix-trailing-backslashes ( str -- str' )
+ 0 count-trailing-backslashes
+ 2 * CHAR: \\ <repetition> append ;
+
: escape-argument ( str -- newstr )
- CHAR: \s over member? [ "\"" swap "\"" 3append ] when ;
+ CHAR: \s over member? [
+ "\"" swap fix-trailing-backslashes "\"" 3append
+ ] when ;
: join-arguments ( args -- cmd-line )
[ escape-argument ] map " " join ;
From 0804c7e7af0f68696b57c4666838ff5e1da14414 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 6 Apr 2008 01:22:52 -0500
Subject: [PATCH 198/288] cleanup
---
extra/db/sqlite/sqlite.factor | 46 +++++++++++++++++------------------
1 file changed, 22 insertions(+), 24 deletions(-)
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index d14403648d..e0930f3ba8 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -20,7 +20,6 @@ M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
TUPLE: sqlite-statement < throwable-statement ;
-! INSTANCE: sqlite-statement throwable-statement
TUPLE: sqlite-result-set < result-set has-more? ;
@@ -57,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- )
M: sqlite-statement bind-tuple ( tuple statement -- )
[
- statement-in-params
+ in-params>>
[
- [ sql-spec-column-name ":" prepend ]
- [ sql-spec-slot-name rot get-slot-named ]
- [ sql-spec-type ] tri 3array
+ [ column-name>> ":" prepend ]
+ [ slot-name>> rot get-slot-named ]
+ [ type>> ] tri 3array
] with map
] keep
bind-statement ;
@@ -71,28 +70,27 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-db insert-tuple* ( tuple statement -- )
- execute-statement last-insert-id swap set-primary-key ;
+ execute-statement last-insert-id >>primary-key drop ;
M: sqlite-result-set #columns ( result-set -- n )
- result-set-handle sqlite-#columns ;
+ handle>> sqlite-#columns ;
M: sqlite-result-set row-column ( result-set n -- obj )
- >r result-set-handle r> sqlite-column ;
+ [ handle>> ] [ sqlite-column ] bi* ;
M: sqlite-result-set row-column-typed ( result-set n -- obj )
- dup pick result-set-out-params nth sql-spec-type
- >r >r result-set-handle r> r> sqlite-column-typed ;
+ dup pick out-params>> nth type>>
+ >r >r handle>> r> r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
- [ result-set-handle sqlite-next ] keep
- set-sqlite-result-set-has-more? ;
+ dup handle>> sqlite-next >>has-more? drop ;
M: sqlite-result-set more-rows? ( result-set -- ? )
- sqlite-result-set-has-more? ;
+ has-more?>> ;
M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare
- dup statement-handle sqlite-result-set construct-result-set
+ dup handle>> sqlite-result-set construct-result-set
dup advance-row ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
@@ -107,9 +105,9 @@ M: sqlite-db create-sql-statement ( class -- statement )
[
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
- dup sql-spec-column-name 0%
+ dup column-name>> 0%
" " 0%
- dup sql-spec-type t lookup-type 0%
+ dup type>> t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] sqlite-make ;
@@ -122,7 +120,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
"insert into " 0% 0%
"(" 0%
maybe-remove-id
- dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
@@ -133,11 +131,11 @@ M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
: where-primary-key% ( specs -- )
" where " 0%
- find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
+ find-primary-key dup column-name>> 0% " = " 0% bind% ;
: where-clause ( specs -- )
" where " 0%
- [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
+ [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
@@ -145,7 +143,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
0%
" set " 0%
dup remove-id
- [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+ [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
where-primary-key%
] sqlite-make ;
@@ -154,23 +152,23 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
"delete from " 0% 0%
" where " 0%
find-primary-key
- dup sql-spec-column-name 0% " = " 0% bind%
+ dup column-name>> 0% " = " 0% bind%
] sqlite-make ;
! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ;
M: sqlite-db bind% ( spec -- )
- dup 1, sql-spec-column-name ":" prepend 0% ;
+ dup 1, column-name>> ":" prepend 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
over [ ", " 0% ]
- [ dup sql-spec-column-name 0% 2, ] interleave
+ [ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
- [ sql-spec-slot-name swap get-slot-named ] with subset
+ [ column-name>> swap get-slot-named ] with subset
dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ;
From 49e3422d84569caf5836aafb068cce2fd1e52331 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 6 Apr 2008 01:23:00 -0500
Subject: [PATCH 199/288] Comment out failing delegate unit tests since those
features aren't used right now
---
extra/delegate/delegate-tests.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor
index 497a6c5120..5e0abcd5ba 100644
--- a/extra/delegate/delegate-tests.factor
+++ b/extra/delegate/delegate-tests.factor
@@ -36,15 +36,15 @@ MIMIC: bee goodbye hello
[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
-[ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
+! [ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ V{ goodbye } ] [ baz protocol-users ] unit-test
-[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
-[ [ baz see ] with-string-writer ] unit-test
+! [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
+! [ [ baz see ] with-string-writer ] unit-test
! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
! [ f ] [ goodbye baz method ] unit-test
From 22bf0625c6334eaa9174dd3d0414fd0affac2538 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 6 Apr 2008 01:51:04 -0500
Subject: [PATCH 200/288] Fix 64-bit deploy tests
---
extra/tools/deploy/deploy-tests.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index f104fb0210..99e533f1c1 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -23,7 +23,7 @@ namespaces continuations layouts ;
[ ] [ "sudoku" shake-and-bake ] unit-test
[ t ] [
- 1500000 small-enough?
+ cell 8 = 30 15 ? 100000 * small-enough?
] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test
@@ -34,13 +34,13 @@ namespaces continuations layouts ;
] unit-test
[ t ] [
- 2000000 small-enough?
+ cell 8 = 40 20 ? 100000 * small-enough?
] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [
- 3000000 small-enough?
+ cell 8 = 50 30 ? 100000 * small-enough?
] unit-test
[ ] [
From 4586200f83841bbac572c30301883e762818f08d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 6 Apr 2008 03:30:10 -0500
Subject: [PATCH 201/288] Fix launcher failure on *BSD
---
extra/io/unix/launcher/launcher.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 2736764665..82852f6311 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -31,7 +31,10 @@ USE: unix
: redirect-fd ( oldfd fd -- )
2dup = [ 2drop ] [ dupd dup2 io-error close ] if ;
-: reset-fd ( fd -- ) F_SETFL 0 fcntl io-error ;
+: reset-fd ( fd -- )
+ #! We drop the error code because on *BSD, fcntl of
+ #! /dev/null fails.
+ F_SETFL 0 fcntl drop ;
: redirect-inherit ( obj mode fd -- )
2nip reset-fd ;
From 70573c01f07b1aecd9abe14fd44b0cd87f00a141 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 6 Apr 2008 14:33:01 -0500
Subject: [PATCH 202/288] comment out compiler error
---
extra/db/mysql/lib/lib.factor | 20 ++++++++++----------
1 file changed, 10 insertions(+), 10 deletions(-)
diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor
index 59d1b6ff3d..ca912f200d 100644
--- a/extra/db/mysql/lib/lib.factor
+++ b/extra/db/mysql/lib/lib.factor
@@ -18,16 +18,16 @@ TUPLE: mysql-result-set ;
: mysql-error ( mysql -- )
[ mysql_error throw ] when* ;
-: mysql-connect ( mysql-connection -- )
- new-mysql over set-mysql-db-handle
- dup {
- mysql-db-handle
- mysql-db-host
- mysql-db-user
- mysql-db-password
- mysql-db-db
- mysql-db-port
- } get-slots f 0 mysql_real_connect mysql-error ;
+! : mysql-connect ( mysql-connection -- )
+ ! new-mysql over set-mysql-db-handle
+ ! dup {
+ ! mysql-db-handle
+ ! mysql-db-host
+ ! mysql-db-user
+ ! mysql-db-password
+ ! mysql-db-db
+ ! mysql-db-port
+ ! } get-slots f 0 mysql_real_connect mysql-error ;
! =========================================================
! Low level mysql utility definitions
From d8dd8f967ec5c33d57fba093b4ad4580df413395 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 6 Apr 2008 16:22:05 -0500
Subject: [PATCH 203/288] Add frame-buffer
---
extra/frame-buffer/frame-buffer.factor | 113 +++++++++++++++++++++++++
1 file changed, 113 insertions(+)
create mode 100644 extra/frame-buffer/frame-buffer.factor
diff --git a/extra/frame-buffer/frame-buffer.factor b/extra/frame-buffer/frame-buffer.factor
new file mode 100644
index 0000000000..eb9ada7d84
--- /dev/null
+++ b/extra/frame-buffer/frame-buffer.factor
@@ -0,0 +1,113 @@
+
+USING: kernel alien.c-types combinators sequences splitting
+ opengl.gl ui.gadgets ui.render
+ math math.vectors accessors ;
+
+IN: frame-buffer
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
+ dup
+ rect-dim product "uint[4]" <c-array>
+ >>pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <frame-buffer> ( -- frame-buffer )
+ frame-buffer construct-gadget
+ [ ] >>action
+ { 100 100 } >>dim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: read-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ >r
+ 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer pref-dim* dim>> ;
+M: frame-buffer graft* graft>> call ;
+M: frame-buffer ungraft* ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: copy-row ( old new -- )
+ 2dup min-length swap >r head-slice 0 r> copy ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ group ] 2bi@
+! [ copy-row ] 2each ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ 16 * group ] 2bi@
+! [ copy-row ] 2each ;
+
+: copy-pixels ( old-pixels old-width new-pixels new-width -- )
+ [ 16 * <sliced-groups> ] 2bi@
+ [ copy-row ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer layout* ( fb -- )
+ {
+ {
+ [ dup last-dim>> f = ]
+ [
+ init-frame-buffer-pixels
+ dup
+ rect-dim >>last-dim
+ drop
+ ]
+ }
+ {
+ [ dup [ rect-dim ] [ last-dim>> ] bi = not ]
+ [
+ dup [ pixels>> ] [ last-dim>> first ] bi
+
+ rot init-frame-buffer-pixels
+ dup rect-dim >>last-dim
+
+ [ pixels>> ] [ rect-dim first ] bi
+
+ copy-pixels
+ ]
+ }
+ { [ t ] [ drop ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer draw-gadget* ( fb -- )
+
+ dup rect-dim { 0 1 } v* first2 glRasterPos2i
+
+ draw-pixels
+
+ dup action>> call
+
+ glFlush
+
+ read-pixels
+
+ drop ;
+
From ce895924bf0e70a7b7427fd6ff2b279623112f3c Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 6 Apr 2008 16:26:02 -0500
Subject: [PATCH 204/288] Move frame-buffer vocab
---
extra/{ => ui/gadgets}/frame-buffer/frame-buffer.factor | 0
1 file changed, 0 insertions(+), 0 deletions(-)
rename extra/{ => ui/gadgets}/frame-buffer/frame-buffer.factor (100%)
diff --git a/extra/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor
similarity index 100%
rename from extra/frame-buffer/frame-buffer.factor
rename to extra/ui/gadgets/frame-buffer/frame-buffer.factor
From 9dbc39f5810f7ab91181501a0f36de4c178cb5c3 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 6 Apr 2008 16:26:32 -0500
Subject: [PATCH 205/288] Set vocab name
---
extra/ui/gadgets/frame-buffer/frame-buffer.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor
index eb9ada7d84..4990254778 100644
--- a/extra/ui/gadgets/frame-buffer/frame-buffer.factor
+++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor
@@ -3,7 +3,7 @@ USING: kernel alien.c-types combinators sequences splitting
opengl.gl ui.gadgets ui.render
math math.vectors accessors ;
-IN: frame-buffer
+IN: ui.gadgets.frame-buffer
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 6508cf840ace232b4bc7df0a3089a8536b7b4de2 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 6 Apr 2008 16:27:21 -0500
Subject: [PATCH 206/288] newfx: Add a few words
---
extra/newfx/newfx.factor | 23 +++++++++++++++++++++++
1 file changed, 23 insertions(+)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index ae92f8f6c0..df826dc295 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -68,6 +68,29 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: delete ( seq elt -- seq ) over sequences:delete ;
+: delete-from ( elt seq -- seq ) tuck sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: deleted ( seq elt -- ) swap sequences:delete ;
+: deleted-from ( elt seq -- ) sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remove ( seq obj -- seq ) swap sequences:remove ;
+: remove-from ( obj seq -- seq ) sequences:remove ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: subset-of ( quot seq -- seq ) swap subset ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: map-over ( quot seq -- seq ) swap map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
From 90f730256bf61056687c6a2825f3fa117e63eb85 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 6 Apr 2008 16:36:12 -0500
Subject: [PATCH 207/288] Add extra/processing
---
extra/processing/color/color.factor | 22 ++
extra/processing/gadget/gadget.factor | 80 ++++++
extra/processing/processing.factor | 387 ++++++++++++++++++++++++++
3 files changed, 489 insertions(+)
create mode 100644 extra/processing/color/color.factor
create mode 100644 extra/processing/gadget/gadget.factor
create mode 100644 extra/processing/processing.factor
diff --git a/extra/processing/color/color.factor b/extra/processing/color/color.factor
new file mode 100644
index 0000000000..50d20fcf52
--- /dev/null
+++ b/extra/processing/color/color.factor
@@ -0,0 +1,22 @@
+
+USING: kernel sequences ;
+
+IN: processing.color
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: rgba red green blue alpha ;
+
+C: <rgba> rgba
+
+: <rgb> ( r g b -- rgba ) 1 <rgba> ;
+
+: <gray> ( gray -- rgba ) dup dup 1 <rgba> ;
+
+: {rgb} ( seq -- rgba ) first3 <rgb> ;
+
+! : hex>rgba ( hex -- rgba )
+
+! : set-gl-color ( color -- )
+! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
+
diff --git a/extra/processing/gadget/gadget.factor b/extra/processing/gadget/gadget.factor
new file mode 100644
index 0000000000..8b78c43f00
--- /dev/null
+++ b/extra/processing/gadget/gadget.factor
@@ -0,0 +1,80 @@
+
+USING: kernel namespaces combinators
+ ui.gestures qualified accessors ui.gadgets.frame-buffer ;
+
+IN: processing.gadget
+
+QUALIFIED: ui.gadgets
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: processing-gadget button-down button-up key-down key-up ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: set-gadget-delegate ( tuple gadget -- tuple )
+ over ui.gadgets:set-gadget-delegate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <processing-gadget> ( -- gadget )
+ processing-gadget construct-empty
+ <frame-buffer> set-gadget-delegate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: mouse-pressed-value
+SYMBOL: key-pressed-value
+
+SYMBOL: button-value
+SYMBOL: key-value
+
+: key-pressed? ( -- ? ) key-pressed-value get ;
+: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
+
+: key ( -- key ) key-value get ;
+: button ( -- val ) button-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: processing-gadget handle-gesture* ( gadget gesture delegate -- ? )
+ rot drop swap ! delegate gesture
+ {
+ {
+ [ dup key-down? ]
+ [
+ key-down-sym key-value set
+ key-pressed-value on
+ key-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup key-up? ]
+ [
+ key-pressed-value off
+ drop
+ key-up>> dup [ call ] [ drop ] if
+ t
+ ] }
+ {
+ [ dup button-down? ]
+ [
+ button-down-# button-value set
+ mouse-pressed-value on
+ button-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup button-up? ]
+ [
+ mouse-pressed-value off
+ drop
+ button-up>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ { [ t ] [ 2drop t ] }
+ }
+ cond ;
\ No newline at end of file
diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor
new file mode 100644
index 0000000000..acad02363b
--- /dev/null
+++ b/extra/processing/processing.factor
@@ -0,0 +1,387 @@
+
+USING: kernel namespaces threads combinators sequences arrays
+ math math.functions
+ opengl.gl opengl.glu vars multi-methods shuffle
+ ui
+ ui.gestures
+ ui.gadgets
+ combinators
+ combinators.lib
+ combinators.cleave
+ rewrite-closures fry accessors
+ processing.color
+ processing.gadget ;
+
+IN: processing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: fill-color
+VAR: stroke-color
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: set-color ( value -- )
+
+METHOD: set-color { number } dup dup glColor3d ;
+
+METHOD: set-color { array }
+ dup length
+ {
+ { 2 [ first2 >r dup dup r> glColor4d ] }
+ { 3 [ first3 glColor3d ] }
+ { 4 [ first4 glColor4d ] }
+ }
+ case ;
+
+METHOD: set-color { rgba }
+ { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill ( value -- ) >fill-color ;
+: stroke ( value -- ) >stroke-color ;
+
+: no-fill ( -- )
+ fill-color>
+ {
+ { [ dup number? ] [ 0 2array fill ] }
+ { [ t ]
+ [
+ [ drop 0 ] [ length 1- ] [ ] tri set-nth
+ ] }
+ }
+ cond ;
+
+: no-stroke ( -- )
+ stroke-color>
+ {
+ { [ dup number? ] [ 0 2array stroke ] }
+ { [ t ]
+ [
+ [ drop 0 ] [ length 1- ] [ ] tri set-nth
+ ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: stroke-weight ( w -- ) glLineWidth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point* ( x y -- )
+ stroke-color> set-color
+ GL_POINTS glBegin
+ glVertex2d
+ glEnd ;
+
+: point ( seq -- ) first2 point* ;
+
+: line ( x1 y1 x2 y2 -- )
+ stroke-color> set-color
+ GL_LINES glBegin
+ glVertex2d
+ glVertex2d
+ glEnd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: triangle ( x1 y1 x2 y2 x3 y3 -- )
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ 6 ndup
+
+ GL_TRIANGLES glBegin
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glEnd
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> set-color
+
+ GL_TRIANGLES glBegin
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glEnd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
+ GL_POLYGON glBegin
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glEnd ;
+
+: quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
+
+ 8 ndup
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ quad-vertices
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> set-color
+
+ quad-vertices ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rect-vertices ( x y width height -- )
+ GL_POLYGON glBegin
+ [ 2drop glVertex2d ] 4keep
+ [ drop swap >r + 1- r> glVertex2d ] 4keep
+ [ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep
+ [ nip + 1- glVertex2d ] 4keep
+ 4drop
+ glEnd ;
+
+: rect ( x y width height -- )
+
+ 4dup
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ rect-vertices
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> set-color
+
+ rect-vertices ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ellipse-disk ( x y width height -- )
+ glPushMatrix
+ >r >r
+ 0 glTranslated
+ r> r> 1 glScaled
+ gluNewQuadric
+ dup 0 0.5 20 1 gluDisk
+ gluDeleteQuadric
+ glPopMatrix ;
+
+: ellipse-center ( x y width height -- )
+
+ 4dup
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ stroke-color> set-color
+
+ ellipse-disk
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
+
+ ellipse-disk ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: CENTER
+SYMBOL: RADIUS
+SYMBOL: CORNER
+SYMBOL: CORNERS
+
+SYMBOL: ellipse-mode-value
+
+: ellipse-mode ( val -- ) ellipse-mode-value set ;
+
+: ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
+
+: ellipse-corner ( x y width height -- )
+ [ drop nip 2 / + ] 4keep
+ [ nip rot drop 2 / + ] 4keep
+ [ >r >r 2drop r> r> ] 4keep
+ 4drop
+ ellipse-center ;
+
+: ellipse-corners ( x1 y1 x2 y2 -- )
+ [ drop nip + 2 / ] 4keep
+ [ nip rot drop + 2 / ] 4keep
+ [ drop nip - abs 1+ ] 4keep
+ [ nip rot drop - abs 1+ ] 4keep
+ 4drop
+ ellipse-center ;
+
+: ellipse ( a b c d -- )
+ ellipse-mode-value get
+ {
+ { CENTER [ ellipse-center ] }
+ { RADIUS [ ellipse-radius ] }
+ { CORNER [ ellipse-corner ] }
+ { CORNERS [ ellipse-corners ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: multi-methods ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: background ( value -- )
+
+METHOD: background { number }
+ dup dup 1 glClearColor
+ GL_COLOR_BUFFER_BIT glClear ;
+
+METHOD: background { array }
+ dup length
+ {
+ { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ { 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ { 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: translate ( x y -- ) 0 glTranslated ;
+
+: rotate ( angle -- ) 0 0 1 glRotated ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse ( -- point ) hand-loc get ;
+
+: mouse-x mouse first ;
+: mouse-y mouse second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: frame-rate-value
+
+: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: slate
+
+VAR: loop-flag
+
+: defaults ( -- )
+ 0.8 background
+ 0 >stroke-color
+ 1 >fill-color
+ CENTER ellipse-mode
+ 60 frame-rate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: size-val
+
+: size ( seq -- ) size-val set ;
+
+: size* ( width height -- ) 2array size-val set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: setup-action
+SYMBOL: draw-action
+
+! : setup ( quot -- ) closed-quot setup-action set ;
+! : draw ( quot -- ) closed-quot draw-action set ;
+
+: setup ( quot -- ) setup-action set ;
+: draw ( quot -- ) draw-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-down-action
+SYMBOL: key-up-action
+
+: key-down ( quot -- ) closed-quot key-down-action set ;
+: key-up ( quot -- ) closed-quot key-up-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: button-down-action
+SYMBOL: button-up-action
+
+: button-down ( quot -- ) closed-quot button-down-action set ;
+: button-up ( quot -- ) closed-quot button-up-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start-processing-thread ( -- )
+ loop-flag get not
+ [
+ loop-flag on
+ [
+ [ loop-flag get ]
+ processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
+ [ ]
+ while
+ ]
+ in-thread
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-size ( -- size ) processing-gadget get rect-dim ;
+
+: width ( -- width ) get-size first ;
+: height ( -- height ) get-size second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: setup-called
+
+: setup-called? ( -- ? ) setup-called get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run ( -- )
+
+ loop-flag off
+
+ 500 sleep
+
+ <processing-gadget>
+ size-val get >>dim
+ dup "Processing" open-window
+
+ 500 sleep
+
+ defaults
+
+ setup-called off
+
+ [
+ setup-called? not
+ [
+ setup-action get call
+ setup-called on
+ ]
+ [
+ draw-action get call
+ ]
+ if
+ ]
+ closed-quot >>action
+
+ key-down-action get >>key-down
+ key-up-action get >>key-up
+
+ button-down-action get >>button-down
+ button-up-action get >>button-up
+
+ processing-gadget set
+
+ start-processing-thread ;
\ No newline at end of file
From d50d6a59efe5a21fe10c8093ed0e3afa22905b0c Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 6 Apr 2008 16:37:26 -0500
Subject: [PATCH 208/288] Add bubble-chamber demo
---
extra/bubble-chamber/bubble-chamber.factor | 477 +++++++++++++++++++++
1 file changed, 477 insertions(+)
create mode 100644 extra/bubble-chamber/bubble-chamber.factor
diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor
new file mode 100644
index 0000000000..ea8d309bdb
--- /dev/null
+++ b/extra/bubble-chamber/bubble-chamber.factor
@@ -0,0 +1,477 @@
+
+USING: kernel namespaces sequences combinators arrays threads
+
+ math
+ math.libm
+ math.vectors
+ math.ranges
+ math.constants
+ math.functions
+
+ ui
+ ui.gadgets
+
+ random accessors multi-methods
+ combinators.cleave
+ vars locals
+
+ newfx
+
+ processing
+ processing.gadget
+ processing.color ;
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
+
+: 1random ( b -- num ) 0 swap 2random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dim ( -- dim ) 1000 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: collision-theta
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: boom
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VARS: particles muons quarks hadrons axions ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: good-colors ( -- seq )
+ {
+ T{ rgba f 0.23 0.14 0.17 1 }
+ T{ rgba f 0.23 0.14 0.15 1 }
+ T{ rgba f 0.21 0.14 0.15 1 }
+ T{ rgba f 0.51 0.39 0.33 1 }
+ T{ rgba f 0.49 0.33 0.20 1 }
+ T{ rgba f 0.55 0.45 0.32 1 }
+ T{ rgba f 0.69 0.63 0.51 1 }
+ T{ rgba f 0.64 0.39 0.18 1 }
+ T{ rgba f 0.73 0.42 0.20 1 }
+ T{ rgba f 0.71 0.45 0.29 1 }
+ T{ rgba f 0.79 0.45 0.22 1 }
+ T{ rgba f 0.82 0.56 0.34 1 }
+ T{ rgba f 0.88 0.72 0.49 1 }
+ T{ rgba f 0.85 0.69 0.40 1 }
+ T{ rgba f 0.96 0.92 0.75 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.85 0.82 0.69 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.82 0.82 0.79 1 }
+ T{ rgba f 0.65 0.69 0.67 1 }
+ T{ rgba f 0.53 0.60 0.55 1 }
+ T{ rgba f 0.57 0.53 0.68 1 }
+ T{ rgba f 0.47 0.42 0.56 1 }
+ } ;
+
+: good-color ( i -- color ) good-colors nth-of ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x>> ( particle -- x ) pos>> first ;
+: y>> ( particle -- x ) pos>> second ;
+
+: >>x ( particle x -- particle ) over y>> 2array >>pos ;
+: >>y ( particle y -- particle ) over x>> swap 2array >>pos ;
+
+: x x>> ;
+: y y>> ;
+
+: v+y ( seq y -- seq ) >r first2 r> + 2array ;
+: v-y ( seq y -- seq ) >r first2 r> - 2array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: out-of-bounds? ( particle -- particle ? )
+ dup
+ { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
+ or or or ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: collide ( particle -- )
+GENERIC: move ( particle -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ;
+
+: <muon> ( -- muon )
+ muon construct-empty
+ 0 0 2array >>pos
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+ 0 0 0 1 <rgba> >>myc
+ 0 0 0 1 <rgba> >>mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { muon }
+
+ dim 2 / dup 2array >>pos
+ 2 32 [a,b] random >>speed
+ 0.0001 0.001 2random >>speed-d
+
+ collision-theta> -0.1 0.1 2random + >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ dup theta-dd>> abs 0.001 < ]
+ [ -0.1 0.1 2random >>theta-dd ]
+ [ ]
+ while
+
+ dup theta>> pi +
+ 2 pi * /
+ good-colors length 1 - *
+ [ ] [ good-colors length >= ] [ 0 < ] tri or
+ [ drop ]
+ [
+ [ good-color >>myc ]
+ [ good-colors length swap - 1 - good-color >>mya ]
+ bi
+ ]
+ if
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { muon }
+
+ dup myc>> 0.16 >>alpha stroke
+ dup pos>> point
+
+ dup mya>> 0.16 >>alpha stroke
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ move-by
+
+ [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
+ [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
+ [ ] [ speed>> ] [ speed-d>> ] tri - >>speed
+
+ out-of-bounds?
+ [ collide ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: quark pos vel speed theta speed-d theta-d theta-dd myc ;
+
+: <quark> ( -- quark )
+ quark construct-empty
+ 0 0 2array >>pos
+ 0 0 2array >>vel
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+ 0 0 0 1 <rgba> >>myc ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { quark }
+
+ dim 2 / dup 2array >>pos
+ collision-theta> -0.11 0.11 2random + >>theta
+ 0.5 3.0 2random >>speed
+
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ dup theta-dd>> abs 0.00001 < ]
+ [ -0.001 0.001 2random >>theta-dd ]
+ [ ]
+ while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { quark }
+
+ dup myc>> 0.13 >>alpha stroke
+ dup pos>> point
+
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ [ ] [ vel>> ] bi move-by
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel
+
+ [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
+ [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
+ [ ] [ speed>> ] [ speed-d>> ] tri * >>speed
+
+ 1000 random 997 >
+ [
+ dup speed>> neg >>speed
+ 2 over speed-d>> - >>speed-d
+ ]
+ when
+
+ out-of-bounds?
+ [ collide ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: hadron pos vel speed theta speed-d theta-d theta-dd myc ;
+
+: <hadron> ( -- hadron )
+ hadron construct-empty
+ 0 0 2array >>pos
+ 0 0 2array >>vel
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+ 0 0 0 1 <rgba> >>myc ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { hadron }
+
+ dim 2 / dup 2array >>pos
+ 2 pi * 1random >>theta
+ 0.5 3.5 2random >>speed
+
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ dup theta-dd>> abs 0.00001 < ]
+ [ -0.001 0.001 2random >>theta-dd ]
+ [ ]
+ while
+
+ 0 1 0 <rgb> >>myc
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { hadron }
+
+ { 1 0.11 } stroke
+ dup pos>> 1 v-y point
+
+ { 0 0.11 } stroke
+ dup pos>> 1 v+y point
+
+ dup vel>> move-by
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel
+
+ [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
+ [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
+ [ ] [ speed>> ] [ speed-d>> ] tri * >>speed
+
+ 1000 random 997 >
+ [
+ 1.0 >>speed-d
+ 0.00001 >>theta-dd
+
+ 100 random 70 >
+ [
+ dim 2 / dup 2array >>pos
+ dup collide
+ ]
+ when
+ ]
+ when
+
+ out-of-bounds?
+ [ collide ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: axion pos vel speed theta speed-d theta-d theta-dd ;
+
+: <axion> ( -- axion )
+ axion construct-empty
+ 0 0 2array >>pos
+ 0 0 2array >>vel
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { axion }
+
+ dim 2 / dup 2array >>pos
+ 2 pi * 1random >>theta
+ 1.0 6.0 2random >>speed
+
+ 0.998 1.000 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ dup theta-dd>> abs 0.00001 < ]
+ [ -0.001 0.001 2random >>theta-dd ]
+ [ ]
+ while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { axion }
+
+ { 0.06 0.59 } stroke
+ dup pos>> point
+
+ 1 4 [a,b]
+ [| dy |
+ 1 30 dy 6 * - 255.0 / 2array stroke
+ dup pos>> 0 dy neg 2array v+ point
+ ] with-locals
+ each
+
+ 1 4 [a,b]
+ [| dy |
+ 0 30 dy 6 * - 255.0 / 2array stroke
+ dup pos>> dy v+y point
+ ] with-locals
+ each
+
+ dup vel>> move-by
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel
+
+ [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
+ [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
+ [ ] [ speed>> ] [ speed-d>> ] tri * >>speed
+
+ [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
+
+ 1000 random 996 >
+ [
+ dup speed>> neg >>speed
+ dup speed-d>> neg 2 + >>speed-d
+
+ 100 random 30 >
+ [
+ dim 2 / dup 2array >>pos
+ collide
+ ]
+ [ drop ]
+ if
+ ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : draw ( -- )
+
+! boom>
+! [ particles> [ move ] each ]
+! when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-all ( -- )
+
+ 2 pi * 1random >collision-theta
+
+ particles> [ collide ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-one ( -- )
+
+ dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
+
+ hadrons> random collide
+ quarks> random collide
+ muons> random collide ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-pressed ( -- )
+ boom on
+ 1 background ! kludge
+ 11 [ drop collide-one ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key-released ( -- )
+ key " " =
+ [
+ boom on
+ 1 background
+ collide-all
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber ( -- )
+
+ 1000 1000 size*
+
+ [
+ 1 background
+ no-stroke
+
+ 1789 [ drop <muon> ] map >muons
+ 1300 [ drop <quark> ] map >quarks
+ 1000 [ drop <hadron> ] map >hadrons
+ 111 [ drop <axion> ] map >axions
+
+ muons> quarks> hadrons> axions> 3append append >particles
+
+ collide-one
+ ] setup
+
+ [
+ boom>
+ [ particles> [ move ] each ]
+ when
+ ] draw
+
+ [ mouse-pressed ] button-down
+ [ key-released ] key-up
+
+ ;
+
+: go ( -- ) [ bubble-chamber 500 sleep run ] with-ui ;
+
+MAIN: go
\ No newline at end of file
From 00d09d20e224bf2ec46dd4fc99bdfe906ff62b98 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 7 Apr 2008 12:07:44 +1200
Subject: [PATCH 209/288] Remove MATCH-VARS not used in pegs
---
extra/peg/peg.factor | 9 +--------
1 file changed, 1 insertion(+), 8 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 8d5d1c1560..3635abac84 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle
- vectors arrays combinators.lib math.parser match
+ vectors arrays combinators.lib math.parser
unicode.categories sequences.lib compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
IN: peg
@@ -265,8 +265,6 @@ SYMBOL: id
TUPLE: token-parser symbol ;
-MATCH-VARS: ?token ;
-
: parse-token ( input string -- result )
#! Parse the string, returning a parse result
dup >r ?head-slice [
@@ -388,9 +386,6 @@ M: optional-parser (compile) ( parser -- quot )
p1>> compiled-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ;
-MATCH-VARS: ?quot ;
-
-MATCH-VARS: ?parser ;
: check-semantic ( result quot -- result )
over [
@@ -421,8 +416,6 @@ M: ensure-not-parser (compile) ( parser -- quot )
TUPLE: action-parser p1 quot ;
-MATCH-VARS: ?action ;
-
: check-action ( result quot -- result )
over [
over ast>> swap call >>ast
From 5a493c03849063bf54b6bce0b95406ea338bbf40 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@freebsd.gateway.2wire.net>
Date: Sun, 6 Apr 2008 19:28:47 -0500
Subject: [PATCH 210/288] symlink gdb to a working binary on freebsd, remove
the special casing in code
---
extra/tools/disassembler/disassembler.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor
index 5b835cd52f..39ee85b07a 100755
--- a/extra/tools/disassembler/disassembler.factor
+++ b/extra/tools/disassembler/disassembler.factor
@@ -26,8 +26,7 @@ M: pair make-disassemble-cmd
M: method-spec make-disassemble-cmd
first2 method make-disassemble-cmd ;
-: gdb-binary ( -- string )
- os freebsd? "gdb66" "gdb" ? ;
+: gdb-binary ( -- string ) "gdb" ;
: run-gdb ( -- lines )
<process>
From a0939436272ac899f0d14f0939563a5cbfcf2d07 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 7 Apr 2008 12:50:07 +1200
Subject: [PATCH 211/288] Remove match from peg.parsers USING: list
---
extra/peg/parsers/parsers.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor
index 49035ea43c..3bbb61b846 100755
--- a/extra/peg/parsers/parsers.factor
+++ b/extra/peg/parsers/parsers.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays combinators.lib math.parser match
+ vectors arrays combinators.lib math.parser
unicode.categories sequences.deep peg peg.private
peg.search math.ranges words memoize ;
IN: peg.parsers
From 463a1991cae6c861e88ee54a3bb256f1b3ff5c44 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 7 Apr 2008 13:02:56 +1200
Subject: [PATCH 212/288] Fix peg help
---
extra/peg/parsers/parsers-docs.factor | 4 ++--
extra/peg/peg-docs.factor | 4 ++--
extra/peg/peg.factor | 2 +-
3 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor
index d49f1158dd..d71fdaea3b 100755
--- a/extra/peg/parsers/parsers-docs.factor
+++ b/extra/peg/parsers/parsers-docs.factor
@@ -173,7 +173,7 @@ HELP: range-pattern
"of characters separated with a dash (-) represents the "
"range of characters from the first to the second, inclusive."
{ $examples
- { $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
- { $example "USING: peg peg.parsers prettyprint ;" "\"0\" \"^0-9\" range-pattern parse ." "f" }
+ { $example "USING: peg peg.parsers prettyprint strings ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
+ { $example "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse ." "f" }
}
} ;
diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor
index 5f200be78e..10e05a2512 100644
--- a/extra/peg/peg-docs.factor
+++ b/extra/peg/peg-docs.factor
@@ -104,8 +104,8 @@ HELP: semantic
"Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
"the AST produced by 'p1' on the stack returns true." }
{ $examples
- { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" }
- { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" }
+ { $example "USING: kernel math peg prettyprint ;" "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse ." "f" }
+ { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast ." "67" }
} ;
HELP: ensure
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 3635abac84..ee9037ff25 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -241,7 +241,7 @@ GENERIC: (compile) ( parser -- quot )
: compiled-parse ( state word -- result )
swap [ execute ] with-packrat ; inline
-: parse ( state parser -- result )
+: parse ( input parser -- result )
dup word? [ compile ] unless compiled-parse ;
<PRIVATE
From a7a2fb4a005e1364fa21e9e6803fc5cffdd30800 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 6 Apr 2008 20:09:20 -0500
Subject: [PATCH 213/288] Fix multi-methods
---
extra/multi-methods/multi-methods.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index 5ea19bc957..115432b14d 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -70,6 +70,9 @@ PREDICATE: method-body < word
M: method-body stack-effect
"multi-method" word-prop method-generic stack-effect ;
+M: method-body crossref?
+ drop t ;
+
: method-word-name ( classes generic -- string )
[
word-name %
From f5d7f8b91727f774d2437454e63824984df35184 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 6 Apr 2008 20:09:31 -0500
Subject: [PATCH 214/288] Doc fix
---
core/io/files/files-docs.factor | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index 1dd96a13fc..e3f86c079d 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -7,14 +7,15 @@ ARTICLE: "file-streams" "Reading and writing files"
{ $subsection <file-reader> }
{ $subsection <file-writer> }
{ $subsection <file-appender> }
+"Reading and writing the entire contents of a file; this is only recommended for smaller files:"
+{ $subsection file-contents }
+{ $subsection set-file-contents }
+{ $subsection file-lines }
+{ $subsection set-file-lines }
"Utility combinators:"
{ $subsection with-file-reader }
{ $subsection with-file-writer }
-{ $subsection with-file-appender }
-{ $subsection set-file-contents }
-{ $subsection file-contents }
-{ $subsection set-file-lines }
-{ $subsection file-lines } ;
+{ $subsection with-file-appender } ;
ARTICLE: "pathnames" "Pathname manipulation"
"Pathname manipulation:"
From 719376e412804f1286482ff32cf3aaf1889f524d Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 7 Apr 2008 13:17:09 +1200
Subject: [PATCH 215/288] Remove w-c-u from ebnf transform
---
extra/peg/ebnf/ebnf.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index e5787e6cf8..56f88fc866 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -318,11 +318,11 @@ M: object build-locals ( code ast -- )
M: ebnf-action (transform) ( ast -- parser )
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
- string-lines [ parse-lines ] with-compilation-unit action ;
+ string-lines parse-lines action ;
M: ebnf-semantic (transform) ( ast -- parser )
[ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
- string-lines [ parse-lines ] with-compilation-unit semantic ;
+ string-lines parse-lines semantic ;
M: ebnf-var (transform) ( ast -- parser )
parser>> (transform) ;
From 8f7f1228d35a1131d18d7f437424a5739a42d187 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 6 Apr 2008 20:31:40 -0500
Subject: [PATCH 216/288] Add processing.gallery.trails
---
extra/processing/gallery/trails/trails.factor | 62 +++++++++++++++++++
1 file changed, 62 insertions(+)
create mode 100644 extra/processing/gallery/trails/trails.factor
diff --git a/extra/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor
new file mode 100644
index 0000000000..f0a8889fbf
--- /dev/null
+++ b/extra/processing/gallery/trails/trails.factor
@@ -0,0 +1,62 @@
+
+USING: kernel arrays sequences math qualified circular processing ui ;
+
+IN: processing.gallery.trails
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Example 33-15 from the Processing book
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+QUALIFIED: circular
+
+: push-circular ( seq elt -- seq ) over circular:push-circular ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: each-percent ( seq quot -- )
+ >r
+ dup length
+ dup [ / ] curry
+ [ 1+ ] swap compose
+ r> compose
+ 2each ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dot ( pos percent -- ) 1 swap - 25 * 5 max circle ;
+
+: step ( seq -- )
+
+ no-stroke
+ { 1 0.4 } fill
+
+ 0 background
+
+ mouse push-circular
+ [ dot ]
+ each-percent ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: go* ( -- )
+
+ 500 500 size*
+
+ [
+ 100 point-list
+ [ step ]
+ curry
+ draw
+ ] setup
+
+ run ;
+
+: go ( -- ) [ go* ] with-ui ;
+
+MAIN: go
\ No newline at end of file
From 73a914cab7e299705e2a74d946b2b91c9ded605f Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 6 Apr 2008 20:33:45 -0500
Subject: [PATCH 217/288] Move bubble-chamber to
processing.gallery.bubble-chamber
---
.../gallery}/bubble-chamber/bubble-chamber.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
rename extra/{ => processing/gallery}/bubble-chamber/bubble-chamber.factor (99%)
diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
similarity index 99%
rename from extra/bubble-chamber/bubble-chamber.factor
rename to extra/processing/gallery/bubble-chamber/bubble-chamber.factor
index ea8d309bdb..708e50fb12 100644
--- a/extra/bubble-chamber/bubble-chamber.factor
+++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
@@ -472,6 +472,6 @@ METHOD: move { axion }
;
-: go ( -- ) [ bubble-chamber 500 sleep run ] with-ui ;
+: go ( -- ) [ bubble-chamber run ] with-ui ;
MAIN: go
\ No newline at end of file
From 6c74f33edb3bed776bcb332bf7f16bb17cc220be Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 6 Apr 2008 20:34:53 -0500
Subject: [PATCH 218/288] bubble-chamber: Fix IN:
---
extra/processing/gallery/bubble-chamber/bubble-chamber.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
index 708e50fb12..c6e000e74f 100644
--- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
+++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
@@ -21,7 +21,7 @@ USING: kernel namespaces sequences combinators arrays threads
processing.gadget
processing.color ;
-IN: bubble-chamber
+IN: processing.gallery.bubble-chamber
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From ddb1749c57743c25d7667c9484fa854ee98abf50 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 6 Apr 2008 21:07:21 -0500
Subject: [PATCH 219/288] ERROR: should be inside the IN:
---
extra/opengl/gl/extensions/extensions.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor
index b8ac396c2f..20929fb410 100644
--- a/extra/opengl/gl/extensions/extensions.factor
+++ b/extra/opengl/gl/extensions/extensions.factor
@@ -1,6 +1,7 @@
USING: alien alien.syntax combinators kernel parser sequences
system words namespaces hashtables init math arrays assocs
continuations ;
+IN: opengl.gl.extensions
ERROR: unknown-gl-platform ;
<< {
@@ -9,7 +10,6 @@ ERROR: unknown-gl-platform ;
{ [ os unix? ] [ "opengl.gl.unix" ] }
{ [ t ] [ unknown-gl-platform ] }
} cond use+ >>
-IN: opengl.gl.extensions
SYMBOL: +gl-function-number-counter+
SYMBOL: +gl-function-pointers+
From a641c6d332e36910239a6a269e299a231f422d18 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 7 Apr 2008 14:39:18 +1200
Subject: [PATCH 220/288] Add \r to ebnf escape rules
---
extra/peg/ebnf/ebnf.factor | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 56f88fc866..8bf0475da5 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -361,7 +361,11 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
[ compiled-parse ] curry [ with-scope ] curry ;
: replace-escapes ( string -- string )
- "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ;
+ [
+ "\\t" token [ drop "\t" ] action ,
+ "\\n" token [ drop "\n" ] action ,
+ "\\r" token [ drop "\r" ] action ,
+ ] choice* replace ;
: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing
From 1518d631150a969041095d71cc8381bff6157b47 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 6 Apr 2008 22:04:31 -0500
Subject: [PATCH 221/288] Fix Windows launcher resource leak
---
extra/io/windows/nt/launcher/launcher-tests.factor | 13 ++++++++++++-
extra/io/windows/nt/launcher/launcher.factor | 2 +-
2 files changed, 13 insertions(+), 2 deletions(-)
diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor
index fac6471b8c..8b13b9b3b9 100755
--- a/extra/io/windows/nt/launcher/launcher-tests.factor
+++ b/extra/io/windows/nt/launcher/launcher-tests.factor
@@ -1,7 +1,7 @@
IN: io.windows.launcher.nt.tests
USING: io.launcher tools.test calendar accessors
namespaces kernel system arrays io io.files io.encodings.ascii
-sequences parser assocs hashtables ;
+sequences parser assocs hashtables math ;
[ ] [
<process>
@@ -129,3 +129,14 @@ sequences parser assocs hashtables ;
"HOME" swap at "XXX" =
] unit-test
+
+2 [
+ [ ] [
+ <process>
+ "cmd.exe /c dir" >>command
+ "dir.txt" temp-file >>stdout
+ try-process
+ ] unit-test
+
+ [ ] [ "dir.txt" temp-file delete-file ] unit-test
+] times
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index a01ba4698e..97de248d24 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -39,7 +39,7 @@ IN: io.windows.nt.launcher
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
- CreateFile dup invalid-handle? dup close-later ;
+ CreateFile dup invalid-handle? dup close-always ;
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
From 225a0fb781f281c2c581bacac5c4989fc2ba7d7d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 6 Apr 2008 23:31:53 -0500
Subject: [PATCH 222/288] Fix Windows crash with set-os-envs
---
core/bootstrap/primitives.factor | 1 +
core/inference/known-words/known-words.factor | 2 +
core/kernel/kernel-tests.factor | 9 +
vm/errors.c | 6 +
vm/errors.h | 2 +
vm/errors.s | 687 ++++++++
vm/os-windows.c | 2 +-
vm/primitives.c | 1 +
vm/run.s | 1511 +++++++++++++++++
9 files changed, 2220 insertions(+), 1 deletion(-)
create mode 100644 vm/errors.s
create mode 100644 vm/run.s
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 5836b4d3c5..233de6f4ee 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -737,6 +737,7 @@ define-builtin
{ "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" }
+ { "unimplemented" "kernel.private" }
}
dup length [ >r first2 r> make-primitive ] 2each
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 99737e0ac5..8f505c21a1 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -594,3 +594,5 @@ set-primitive-effect
\ dll-valid? { object } { object } <effect> set-primitive-effect
\ modify-code-heap { array object } { } <effect> set-primitive-effect
+
+\ unimplemented { } { } <effect> set-primitive-effect
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 3c40984d7a..4b129ad59d 100755
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -108,3 +108,12 @@ IN: kernel.tests
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] must-fail
+
+! Discovered on Windows
+: total-failure-1 "" [ ] map unimplemented ;
+
+[ total-failure-1 ] must-fail
+
+: total-failure-2 [ ] (call) unimplemented ;
+
+[ total-failure-2 ] must-fail
diff --git a/vm/errors.c b/vm/errors.c
index 27158cbf44..6d99d34766 100755
--- a/vm/errors.c
+++ b/vm/errors.c
@@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
}
+
+/* For testing purposes */
+DEFINE_PRIMITIVE(unimplemented)
+{
+ not_implemented_error();
+}
diff --git a/vm/errors.h b/vm/errors.h
index 747a3415ba..227fed9228 100755
--- a/vm/errors.h
+++ b/vm/errors.h
@@ -55,3 +55,5 @@ void *signal_callstack_top;
void memory_signal_handler_impl(void);
void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);
+
+DECLARE_PRIMITIVE(unimplemented);
diff --git a/vm/errors.s b/vm/errors.s
new file mode 100644
index 0000000000..d6b3bdb6e5
--- /dev/null
+++ b/vm/errors.s
@@ -0,0 +1,687 @@
+ .file "errors.c"
+ .section .rdata,"dr"
+LC0:
+ .ascii "fatal_error: %s %lx\12\0"
+ .text
+.globl _fatal_error
+ .def _fatal_error; .scl 2; .type 32; .endef
+_fatal_error:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ call ___getreent
+ movl %eax, %edx
+ movl 12(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl $LC0, 4(%esp)
+ movl 12(%edx), %eax
+ movl %eax, (%esp)
+ call _fprintf
+ movl $1, (%esp)
+ call _exit
+ .section .rdata,"dr"
+ .align 4
+LC1:
+ .ascii "You have triggered a bug in Factor. Please report.\12\0"
+LC2:
+ .ascii "critical_error: %s %lx\12\0"
+ .text
+.globl _critical_error
+ .def _critical_error; .scl 2; .type 32; .endef
+_critical_error:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ call ___getreent
+ movl $LC1, 4(%esp)
+ movl 12(%eax), %eax
+ movl %eax, (%esp)
+ call _fprintf
+ call ___getreent
+ movl %eax, %edx
+ movl 12(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl $LC2, 4(%esp)
+ movl 12(%edx), %eax
+ movl %eax, (%esp)
+ call _fprintf
+ call _factorbug
+ leave
+ ret
+ .section .rdata,"dr"
+LC3:
+ .ascii "early_error: \0"
+LC4:
+ .ascii "\12\0"
+ .text
+.globl _throw_error
+ .def _throw_error; .scl 2; .type 32; .endef
+_throw_error:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ cmpl $7, _userenv+20
+ je L4
+ movb $0, _gc_off
+ movl _gc_locals_region, %eax
+ movl (%eax), %eax
+ subl $4, %eax
+ movl %eax, _gc_locals
+ movl _extra_roots_region, %eax
+ movl (%eax), %eax
+ subl $4, %eax
+ movl %eax, _extra_roots
+ call _fix_stacks
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _dpush
+ cmpl $0, 12(%ebp)
+ je L5
+ movl _stack_chain, %eax
+ movl 4(%eax), %eax
+ movl %eax, 4(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, (%esp)
+ call _fix_callstack_top
+ movl %eax, 12(%ebp)
+ jmp L6
+L5:
+ movl _stack_chain, %eax
+ movl (%eax), %eax
+ movl %eax, 12(%ebp)
+L6:
+ movl 12(%ebp), %edx
+ movl _userenv+20, %eax
+ call _throw_impl
+ jmp L3
+L4:
+ call ___getreent
+ movl $LC1, 4(%esp)
+ movl 12(%eax), %eax
+ movl %eax, (%esp)
+ call _fprintf
+ call ___getreent
+ movl $LC3, 4(%esp)
+ movl 12(%eax), %eax
+ movl %eax, (%esp)
+ call _fprintf
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _print_obj
+ call ___getreent
+ movl $LC4, 4(%esp)
+ movl 12(%eax), %eax
+ movl %eax, (%esp)
+ call _fprintf
+ call _factorbug
+L3:
+ leave
+ ret
+ .def _dpush; .scl 3; .type 32; .endef
+_dpush:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ addl $4, %esi
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ leave
+ ret
+ .def _put; .scl 3; .type 32; .endef
+_put:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %edx
+ movl 12(%ebp), %eax
+ movl %eax, (%edx)
+ popl %ebp
+ ret
+.globl _general_error
+ .def _general_error; .scl 2; .type 32; .endef
+_general_error:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _tag_fixnum
+ movl %eax, %edx
+ movl 16(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl %edx, 4(%esp)
+ movl _userenv+24, %eax
+ movl %eax, (%esp)
+ call _allot_array_4
+ movl %eax, %edx
+ movl 20(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %edx, (%esp)
+ call _throw_error
+ leave
+ ret
+ .def _tag_fixnum; .scl 3; .type 32; .endef
+_tag_fixnum:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ sall $3, %eax
+ andl $-8, %eax
+ popl %ebp
+ ret
+.globl _type_error
+ .def _type_error; .scl 2; .type 32; .endef
+_type_error:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _tag_fixnum
+ movl %eax, %edx
+ movl $0, 12(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl %edx, 4(%esp)
+ movl $3, (%esp)
+ call _general_error
+ leave
+ ret
+.globl _not_implemented_error
+ .def _not_implemented_error; .scl 2; .type 32; .endef
+_not_implemented_error:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl $0, 12(%esp)
+ movl $7, 8(%esp)
+ movl $7, 4(%esp)
+ movl $2, (%esp)
+ call _general_error
+ leave
+ ret
+.globl _in_page
+ .def _in_page; .scl 2; .type 32; .endef
+_in_page:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _getpagesize
+ movl %eax, -4(%ebp)
+ movl 16(%ebp), %edx
+ leal 12(%ebp), %eax
+ addl %edx, (%eax)
+ movl 20(%ebp), %eax
+ movl %eax, %edx
+ imull -4(%ebp), %edx
+ leal 12(%ebp), %eax
+ addl %edx, (%eax)
+ movb $0, -5(%ebp)
+ movl 8(%ebp), %eax
+ cmpl 12(%ebp), %eax
+ jb L15
+ movl -4(%ebp), %eax
+ addl 12(%ebp), %eax
+ cmpl 8(%ebp), %eax
+ jb L15
+ movb $1, -5(%ebp)
+L15:
+ movzbl -5(%ebp), %eax
+ leave
+ ret
+ .section .rdata,"dr"
+ .align 4
+LC5:
+ .ascii "allot_object() missed GC check\0"
+LC6:
+ .ascii "gc locals underflow\0"
+LC7:
+ .ascii "gc locals overflow\0"
+LC8:
+ .ascii "extra roots underflow\0"
+LC9:
+ .ascii "extra roots overflow\0"
+ .text
+.globl _memory_protection_error
+ .def _memory_protection_error; .scl 2; .type 32; .endef
+_memory_protection_error:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl $-1, 12(%esp)
+ movl $0, 8(%esp)
+ movl _stack_chain, %eax
+ movl 24(%eax), %eax
+ movl (%eax), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _in_page
+ testb %al, %al
+ je L17
+ movl 12(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl $7, 8(%esp)
+ movl $7, 4(%esp)
+ movl $11, (%esp)
+ call _general_error
+ jmp L16
+L17:
+ movl $0, 12(%esp)
+ movl _ds_size, %eax
+ movl %eax, 8(%esp)
+ movl _stack_chain, %eax
+ movl 24(%eax), %eax
+ movl (%eax), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _in_page
+ testb %al, %al
+ je L19
+ movl 12(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl $7, 8(%esp)
+ movl $7, 4(%esp)
+ movl $12, (%esp)
+ call _general_error
+ jmp L16
+L19:
+ movl $-1, 12(%esp)
+ movl $0, 8(%esp)
+ movl _stack_chain, %eax
+ movl 28(%eax), %eax
+ movl (%eax), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _in_page
+ testb %al, %al
+ je L21
+ movl 12(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl $7, 8(%esp)
+ movl $7, 4(%esp)
+ movl $13, (%esp)
+ call _general_error
+ jmp L16
+L21:
+ movl $0, 12(%esp)
+ movl _rs_size, %eax
+ movl %eax, 8(%esp)
+ movl _stack_chain, %eax
+ movl 28(%eax), %eax
+ movl (%eax), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _in_page
+ testb %al, %al
+ je L23
+ movl 12(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl $7, 8(%esp)
+ movl $7, 4(%esp)
+ movl $14, (%esp)
+ call _general_error
+ jmp L16
+L23:
+ movl $0, 12(%esp)
+ movl $0, 8(%esp)
+ movl _nursery, %eax
+ movl 12(%eax), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _in_page
+ testb %al, %al
+ je L25
+ movl $0, 4(%esp)
+ movl $LC5, (%esp)
+ call _critical_error
+ jmp L16
+L25:
+ movl $-1, 12(%esp)
+ movl $0, 8(%esp)
+ movl _gc_locals_region, %eax
+ movl (%eax), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _in_page
+ testb %al, %al
+ je L27
+ movl $0, 4(%esp)
+ movl $LC6, (%esp)
+ call _critical_error
+ jmp L16
+L27:
+ movl $0, 12(%esp)
+ movl $0, 8(%esp)
+ movl _gc_locals_region, %eax
+ movl 8(%eax), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _in_page
+ testb %al, %al
+ je L29
+ movl $0, 4(%esp)
+ movl $LC7, (%esp)
+ call _critical_error
+ jmp L16
+L29:
+ movl $-1, 12(%esp)
+ movl $0, 8(%esp)
+ movl _extra_roots_region, %eax
+ movl (%eax), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _in_page
+ testb %al, %al
+ je L31
+ movl $0, 4(%esp)
+ movl $LC8, (%esp)
+ call _critical_error
+ jmp L16
+L31:
+ movl $0, 12(%esp)
+ movl $0, 8(%esp)
+ movl _extra_roots_region, %eax
+ movl 8(%eax), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _in_page
+ testb %al, %al
+ je L33
+ movl $0, 4(%esp)
+ movl $LC9, (%esp)
+ call _critical_error
+ jmp L16
+L33:
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _allot_cell
+ movl %eax, %edx
+ movl 12(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl $7, 8(%esp)
+ movl %edx, 4(%esp)
+ movl $15, (%esp)
+ call _general_error
+L16:
+ leave
+ ret
+ .def _allot_cell; .scl 3; .type 32; .endef
+_allot_cell:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ cmpl $268435455, 8(%ebp)
+ jbe L36
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _cell_to_bignum
+ movl %eax, (%esp)
+ call _tag_bignum
+ movl %eax, -4(%ebp)
+ jmp L35
+L36:
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _tag_fixnum
+ movl %eax, -4(%ebp)
+L35:
+ movl -4(%ebp), %eax
+ leave
+ ret
+ .def _tag_bignum; .scl 3; .type 32; .endef
+_tag_bignum:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ andl $-8, %eax
+ orl $1, %eax
+ popl %ebp
+ ret
+.globl _signal_error
+ .def _signal_error; .scl 2; .type 32; .endef
+_signal_error:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _tag_fixnum
+ movl %eax, %edx
+ movl 12(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl $7, 8(%esp)
+ movl %edx, 4(%esp)
+ movl $5, (%esp)
+ call _general_error
+ leave
+ ret
+.globl _divide_by_zero_error
+ .def _divide_by_zero_error; .scl 2; .type 32; .endef
+_divide_by_zero_error:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movl %eax, 12(%esp)
+ movl $7, 8(%esp)
+ movl $7, 4(%esp)
+ movl $4, (%esp)
+ call _general_error
+ leave
+ ret
+.globl _memory_signal_handler_impl
+ .def _memory_signal_handler_impl; .scl 2; .type 32; .endef
+_memory_signal_handler_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl _signal_callstack_top, %eax
+ movl %eax, 4(%esp)
+ movl _signal_fault_addr, %eax
+ movl %eax, (%esp)
+ call _memory_protection_error
+ leave
+ ret
+.globl _divide_by_zero_signal_handler_impl
+ .def _divide_by_zero_signal_handler_impl; .scl 2; .type 32; .endef
+_divide_by_zero_signal_handler_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl _signal_callstack_top, %eax
+ movl %eax, (%esp)
+ call _divide_by_zero_error
+ leave
+ ret
+.globl _misc_signal_handler_impl
+ .def _misc_signal_handler_impl; .scl 2; .type 32; .endef
+_misc_signal_handler_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl _signal_callstack_top, %eax
+ movl %eax, 4(%esp)
+ movl _signal_number, %eax
+ movl %eax, (%esp)
+ call _signal_error
+ leave
+ ret
+.globl _primitive_throw
+ .def _primitive_throw; .scl 2; .type 32; .endef
+_primitive_throw:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_throw_impl
+ leave
+ ret
+ .def _primitive_throw_impl; .scl 3; .type 32; .endef
+_primitive_throw_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpop
+ call _dpop
+ movl %eax, %ecx
+ movl _stack_chain, %eax
+ movl (%eax), %edx
+ movl %ecx, %eax
+ call _throw_impl
+ leave
+ ret
+ .def _dpop; .scl 3; .type 32; .endef
+_dpop:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %esi, (%esp)
+ call _get
+ movl %eax, -4(%ebp)
+ subl $4, %esi
+ movl -4(%ebp), %eax
+ leave
+ ret
+ .def _get; .scl 3; .type 32; .endef
+_get:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ movl (%eax), %eax
+ popl %ebp
+ ret
+.globl _primitive_call_clear
+ .def _primitive_call_clear; .scl 2; .type 32; .endef
+_primitive_call_clear:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_call_clear_impl
+ leave
+ ret
+ .def _primitive_call_clear_impl; .scl 3; .type 32; .endef
+_primitive_call_clear_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpop
+ movl _stack_chain, %edx
+ movl 4(%edx), %edx
+ call _throw_impl
+ leave
+ ret
+.globl _primitive_unimplemented2
+ .def _primitive_unimplemented2; .scl 2; .type 32; .endef
+_primitive_unimplemented2:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ call _not_implemented_error
+ leave
+ ret
+.globl _primitive_unimplemented
+ .def _primitive_unimplemented; .scl 2; .type 32; .endef
+_primitive_unimplemented:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_unimplemented_impl
+ leave
+ ret
+ .def _primitive_unimplemented_impl; .scl 3; .type 32; .endef
+_primitive_unimplemented_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _not_implemented_error
+ leave
+ ret
+ .comm _console_open, 16 # 1
+ .comm _userenv, 256 # 256
+ .comm _T, 16 # 4
+ .comm _stack_chain, 16 # 4
+ .comm _ds_size, 16 # 4
+ .comm _rs_size, 16 # 4
+ .comm _stage2, 16 # 1
+ .comm _profiling_p, 16 # 1
+ .comm _signal_number, 16 # 4
+ .comm _signal_fault_addr, 16 # 4
+ .comm _signal_callstack_top, 16 # 4
+ .comm _secure_gc, 16 # 1
+ .comm _data_heap, 16 # 4
+ .comm _cards_offset, 16 # 4
+ .comm _newspace, 16 # 4
+ .comm _nursery, 16 # 4
+ .comm _gc_time, 16 # 8
+ .comm _nursery_collections, 16 # 4
+ .comm _aging_collections, 16 # 4
+ .comm _cards_scanned, 16 # 4
+ .comm _performing_gc, 16 # 1
+ .comm _collecting_gen, 16 # 4
+ .comm _collecting_aging_again, 16 # 1
+ .comm _last_code_heap_scan, 16 # 4
+ .comm _growing_data_heap, 16 # 1
+ .comm _old_data_heap, 16 # 4
+ .comm _gc_jmp, 208 # 208
+ .comm _heap_scan_ptr, 16 # 4
+ .comm _gc_off, 16 # 1
+ .comm _gc_locals_region, 16 # 4
+ .comm _gc_locals, 16 # 4
+ .comm _extra_roots_region, 16 # 4
+ .comm _extra_roots, 16 # 4
+ .comm _bignum_zero, 16 # 4
+ .comm _bignum_pos_one, 16 # 4
+ .comm _bignum_neg_one, 16 # 4
+ .comm _code_heap, 16 # 8
+ .comm _data_relocation_base, 16 # 4
+ .comm _code_relocation_base, 16 # 4
+ .comm _posix_argc, 16 # 4
+ .comm _posix_argv, 16 # 4
+ .def _save_callstack_top; .scl 3; .type 32; .endef
+ .def _getpagesize; .scl 3; .type 32; .endef
+ .def _allot_array_4; .scl 3; .type 32; .endef
+ .def _print_obj; .scl 3; .type 32; .endef
+ .def _throw_impl; .scl 3; .type 32; .endef
+ .def _fix_callstack_top; .scl 3; .type 32; .endef
+ .def _fix_stacks; .scl 3; .type 32; .endef
+ .def _factorbug; .scl 3; .type 32; .endef
+ .def _exit; .scl 3; .type 32; .endef
+ .def ___getreent; .scl 3; .type 32; .endef
+ .def _fprintf; .scl 3; .type 32; .endef
+ .def _critical_error; .scl 3; .type 32; .endef
+ .def _type_error; .scl 3; .type 32; .endef
+ .section .drectve
+
+ .ascii " -export:nursery,data"
+ .ascii " -export:cards_offset,data"
+ .ascii " -export:stack_chain,data"
+ .ascii " -export:userenv,data"
diff --git a/vm/os-windows.c b/vm/os-windows.c
index 1be41f8b57..664df9e774 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.c
@@ -215,7 +215,7 @@ void sleep_millis(DWORD msec)
Sleep(msec);
}
-DECLARE_PRIMITIVE(set_os_envs)
+DEFINE_PRIMITIVE(set_os_envs)
{
not_implemented_error();
}
diff --git a/vm/primitives.c b/vm/primitives.c
index 038a7d84a5..533fcebc9a 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -187,4 +187,5 @@ void *primitives[] = {
primitive_resize_bit_array,
primitive_resize_float_array,
primitive_dll_validp,
+ primitive_unimplemented,
};
diff --git a/vm/run.s b/vm/run.s
new file mode 100644
index 0000000000..78b2adac84
--- /dev/null
+++ b/vm/run.s
@@ -0,0 +1,1511 @@
+ .file "run.c"
+ .text
+.globl _reset_datastack
+ .def _reset_datastack; .scl 2; .type 32; .endef
+_reset_datastack:
+ pushl %ebp
+ movl %esp, %ebp
+ movl _stack_chain, %eax
+ movl 24(%eax), %eax
+ movl (%eax), %esi
+ subl $4, %esi
+ popl %ebp
+ ret
+.globl _reset_retainstack
+ .def _reset_retainstack; .scl 2; .type 32; .endef
+_reset_retainstack:
+ pushl %ebp
+ movl %esp, %ebp
+ movl _stack_chain, %eax
+ movl 28(%eax), %eax
+ movl (%eax), %edi
+ subl $4, %edi
+ popl %ebp
+ ret
+.globl _fix_stacks
+ .def _fix_stacks; .scl 2; .type 32; .endef
+_fix_stacks:
+ pushl %ebp
+ movl %esp, %ebp
+ leal 4(%esi), %eax
+ movl _stack_chain, %edx
+ movl 24(%edx), %edx
+ cmpl (%edx), %eax
+ jb L5
+ leal 256(%esi), %eax
+ movl _stack_chain, %edx
+ movl 24(%edx), %edx
+ cmpl 8(%edx), %eax
+ jae L5
+ jmp L4
+L5:
+ call _reset_datastack
+L4:
+ leal 4(%edi), %eax
+ movl _stack_chain, %edx
+ movl 28(%edx), %edx
+ cmpl (%edx), %eax
+ jb L7
+ leal 256(%edi), %eax
+ movl _stack_chain, %edx
+ movl 28(%edx), %edx
+ cmpl 8(%edx), %eax
+ jae L7
+ jmp L3
+L7:
+ call _reset_retainstack
+L3:
+ popl %ebp
+ ret
+.globl _save_stacks
+ .def _save_stacks; .scl 2; .type 32; .endef
+_save_stacks:
+ pushl %ebp
+ movl %esp, %ebp
+ cmpl $0, _stack_chain
+ je L8
+ movl _stack_chain, %eax
+ movl %esi, 8(%eax)
+ movl _stack_chain, %eax
+ movl %edi, 12(%eax)
+L8:
+ popl %ebp
+ ret
+.globl _nest_stacks
+ .def _nest_stacks; .scl 2; .type 32; .endef
+_nest_stacks:
+ pushl %ebp
+ movl %esp, %ebp
+ pushl %ebx
+ subl $20, %esp
+ movl $44, (%esp)
+ call _safe_malloc
+ movl %eax, -8(%ebp)
+ movl -8(%ebp), %eax
+ movl $-1, 4(%eax)
+ movl -8(%ebp), %eax
+ movl $-1, (%eax)
+ movl -8(%ebp), %eax
+ movl %esi, 16(%eax)
+ movl -8(%ebp), %eax
+ movl %edi, 20(%eax)
+ movl -8(%ebp), %edx
+ movl _userenv+8, %eax
+ movl %eax, 36(%edx)
+ movl -8(%ebp), %edx
+ movl _userenv+4, %eax
+ movl %eax, 32(%edx)
+ movl -8(%ebp), %ebx
+ movl _ds_size, %eax
+ movl %eax, (%esp)
+ call _alloc_segment
+ movl %eax, 24(%ebx)
+ movl -8(%ebp), %ebx
+ movl _rs_size, %eax
+ movl %eax, (%esp)
+ call _alloc_segment
+ movl %eax, 28(%ebx)
+ movl -8(%ebp), %edx
+ movl _stack_chain, %eax
+ movl %eax, 40(%edx)
+ movl -8(%ebp), %eax
+ movl %eax, _stack_chain
+ call _reset_datastack
+ call _reset_retainstack
+ addl $20, %esp
+ popl %ebx
+ popl %ebp
+ ret
+.globl _unnest_stacks
+ .def _unnest_stacks; .scl 2; .type 32; .endef
+_unnest_stacks:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl _stack_chain, %eax
+ movl 24(%eax), %eax
+ movl %eax, (%esp)
+ call _dealloc_segment
+ movl _stack_chain, %eax
+ movl 28(%eax), %eax
+ movl %eax, (%esp)
+ call _dealloc_segment
+ movl _stack_chain, %eax
+ movl 16(%eax), %esi
+ movl _stack_chain, %eax
+ movl 20(%eax), %edi
+ movl _stack_chain, %eax
+ movl 36(%eax), %eax
+ movl %eax, _userenv+8
+ movl _stack_chain, %eax
+ movl 32(%eax), %eax
+ movl %eax, _userenv+4
+ movl _stack_chain, %eax
+ movl %eax, -4(%ebp)
+ movl -4(%ebp), %eax
+ movl 40(%eax), %eax
+ movl %eax, _stack_chain
+ movl -4(%ebp), %eax
+ movl %eax, (%esp)
+ call _free
+ leave
+ ret
+.globl _init_stacks
+ .def _init_stacks; .scl 2; .type 32; .endef
+_init_stacks:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ movl %eax, _ds_size
+ movl 12(%ebp), %eax
+ movl %eax, _rs_size
+ movl $0, _stack_chain
+ popl %ebp
+ ret
+.globl _primitive_drop
+ .def _primitive_drop; .scl 2; .type 32; .endef
+_primitive_drop:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_drop_impl
+ leave
+ ret
+ .def _primitive_drop_impl; .scl 3; .type 32; .endef
+_primitive_drop_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpop
+ leave
+ ret
+ .def _dpop; .scl 3; .type 32; .endef
+_dpop:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %esi, (%esp)
+ call _get
+ movl %eax, -4(%ebp)
+ subl $4, %esi
+ movl -4(%ebp), %eax
+ leave
+ ret
+ .def _get; .scl 3; .type 32; .endef
+_get:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ movl (%eax), %eax
+ popl %ebp
+ ret
+.globl _primitive_2drop
+ .def _primitive_2drop; .scl 2; .type 32; .endef
+_primitive_2drop:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_2drop_impl
+ leave
+ ret
+ .def _primitive_2drop_impl; .scl 3; .type 32; .endef
+_primitive_2drop_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esi
+ popl %ebp
+ ret
+.globl _primitive_3drop
+ .def _primitive_3drop; .scl 2; .type 32; .endef
+_primitive_3drop:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_3drop_impl
+ leave
+ ret
+ .def _primitive_3drop_impl; .scl 3; .type 32; .endef
+_primitive_3drop_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $12, %esi
+ popl %ebp
+ ret
+.globl _primitive_dup
+ .def _primitive_dup; .scl 2; .type 32; .endef
+_primitive_dup:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_dup_impl
+ leave
+ ret
+ .def _primitive_dup_impl; .scl 3; .type 32; .endef
+_primitive_dup_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpeek
+ movl %eax, (%esp)
+ call _dpush
+ leave
+ ret
+ .def _dpush; .scl 3; .type 32; .endef
+_dpush:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ addl $4, %esi
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ leave
+ ret
+ .def _put; .scl 3; .type 32; .endef
+_put:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %edx
+ movl 12(%ebp), %eax
+ movl %eax, (%edx)
+ popl %ebp
+ ret
+ .def _dpeek; .scl 3; .type 32; .endef
+_dpeek:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $4, %esp
+ movl %esi, (%esp)
+ call _get
+ leave
+ ret
+.globl _primitive_2dup
+ .def _primitive_2dup; .scl 2; .type 32; .endef
+_primitive_2dup:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_2dup_impl
+ leave
+ ret
+ .def _primitive_2dup_impl; .scl 3; .type 32; .endef
+_primitive_2dup_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $16, %esp
+ call _dpeek
+ movl %eax, -4(%ebp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -8(%ebp)
+ addl $8, %esi
+ movl -8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ movl -4(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ leave
+ ret
+.globl _primitive_3dup
+ .def _primitive_3dup; .scl 2; .type 32; .endef
+_primitive_3dup:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_3dup_impl
+ leave
+ ret
+ .def _primitive_3dup_impl; .scl 3; .type 32; .endef
+_primitive_3dup_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $20, %esp
+ call _dpeek
+ movl %eax, -4(%ebp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -8(%ebp)
+ leal -8(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -12(%ebp)
+ addl $12, %esi
+ movl -4(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ movl -8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ movl -12(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -8(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ leave
+ ret
+.globl _primitive_rot
+ .def _primitive_rot; .scl 2; .type 32; .endef
+_primitive_rot:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_rot_impl
+ leave
+ ret
+ .def _primitive_rot_impl; .scl 3; .type 32; .endef
+_primitive_rot_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $20, %esp
+ call _dpeek
+ movl %eax, -4(%ebp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -8(%ebp)
+ leal -8(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -12(%ebp)
+ movl -12(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ movl -4(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ movl -8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -8(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ leave
+ ret
+.globl _primitive__rot
+ .def _primitive__rot; .scl 2; .type 32; .endef
+_primitive__rot:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive__rot_impl
+ leave
+ ret
+ .def _primitive__rot_impl; .scl 3; .type 32; .endef
+_primitive__rot_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $20, %esp
+ call _dpeek
+ movl %eax, -4(%ebp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -8(%ebp)
+ leal -8(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -12(%ebp)
+ movl -8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ movl -12(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ movl -4(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -8(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ leave
+ ret
+.globl _primitive_dupd
+ .def _primitive_dupd; .scl 2; .type 32; .endef
+_primitive_dupd:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_dupd_impl
+ leave
+ ret
+ .def _primitive_dupd_impl; .scl 3; .type 32; .endef
+_primitive_dupd_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ call _dpeek
+ movl %eax, -4(%ebp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -8(%ebp)
+ movl -8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ movl -8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ movl -4(%ebp), %eax
+ movl %eax, (%esp)
+ call _dpush
+ leave
+ ret
+.globl _primitive_swapd
+ .def _primitive_swapd; .scl 2; .type 32; .endef
+_primitive_swapd:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_swapd_impl
+ leave
+ ret
+ .def _primitive_swapd_impl; .scl 3; .type 32; .endef
+_primitive_swapd_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $16, %esp
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -4(%ebp)
+ leal -8(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -8(%ebp)
+ movl -8(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ movl -4(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -8(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ leave
+ ret
+.globl _primitive_nip
+ .def _primitive_nip; .scl 2; .type 32; .endef
+_primitive_nip:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_nip_impl
+ leave
+ ret
+ .def _primitive_nip_impl; .scl 3; .type 32; .endef
+_primitive_nip_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpop
+ movl %eax, -4(%ebp)
+ movl -4(%ebp), %eax
+ movl %eax, (%esp)
+ call _drepl
+ leave
+ ret
+ .def _drepl; .scl 3; .type 32; .endef
+_drepl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ leave
+ ret
+.globl _primitive_2nip
+ .def _primitive_2nip; .scl 2; .type 32; .endef
+_primitive_2nip:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_2nip_impl
+ leave
+ ret
+ .def _primitive_2nip_impl; .scl 3; .type 32; .endef
+_primitive_2nip_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpeek
+ movl %eax, -4(%ebp)
+ subl $8, %esi
+ movl -4(%ebp), %eax
+ movl %eax, (%esp)
+ call _drepl
+ leave
+ ret
+.globl _primitive_tuck
+ .def _primitive_tuck; .scl 2; .type 32; .endef
+_primitive_tuck:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_tuck_impl
+ leave
+ ret
+ .def _primitive_tuck_impl; .scl 3; .type 32; .endef
+_primitive_tuck_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ call _dpeek
+ movl %eax, -4(%ebp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -8(%ebp)
+ movl -8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ movl -4(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ movl -4(%ebp), %eax
+ movl %eax, (%esp)
+ call _dpush
+ leave
+ ret
+.globl _primitive_over
+ .def _primitive_over; .scl 2; .type 32; .endef
+_primitive_over:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_over_impl
+ leave
+ ret
+ .def _primitive_over_impl; .scl 3; .type 32; .endef
+_primitive_over_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, (%esp)
+ call _dpush
+ leave
+ ret
+.globl _primitive_pick
+ .def _primitive_pick; .scl 2; .type 32; .endef
+_primitive_pick:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_pick_impl
+ leave
+ ret
+ .def _primitive_pick_impl; .scl 3; .type 32; .endef
+_primitive_pick_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ leal -8(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, (%esp)
+ call _dpush
+ leave
+ ret
+.globl _primitive_swap
+ .def _primitive_swap; .scl 2; .type 32; .endef
+_primitive_swap:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_swap_impl
+ leave
+ ret
+ .def _primitive_swap_impl; .scl 3; .type 32; .endef
+_primitive_swap_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $16, %esp
+ call _dpeek
+ movl %eax, -4(%ebp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, -8(%ebp)
+ movl -8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %esi, (%esp)
+ call _put
+ movl -4(%ebp), %eax
+ movl %eax, 4(%esp)
+ leal -4(%esi), %eax
+ movl %eax, (%esp)
+ call _put
+ leave
+ ret
+.globl _primitive_to_r
+ .def _primitive_to_r; .scl 2; .type 32; .endef
+_primitive_to_r:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_to_r_impl
+ leave
+ ret
+ .def _primitive_to_r_impl; .scl 3; .type 32; .endef
+_primitive_to_r_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpop
+ movl %eax, (%esp)
+ call _rpush
+ leave
+ ret
+ .def _rpush; .scl 3; .type 32; .endef
+_rpush:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ addl $4, %edi
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl %edi, (%esp)
+ call _put
+ leave
+ ret
+.globl _primitive_from_r
+ .def _primitive_from_r; .scl 2; .type 32; .endef
+_primitive_from_r:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_from_r_impl
+ leave
+ ret
+ .def _primitive_from_r_impl; .scl 3; .type 32; .endef
+_primitive_from_r_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _rpop
+ movl %eax, (%esp)
+ call _dpush
+ leave
+ ret
+ .def _rpop; .scl 3; .type 32; .endef
+_rpop:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %edi, (%esp)
+ call _get
+ movl %eax, -4(%ebp)
+ subl $4, %edi
+ movl -4(%ebp), %eax
+ leave
+ ret
+.globl _stack_to_array
+ .def _stack_to_array; .scl 2; .type 32; .endef
+_stack_to_array:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $40, %esp
+ movl 8(%ebp), %edx
+ movl 12(%ebp), %eax
+ subl %edx, %eax
+ addl $4, %eax
+ movl %eax, -4(%ebp)
+ cmpl $0, -4(%ebp)
+ jns L58
+ movl $0, -12(%ebp)
+ jmp L57
+L58:
+ movl -4(%ebp), %eax
+ movl %eax, -16(%ebp)
+ cmpl $0, -16(%ebp)
+ jns L60
+ addl $3, -16(%ebp)
+L60:
+ movl -16(%ebp), %eax
+ sarl $2, %eax
+ movl %eax, 4(%esp)
+ movl $8, (%esp)
+ call _allot_array_internal
+ movl %eax, -8(%ebp)
+ movl -4(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl -8(%ebp), %eax
+ addl $8, %eax
+ movl %eax, (%esp)
+ call _memcpy
+ movl -8(%ebp), %eax
+ movl %eax, (%esp)
+ call _tag_object
+ movl %eax, (%esp)
+ call _dpush
+ movl $1, -12(%ebp)
+L57:
+ movl -12(%ebp), %eax
+ leave
+ ret
+ .def _tag_object; .scl 3; .type 32; .endef
+_tag_object:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ andl $-8, %eax
+ orl $3, %eax
+ popl %ebp
+ ret
+.globl _primitive_datastack
+ .def _primitive_datastack; .scl 2; .type 32; .endef
+_primitive_datastack:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_datastack_impl
+ leave
+ ret
+ .def _primitive_datastack_impl; .scl 3; .type 32; .endef
+_primitive_datastack_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl %esi, 4(%esp)
+ movl _stack_chain, %eax
+ movl 24(%eax), %eax
+ movl (%eax), %eax
+ movl %eax, (%esp)
+ call _stack_to_array
+ testb %al, %al
+ jne L63
+ movl $0, 12(%esp)
+ movl $7, 8(%esp)
+ movl $7, 4(%esp)
+ movl $11, (%esp)
+ call _general_error
+L63:
+ leave
+ ret
+.globl _primitive_retainstack
+ .def _primitive_retainstack; .scl 2; .type 32; .endef
+_primitive_retainstack:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_retainstack_impl
+ leave
+ ret
+ .def _primitive_retainstack_impl; .scl 3; .type 32; .endef
+_primitive_retainstack_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl %edi, 4(%esp)
+ movl _stack_chain, %eax
+ movl 28(%eax), %eax
+ movl (%eax), %eax
+ movl %eax, (%esp)
+ call _stack_to_array
+ testb %al, %al
+ jne L66
+ movl $0, 12(%esp)
+ movl $7, 8(%esp)
+ movl $7, 4(%esp)
+ movl $13, (%esp)
+ call _general_error
+L66:
+ leave
+ ret
+.globl _array_to_stack
+ .def _array_to_stack; .scl 2; .type 32; .endef
+_array_to_stack:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _array_capacity
+ sall $2, %eax
+ movl %eax, -4(%ebp)
+ movl -4(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl 8(%ebp), %eax
+ addl $8, %eax
+ movl %eax, 4(%esp)
+ movl 12(%ebp), %eax
+ movl %eax, (%esp)
+ call _memcpy
+ movl -4(%ebp), %eax
+ addl 12(%ebp), %eax
+ subl $4, %eax
+ leave
+ ret
+ .def _array_capacity; .scl 3; .type 32; .endef
+_array_capacity:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ movl 4(%eax), %eax
+ shrl $3, %eax
+ popl %ebp
+ ret
+.globl _primitive_set_datastack
+ .def _primitive_set_datastack; .scl 2; .type 32; .endef
+_primitive_set_datastack:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_set_datastack_impl
+ leave
+ ret
+ .def _primitive_set_datastack_impl; .scl 3; .type 32; .endef
+_primitive_set_datastack_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpop
+ movl %eax, (%esp)
+ call _untag_array
+ movl %eax, %edx
+ movl _stack_chain, %eax
+ movl 24(%eax), %eax
+ movl (%eax), %eax
+ movl %eax, 4(%esp)
+ movl %edx, (%esp)
+ call _array_to_stack
+ movl %eax, %esi
+ leave
+ ret
+ .def _untag_array; .scl 3; .type 32; .endef
+_untag_array:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl 8(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl $8, (%esp)
+ call _type_check
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _untag_object
+ leave
+ ret
+ .def _untag_object; .scl 3; .type 32; .endef
+_untag_object:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ andl $-8, %eax
+ popl %ebp
+ ret
+ .def _type_check; .scl 3; .type 32; .endef
+_type_check:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl 12(%ebp), %eax
+ movl %eax, (%esp)
+ call _type_of
+ cmpl 8(%ebp), %eax
+ je L74
+ movl 12(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _type_error
+L74:
+ leave
+ ret
+ .def _type_of; .scl 3; .type 32; .endef
+_type_of:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ movl 8(%ebp), %eax
+ andl $7, %eax
+ movl %eax, -4(%ebp)
+ cmpl $3, -4(%ebp)
+ jne L77
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _object_type
+ movl %eax, -8(%ebp)
+ jmp L76
+L77:
+ movl -4(%ebp), %eax
+ movl %eax, -8(%ebp)
+L76:
+ movl -8(%ebp), %eax
+ leave
+ ret
+ .def _object_type; .scl 3; .type 32; .endef
+_object_type:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl 8(%ebp), %eax
+ andl $-8, %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, (%esp)
+ call _untag_header
+ leave
+ ret
+ .def _untag_header; .scl 3; .type 32; .endef
+_untag_header:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ shrl $3, %eax
+ popl %ebp
+ ret
+.globl _primitive_set_retainstack
+ .def _primitive_set_retainstack; .scl 2; .type 32; .endef
+_primitive_set_retainstack:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_set_retainstack_impl
+ leave
+ ret
+ .def _primitive_set_retainstack_impl; .scl 3; .type 32; .endef
+_primitive_set_retainstack_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpop
+ movl %eax, (%esp)
+ call _untag_array
+ movl %eax, %edx
+ movl _stack_chain, %eax
+ movl 28(%eax), %eax
+ movl (%eax), %eax
+ movl %eax, 4(%esp)
+ movl %edx, (%esp)
+ call _array_to_stack
+ movl %eax, %edi
+ leave
+ ret
+.globl _primitive_getenv
+ .def _primitive_getenv; .scl 2; .type 32; .endef
+_primitive_getenv:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_getenv_impl
+ leave
+ ret
+ .def _primitive_getenv_impl; .scl 3; .type 32; .endef
+_primitive_getenv_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpeek
+ movl %eax, (%esp)
+ call _untag_fixnum_fast
+ movl %eax, -4(%ebp)
+ movl -4(%ebp), %eax
+ movl _userenv(,%eax,4), %eax
+ movl %eax, (%esp)
+ call _drepl
+ leave
+ ret
+ .def _untag_fixnum_fast; .scl 3; .type 32; .endef
+_untag_fixnum_fast:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ sarl $3, %eax
+ popl %ebp
+ ret
+.globl _primitive_setenv
+ .def _primitive_setenv; .scl 2; .type 32; .endef
+_primitive_setenv:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_setenv_impl
+ leave
+ ret
+ .def _primitive_setenv_impl; .scl 3; .type 32; .endef
+_primitive_setenv_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ call _dpop
+ movl %eax, (%esp)
+ call _untag_fixnum_fast
+ movl %eax, -4(%ebp)
+ call _dpop
+ movl %eax, -8(%ebp)
+ movl -4(%ebp), %edx
+ movl -8(%ebp), %eax
+ movl %eax, _userenv(,%edx,4)
+ leave
+ ret
+.globl _primitive_exit
+ .def _primitive_exit; .scl 2; .type 32; .endef
+_primitive_exit:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_exit_impl
+ leave
+ ret
+ .def _primitive_exit_impl; .scl 3; .type 32; .endef
+_primitive_exit_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpop
+ movl %eax, (%esp)
+ call _to_fixnum
+ movl %eax, (%esp)
+ call _exit
+.globl _primitive_os_env
+ .def _primitive_os_env; .scl 2; .type 32; .endef
+_primitive_os_env:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_os_env_impl
+ leave
+ ret
+ .def _primitive_os_env_impl; .scl 3; .type 32; .endef
+_primitive_os_env_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ call _unbox_char_string
+ movl %eax, -4(%ebp)
+ movl -4(%ebp), %eax
+ movl %eax, (%esp)
+ call _getenv
+ movl %eax, -8(%ebp)
+ cmpl $0, -8(%ebp)
+ jne L92
+ movl $7, (%esp)
+ call _dpush
+ jmp L91
+L92:
+ movl -8(%ebp), %eax
+ movl %eax, (%esp)
+ call _box_char_string
+L91:
+ leave
+ ret
+.globl _primitive_eq
+ .def _primitive_eq; .scl 2; .type 32; .endef
+_primitive_eq:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_eq_impl
+ leave
+ ret
+ .def _primitive_eq_impl; .scl 3; .type 32; .endef
+_primitive_eq_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ call _dpop
+ movl %eax, -4(%ebp)
+ call _dpeek
+ movl %eax, -8(%ebp)
+ movl -4(%ebp), %eax
+ cmpl -8(%ebp), %eax
+ jne L96
+ movl _T, %eax
+ movl %eax, -12(%ebp)
+ jmp L97
+L96:
+ movl $7, -12(%ebp)
+L97:
+ movl -12(%ebp), %eax
+ movl %eax, (%esp)
+ call _drepl
+ leave
+ ret
+.globl _primitive_millis
+ .def _primitive_millis; .scl 2; .type 32; .endef
+_primitive_millis:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_millis_impl
+ leave
+ ret
+ .def _primitive_millis_impl; .scl 3; .type 32; .endef
+_primitive_millis_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _current_millis
+ movl %eax, (%esp)
+ movl %edx, 4(%esp)
+ call _box_unsigned_8
+ leave
+ ret
+.globl _primitive_sleep
+ .def _primitive_sleep; .scl 2; .type 32; .endef
+_primitive_sleep:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_sleep_impl
+ leave
+ ret
+ .def _primitive_sleep_impl; .scl 3; .type 32; .endef
+_primitive_sleep_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpop
+ movl %eax, (%esp)
+ call _to_cell
+ movl %eax, (%esp)
+ call _sleep_millis
+ leave
+ ret
+.globl _primitive_tag
+ .def _primitive_tag; .scl 2; .type 32; .endef
+_primitive_tag:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_tag_impl
+ leave
+ ret
+ .def _primitive_tag_impl; .scl 3; .type 32; .endef
+_primitive_tag_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ call _dpeek
+ andl $7, %eax
+ movl %eax, (%esp)
+ call _tag_fixnum
+ movl %eax, (%esp)
+ call _drepl
+ leave
+ ret
+ .def _tag_fixnum; .scl 3; .type 32; .endef
+_tag_fixnum:
+ pushl %ebp
+ movl %esp, %ebp
+ movl 8(%ebp), %eax
+ sall $3, %eax
+ andl $-8, %eax
+ popl %ebp
+ ret
+.globl _primitive_slot
+ .def _primitive_slot; .scl 2; .type 32; .endef
+_primitive_slot:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_slot_impl
+ leave
+ ret
+ .def _primitive_slot_impl; .scl 3; .type 32; .endef
+_primitive_slot_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ call _dpop
+ movl %eax, (%esp)
+ call _untag_fixnum_fast
+ movl %eax, -4(%ebp)
+ call _dpop
+ movl %eax, -8(%ebp)
+ movl -8(%ebp), %edx
+ andl $-8, %edx
+ movl -4(%ebp), %eax
+ sall $2, %eax
+ leal (%edx,%eax), %eax
+ movl %eax, (%esp)
+ call _get
+ movl %eax, (%esp)
+ call _dpush
+ leave
+ ret
+.globl _primitive_set_slot
+ .def _primitive_set_slot; .scl 2; .type 32; .endef
+_primitive_set_slot:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl %eax, -4(%ebp)
+ movl %edx, -8(%ebp)
+ movl -8(%ebp), %eax
+ call _save_callstack_top
+ call _primitive_set_slot_impl
+ leave
+ ret
+ .def _primitive_set_slot_impl; .scl 3; .type 32; .endef
+_primitive_set_slot_impl:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $24, %esp
+ call _dpop
+ movl %eax, (%esp)
+ call _untag_fixnum_fast
+ movl %eax, -4(%ebp)
+ call _dpop
+ movl %eax, -8(%ebp)
+ call _dpop
+ movl %eax, -12(%ebp)
+ movl -12(%ebp), %eax
+ movl %eax, 8(%esp)
+ movl -4(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl -8(%ebp), %eax
+ movl %eax, (%esp)
+ call _set_slot
+ leave
+ ret
+ .def _set_slot; .scl 3; .type 32; .endef
+_set_slot:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $8, %esp
+ movl 16(%ebp), %eax
+ movl %eax, 4(%esp)
+ movl 8(%ebp), %edx
+ andl $-8, %edx
+ movl 12(%ebp), %eax
+ sall $2, %eax
+ leal (%edx,%eax), %eax
+ movl %eax, (%esp)
+ call _put
+ movl 8(%ebp), %eax
+ movl %eax, (%esp)
+ call _write_barrier
+ leave
+ ret
+ .def _write_barrier; .scl 3; .type 32; .endef
+_write_barrier:
+ pushl %ebp
+ movl %esp, %ebp
+ subl $4, %esp
+ movl 8(%ebp), %eax
+ shrl $6, %eax
+ addl _cards_offset, %eax
+ movl %eax, -4(%ebp)
+ movl -4(%ebp), %edx
+ movl -4(%ebp), %eax
+ movzbl (%eax), %eax
+ orb $-64, %al
+ movb %al, (%edx)
+ leave
+ ret
+ .comm _console_open, 16 # 1
+ .comm _userenv, 256 # 256
+ .comm _T, 16 # 4
+ .comm _stack_chain, 16 # 4
+ .comm _ds_size, 16 # 4
+ .comm _rs_size, 16 # 4
+ .comm _stage2, 16 # 1
+ .comm _profiling_p, 16 # 1
+ .comm _signal_number, 16 # 4
+ .comm _signal_fault_addr, 16 # 4
+ .comm _signal_callstack_top, 16 # 4
+ .comm _secure_gc, 16 # 1
+ .comm _data_heap, 16 # 4
+ .comm _cards_offset, 16 # 4
+ .comm _newspace, 16 # 4
+ .comm _nursery, 16 # 4
+ .comm _gc_time, 16 # 8
+ .comm _nursery_collections, 16 # 4
+ .comm _aging_collections, 16 # 4
+ .comm _cards_scanned, 16 # 4
+ .comm _performing_gc, 16 # 1
+ .comm _collecting_gen, 16 # 4
+ .comm _collecting_aging_again, 16 # 1
+ .comm _last_code_heap_scan, 16 # 4
+ .comm _growing_data_heap, 16 # 1
+ .comm _old_data_heap, 16 # 4
+ .comm _gc_jmp, 208 # 208
+ .comm _heap_scan_ptr, 16 # 4
+ .comm _gc_off, 16 # 1
+ .comm _gc_locals_region, 16 # 4
+ .comm _gc_locals, 16 # 4
+ .comm _extra_roots_region, 16 # 4
+ .comm _extra_roots, 16 # 4
+ .comm _bignum_zero, 16 # 4
+ .comm _bignum_pos_one, 16 # 4
+ .comm _bignum_neg_one, 16 # 4
+ .comm _code_heap, 16 # 8
+ .comm _data_relocation_base, 16 # 4
+ .comm _code_relocation_base, 16 # 4
+ .comm _posix_argc, 16 # 4
+ .comm _posix_argv, 16 # 4
+ .def _sleep_millis; .scl 3; .type 32; .endef
+ .def _current_millis; .scl 3; .type 32; .endef
+ .def _getenv; .scl 3; .type 32; .endef
+ .def _exit; .scl 3; .type 32; .endef
+ .def _general_error; .scl 3; .type 32; .endef
+ .def _memcpy; .scl 3; .type 32; .endef
+ .def _allot_array_internal; .scl 3; .type 32; .endef
+ .def _save_callstack_top; .scl 3; .type 32; .endef
+ .def _free; .scl 3; .type 32; .endef
+ .def _dealloc_segment; .scl 3; .type 32; .endef
+ .def _alloc_segment; .scl 3; .type 32; .endef
+ .def _safe_malloc; .scl 3; .type 32; .endef
+ .def _type_error; .scl 3; .type 32; .endef
+ .section .drectve
+
+ .ascii " -export:nursery,data"
+ .ascii " -export:cards_offset,data"
+ .ascii " -export:stack_chain,data"
+ .ascii " -export:userenv,data"
+ .ascii " -export:unnest_stacks"
+ .ascii " -export:nest_stacks"
+ .ascii " -export:save_stacks"
From fcb78822b271c72cd6f14d314e260c0624ca86ab Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 00:16:05 -0500
Subject: [PATCH 223/288] Remove annoying and useless shadowing warnings
---
core/parser/parser-docs.factor | 4 ----
core/parser/parser.factor | 16 +---------------
2 files changed, 1 insertion(+), 19 deletions(-)
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 5adecca206..d11f036445 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -284,10 +284,6 @@ HELP: use
HELP: in
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
-HELP: shadow-warnings
-{ $values { "vocab" "an assoc mapping strings to words" } { "vocabs" "a sequence of assocs" } }
-{ $description "Tests if any keys in " { $snippet "vocab" } " shadow keys in the elements of " { $snippet "vocabs" } ", and if so, prints a warning message. These warning messages can be disabled by setting " { $link parser-notes } " to " { $link f } "." } ;
-
HELP: (use+)
{ $values { "vocab" "an assoc mapping strings to words" } }
{ $description "Adds an assoc at the front of the search path." }
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 7db7e46b3a..6d091fd1c0 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -191,22 +191,8 @@ SYMBOL: in
: word/vocab% ( word -- )
"(" % dup word-vocabulary % " " % word-name % ")" % ;
-: shadow-warning ( new old -- )
- 2dup eq? [
- 2drop
- ] [
- [ word/vocab% " shadowed by " % word/vocab% ] "" make
- note.
- ] if ;
-
-: shadow-warnings ( vocab vocabs -- )
- [
- swapd assoc-stack dup
- [ shadow-warning ] [ 2drop ] if
- ] curry assoc-each ;
-
: (use+) ( vocab -- )
- vocab-words use get 2dup shadow-warnings push ;
+ vocab-words use get push ;
: use+ ( vocab -- )
load-vocab (use+) ;
From 457fea23f7ce862e6cebf9ffc0fa648c35b53a1b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 00:16:15 -0500
Subject: [PATCH 224/288] Improved word completion
---
extra/ui/tools/listener/listener.factor | 30 +++++++++++++++----------
1 file changed, 18 insertions(+), 12 deletions(-)
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index 52c3d2de42..91f7b0ec5d 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
prettyprint listener debugger threads boxes concurrency.flags
-math arrays generic accessors ;
+math arrays generic accessors combinators ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
@@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- )
: clear-stack ( listener -- )
[ clear ] swap (call-listener) ;
-GENERIC# word-completion-string 1 ( word listener -- string )
+GENERIC: word-completion-string ( word -- string )
+
+M: word word-completion-string
+ word-name ;
M: method-body word-completion-string
- >r "method-generic" word-prop r> word-completion-string ;
+ "method-generic" word-prop word-completion-string ;
USE: generic.standard.engines.tuple
M: tuple-dispatch-engine-word word-completion-string
- >r "engine-generic" word-prop r> word-completion-string ;
+ "engine-generic" word-prop word-completion-string ;
-M: word word-completion-string ( word listener -- string )
- >r [ word-name ] [ word-vocabulary ] bi dup vocab-words r>
- input>> interactor-use memq?
- [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
+: use-if-necessary ( word seq -- )
+ >r word-vocabulary vocab-words r>
+ {
+ { [ dup not ] [ 2drop ] }
+ { [ 2dup memq? ] [ 2drop ] }
+ { [ t ] [ push ] }
+ } cond ;
: insert-word ( word -- )
- get-workspace
- workspace-listener
- [ word-completion-string ] keep
- input>> user-input ;
+ get-workspace workspace-listener input>>
+ [ >r word-completion-string r> user-input ]
+ [ interactor-use use-if-necessary ]
+ 2bi ;
: quot-action ( interactor -- lines )
dup control-value
From b0e322bffc2e59e38e4b373d1b4922b2fc933be4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 7 Apr 2008 14:19:29 -0500
Subject: [PATCH 225/288] refactor db some
---
extra/db/db.factor | 6 ++----
1 file changed, 2 insertions(+), 4 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 3cade1a895..1a1a18c942 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -41,6 +41,7 @@ TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
TUPLE: nonthrowable-statement < statement ;
TUPLE: throwable-statement < statement ;
+
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
@@ -49,6 +50,7 @@ TUPLE: throwable-statement < statement ;
] if ;
TUPLE: result-set sql in-params out-params handle n max ;
+
: construct-statement ( sql in out class -- statement )
construct-empty
swap >>out-params
@@ -101,10 +103,6 @@ M: nonthrowable-statement execute-statement ( statement -- )
swap >>in-params
swap >>sql ;
- ! >r >r { sql>> in-params>> out-params>> } get-slots r>
- ! { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
- ! construct r> construct-delegate ;
-
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
From 4180472ae9ac1b2dc4e6aff339f5b21f389867de Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 14:45:32 -0500
Subject: [PATCH 226/288] Fix listener tests
---
extra/ui/tools/listener/listener-tests.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor
index 13ce834df3..cc218533d8 100755
--- a/extra/ui/tools/listener/listener-tests.factor
+++ b/extra/ui/tools/listener/listener-tests.factor
@@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads ;
+threads arrays generic ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
@@ -13,11 +13,11 @@ IN: ui.tools.listener.tests
"listener" get [
[ "dup" ] [
- \ dup "listener" get word-completion-string
+ \ dup word-completion-string
] unit-test
- [ "USE: slots.private slot" ]
- [ \ slot "listener" get word-completion-string ] unit-test
+ [ "equal?" ]
+ [ \ array \ equal? method word-completion-string ] unit-test
<pane> <interactor> "i" set
From a24e2786c1a87788e1533d4e33209b17aa642a71 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 7 Apr 2008 14:49:31 -0500
Subject: [PATCH 227/288] remove special case for netbsd64 gcc
---
build-support/factor.sh | 5 -----
1 file changed, 5 deletions(-)
diff --git a/build-support/factor.sh b/build-support/factor.sh
index 476e885257..ea0c35aa83 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -89,11 +89,6 @@ set_md5sum() {
set_gcc() {
case $OS in
openbsd) ensure_program_installed egcc; CC=egcc;;
- netbsd) if [[ $WORD -eq 64 ]] ; then
- CC=/usr/pkg/gcc34/bin/gcc
- else
- CC=gcc
- fi ;;
*) CC=gcc;;
esac
}
From 719fc91432e8ec49a1c956bc8bb4bd95e7a4d63a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 7 Apr 2008 15:27:35 -0500
Subject: [PATCH 228/288] fix sqlite
---
extra/db/sqlite/sqlite.factor | 4 ++--
extra/db/tuples/tuples-tests.factor | 8 ++++----
2 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index e0930f3ba8..11c0150cd2 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -70,7 +70,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-db insert-tuple* ( tuple statement -- )
- execute-statement last-insert-id >>primary-key drop ;
+ execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
handle>> sqlite-#columns ;
@@ -168,7 +168,7 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
- [ column-name>> swap get-slot-named ] with subset
+ [ slot-name>> swap get-slot-named ] with subset
dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ;
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 6b61981119..951ded32ea 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -260,10 +260,10 @@ C: <secret> secret
! [ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
-! [ assigned-person-schema test-repeated-insert ] test-sqlite
-! [ native-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-repeated-insert ] test-postgresql
+ [ assigned-person-schema test-repeated-insert ] test-sqlite
+ [ native-person-schema test-tuples ] test-postgresql
+ [ assigned-person-schema test-tuples ] test-postgresql
+ [ assigned-person-schema test-repeated-insert ] test-postgresql
! \ insert-tuple must-infer
! \ update-tuple must-infer
From b1b889d8994e96968a47c5f93642fc76b6eb9864 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 7 Apr 2008 15:30:06 -0500
Subject: [PATCH 229/288] add some acl constants
---
extra/windows/advapi32/advapi32.factor | 195 ++++++++++++++++---------
1 file changed, 129 insertions(+), 66 deletions(-)
diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor
index 28091d3d9d..0d2f164c8d 100644
--- a/extra/windows/advapi32/advapi32.factor
+++ b/extra/windows/advapi32/advapi32.factor
@@ -61,6 +61,133 @@ LIBRARY: advapi32
: CRYPT_MACHINE_KEYSET HEX: 20 ; inline
: CRYPT_SILENT HEX: 40 ; inline
+C-STRUCT: ACL
+ { "BYTE" "AclRevision" }
+ { "BYTE" "Sbz1" }
+ { "WORD" "AclSize" }
+ { "WORD" "AceCount" }
+ { "WORD" "Sbz2" } ;
+
+TYPEDEF: ACL* PACL
+
+: ACCESS_ALLOWED_ACE_TYPE 0 ; inline
+: ACCESS_DENIED_ACE_TYPE 1 ; inline
+: SYSTEM_AUDIT_ACE_TYPE 2 ; inline
+: SYSTEM_ALARM_ACE_TYPE 3 ; inline
+
+: OBJECT_INHERIT_ACE HEX: 1 ; inline
+: CONTAINER_INHERIT_ACE HEX: 2 ; inline
+: NO_PROPAGATE_INHERIT_ACE HEX: 4 ; inline
+: INHERIT_ONLY_ACE HEX: 8 ; inline
+: VALID_INHERIT_FLAGS HEX: f ; inline
+
+C-STRUCT: ACE_HEADER
+ { "BYTE" "AceType" }
+ { "BYTE" "AceFlags" }
+ { "WORD" "AceSize" } ;
+
+TYPEDEF: ACE_HEADER* PACE_HEADER
+
+C-STRUCT: ACCESS_ALLOWED_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE
+
+C-STRUCT: ACCESS_DENIED_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE
+
+
+C-STRUCT: SYSTEM_AUDIT_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE
+
+C-STRUCT: SYSTEM_ALARM_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE
+
+C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
+
+
+! typedef enum _TOKEN_INFORMATION_CLASS {
+: TokenUser 1 ; inline
+: TokenGroups 2 ; inline
+: TokenPrivileges 3 ; inline
+: TokenOwner 4 ; inline
+: TokenPrimaryGroup 5 ; inline
+: TokenDefaultDacl 6 ; inline
+: TokenSource 7 ; inline
+: TokenType 8 ; inline
+: TokenImpersonationLevel 9 ; inline
+: TokenStatistics 10 ; inline
+: TokenRestrictedSids 11 ; inline
+: TokenSessionId 12 ; inline
+: TokenGroupsAndPrivileges 13 ; inline
+: TokenSessionReference 14 ; inline
+: TokenSandBoxInert 15 ; inline
+! } TOKEN_INFORMATION_CLASS;
+
+: DELETE HEX: 00010000 ; inline
+: READ_CONTROL HEX: 00020000 ; inline
+: WRITE_DAC HEX: 00040000 ; inline
+: WRITE_OWNER HEX: 00080000 ; inline
+: SYNCHRONIZE HEX: 00100000 ; inline
+: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
+
+: STANDARD_RIGHTS_READ READ_CONTROL ; inline
+: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
+: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
+
+: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
+: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
+: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
+: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
+: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
+: TOKEN_DUPLICATE HEX: 0002 ; inline
+: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
+: TOKEN_IMPERSONATE HEX: 0004 ; inline
+: TOKEN_QUERY HEX: 0008 ; inline
+: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
+: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
+: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
+
+: TOKEN_WRITE
+ {
+ STANDARD_RIGHTS_WRITE
+ TOKEN_ADJUST_PRIVILEGES
+ TOKEN_ADJUST_GROUPS
+ TOKEN_ADJUST_DEFAULT
+ } flags ; foldable
+
+: TOKEN_ALL_ACCESS
+ {
+ STANDARD_RIGHTS_REQUIRED
+ TOKEN_ASSIGN_PRIMARY
+ TOKEN_DUPLICATE
+ TOKEN_IMPERSONATE
+ TOKEN_QUERY
+ TOKEN_QUERY_SOURCE
+ TOKEN_ADJUST_PRIVILEGES
+ TOKEN_ADJUST_GROUPS
+ TOKEN_ADJUST_SESSIONID
+ TOKEN_ADJUST_DEFAULT
+ } flags ; foldable
+
! : I_ScGetCurrentGroupStateW ;
! : A_SHAFinal ;
@@ -85,7 +212,7 @@ LIBRARY: advapi32
! : AddAccessDeniedAce ;
! : AddAccessDeniedAceEx ;
! : AddAccessDeniedObjectAce ;
-! : AddAce ;
+FUNCTION: BOOL AddAce ( PACL pAcl, DWORD dwAceRevision, DWORD dwStartingAceIndex, LPVOID pAceList, DWORD nAceListLength ) ;
! : AddAuditAccessAce ;
! : AddAuditAccessAceEx ;
! : AddAuditAccessObjectAce ;
@@ -382,7 +509,7 @@ FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ;
! : ImpersonateLoggedOnUser ;
! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ;
-! : InitializeAcl ;
+FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
! : InitializeSecurityDescriptor ;
! : InitializeSid ;
! : InitiateSystemShutdownA ;
@@ -508,70 +635,6 @@ FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName,
! : OpenEventLogA ;
! : OpenEventLogW ;
-! typedef enum _TOKEN_INFORMATION_CLASS {
-: TokenUser 1 ;
-: TokenGroups 2 ;
-: TokenPrivileges 3 ;
-: TokenOwner 4 ;
-: TokenPrimaryGroup 5 ;
-: TokenDefaultDacl 6 ;
-: TokenSource 7 ;
-: TokenType 8 ;
-: TokenImpersonationLevel 9 ;
-: TokenStatistics 10 ;
-: TokenRestrictedSids 11 ;
-: TokenSessionId 12 ;
-: TokenGroupsAndPrivileges 13 ;
-: TokenSessionReference 14 ;
-: TokenSandBoxInert 15 ;
-! } TOKEN_INFORMATION_CLASS;
-
-: DELETE HEX: 00010000 ; inline
-: READ_CONTROL HEX: 00020000 ; inline
-: WRITE_DAC HEX: 00040000 ; inline
-: WRITE_OWNER HEX: 00080000 ; inline
-: SYNCHRONIZE HEX: 00100000 ; inline
-: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
-
-: STANDARD_RIGHTS_READ READ_CONTROL ; inline
-: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
-: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
-
-: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
-: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
-: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
-: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
-: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
-: TOKEN_DUPLICATE HEX: 0002 ; inline
-: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
-: TOKEN_IMPERSONATE HEX: 0004 ; inline
-: TOKEN_QUERY HEX: 0008 ; inline
-: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
-: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
-: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
-
-: TOKEN_WRITE
- {
- STANDARD_RIGHTS_WRITE
- TOKEN_ADJUST_PRIVILEGES
- TOKEN_ADJUST_GROUPS
- TOKEN_ADJUST_DEFAULT
- } flags ; foldable
-
-: TOKEN_ALL_ACCESS
- {
- STANDARD_RIGHTS_REQUIRED
- TOKEN_ASSIGN_PRIMARY
- TOKEN_DUPLICATE
- TOKEN_IMPERSONATE
- TOKEN_QUERY
- TOKEN_QUERY_SOURCE
- TOKEN_ADJUST_PRIVILEGES
- TOKEN_ADJUST_GROUPS
- TOKEN_ADJUST_SESSIONID
- TOKEN_ADJUST_DEFAULT
- } flags ; foldable
-
FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle,
DWORD DesiredAccess,
PHANDLE TokenHandle ) ;
From 3164cda6fb4dc8541c0154518321ca946245e54d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 15:45:08 -0500
Subject: [PATCH 230/288] Remove bogus files
---
vm/data_gc.h | 4 +-
vm/errors.s | 687 -----------------------
vm/run.s | 1511 --------------------------------------------------
3 files changed, 2 insertions(+), 2200 deletions(-)
delete mode 100644 vm/errors.s
delete mode 100644 vm/run.s
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 0adcf0ca39..d3b8b6e39e 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -315,8 +315,6 @@ INLINE void* allot_object(CELL type, CELL a)
{
CELL *object;
- /* If the object is bigger than the nursery, allocate it in
- tenured space */
if(nursery->size - ALLOT_BUFFER_ZONE > a)
{
/* If there is insufficient room, collect the nursery */
@@ -325,6 +323,8 @@ INLINE void* allot_object(CELL type, CELL a)
object = allot_zone(nursery,a);
}
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
else
{
F_ZONE *tenured = &data_heap->generations[TENURED];
diff --git a/vm/errors.s b/vm/errors.s
deleted file mode 100644
index d6b3bdb6e5..0000000000
--- a/vm/errors.s
+++ /dev/null
@@ -1,687 +0,0 @@
- .file "errors.c"
- .section .rdata,"dr"
-LC0:
- .ascii "fatal_error: %s %lx\12\0"
- .text
-.globl _fatal_error
- .def _fatal_error; .scl 2; .type 32; .endef
-_fatal_error:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- call ___getreent
- movl %eax, %edx
- movl 12(%ebp), %eax
- movl %eax, 12(%esp)
- movl 8(%ebp), %eax
- movl %eax, 8(%esp)
- movl $LC0, 4(%esp)
- movl 12(%edx), %eax
- movl %eax, (%esp)
- call _fprintf
- movl $1, (%esp)
- call _exit
- .section .rdata,"dr"
- .align 4
-LC1:
- .ascii "You have triggered a bug in Factor. Please report.\12\0"
-LC2:
- .ascii "critical_error: %s %lx\12\0"
- .text
-.globl _critical_error
- .def _critical_error; .scl 2; .type 32; .endef
-_critical_error:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- call ___getreent
- movl $LC1, 4(%esp)
- movl 12(%eax), %eax
- movl %eax, (%esp)
- call _fprintf
- call ___getreent
- movl %eax, %edx
- movl 12(%ebp), %eax
- movl %eax, 12(%esp)
- movl 8(%ebp), %eax
- movl %eax, 8(%esp)
- movl $LC2, 4(%esp)
- movl 12(%edx), %eax
- movl %eax, (%esp)
- call _fprintf
- call _factorbug
- leave
- ret
- .section .rdata,"dr"
-LC3:
- .ascii "early_error: \0"
-LC4:
- .ascii "\12\0"
- .text
-.globl _throw_error
- .def _throw_error; .scl 2; .type 32; .endef
-_throw_error:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- cmpl $7, _userenv+20
- je L4
- movb $0, _gc_off
- movl _gc_locals_region, %eax
- movl (%eax), %eax
- subl $4, %eax
- movl %eax, _gc_locals
- movl _extra_roots_region, %eax
- movl (%eax), %eax
- subl $4, %eax
- movl %eax, _extra_roots
- call _fix_stacks
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _dpush
- cmpl $0, 12(%ebp)
- je L5
- movl _stack_chain, %eax
- movl 4(%eax), %eax
- movl %eax, 4(%esp)
- movl 12(%ebp), %eax
- movl %eax, (%esp)
- call _fix_callstack_top
- movl %eax, 12(%ebp)
- jmp L6
-L5:
- movl _stack_chain, %eax
- movl (%eax), %eax
- movl %eax, 12(%ebp)
-L6:
- movl 12(%ebp), %edx
- movl _userenv+20, %eax
- call _throw_impl
- jmp L3
-L4:
- call ___getreent
- movl $LC1, 4(%esp)
- movl 12(%eax), %eax
- movl %eax, (%esp)
- call _fprintf
- call ___getreent
- movl $LC3, 4(%esp)
- movl 12(%eax), %eax
- movl %eax, (%esp)
- call _fprintf
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _print_obj
- call ___getreent
- movl $LC4, 4(%esp)
- movl 12(%eax), %eax
- movl %eax, (%esp)
- call _fprintf
- call _factorbug
-L3:
- leave
- ret
- .def _dpush; .scl 3; .type 32; .endef
-_dpush:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- addl $4, %esi
- movl 8(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- leave
- ret
- .def _put; .scl 3; .type 32; .endef
-_put:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %edx
- movl 12(%ebp), %eax
- movl %eax, (%edx)
- popl %ebp
- ret
-.globl _general_error
- .def _general_error; .scl 2; .type 32; .endef
-_general_error:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _tag_fixnum
- movl %eax, %edx
- movl 16(%ebp), %eax
- movl %eax, 12(%esp)
- movl 12(%ebp), %eax
- movl %eax, 8(%esp)
- movl %edx, 4(%esp)
- movl _userenv+24, %eax
- movl %eax, (%esp)
- call _allot_array_4
- movl %eax, %edx
- movl 20(%ebp), %eax
- movl %eax, 4(%esp)
- movl %edx, (%esp)
- call _throw_error
- leave
- ret
- .def _tag_fixnum; .scl 3; .type 32; .endef
-_tag_fixnum:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- sall $3, %eax
- andl $-8, %eax
- popl %ebp
- ret
-.globl _type_error
- .def _type_error; .scl 2; .type 32; .endef
-_type_error:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _tag_fixnum
- movl %eax, %edx
- movl $0, 12(%esp)
- movl 12(%ebp), %eax
- movl %eax, 8(%esp)
- movl %edx, 4(%esp)
- movl $3, (%esp)
- call _general_error
- leave
- ret
-.globl _not_implemented_error
- .def _not_implemented_error; .scl 2; .type 32; .endef
-_not_implemented_error:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl $0, 12(%esp)
- movl $7, 8(%esp)
- movl $7, 4(%esp)
- movl $2, (%esp)
- call _general_error
- leave
- ret
-.globl _in_page
- .def _in_page; .scl 2; .type 32; .endef
-_in_page:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _getpagesize
- movl %eax, -4(%ebp)
- movl 16(%ebp), %edx
- leal 12(%ebp), %eax
- addl %edx, (%eax)
- movl 20(%ebp), %eax
- movl %eax, %edx
- imull -4(%ebp), %edx
- leal 12(%ebp), %eax
- addl %edx, (%eax)
- movb $0, -5(%ebp)
- movl 8(%ebp), %eax
- cmpl 12(%ebp), %eax
- jb L15
- movl -4(%ebp), %eax
- addl 12(%ebp), %eax
- cmpl 8(%ebp), %eax
- jb L15
- movb $1, -5(%ebp)
-L15:
- movzbl -5(%ebp), %eax
- leave
- ret
- .section .rdata,"dr"
- .align 4
-LC5:
- .ascii "allot_object() missed GC check\0"
-LC6:
- .ascii "gc locals underflow\0"
-LC7:
- .ascii "gc locals overflow\0"
-LC8:
- .ascii "extra roots underflow\0"
-LC9:
- .ascii "extra roots overflow\0"
- .text
-.globl _memory_protection_error
- .def _memory_protection_error; .scl 2; .type 32; .endef
-_memory_protection_error:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl $-1, 12(%esp)
- movl $0, 8(%esp)
- movl _stack_chain, %eax
- movl 24(%eax), %eax
- movl (%eax), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _in_page
- testb %al, %al
- je L17
- movl 12(%ebp), %eax
- movl %eax, 12(%esp)
- movl $7, 8(%esp)
- movl $7, 4(%esp)
- movl $11, (%esp)
- call _general_error
- jmp L16
-L17:
- movl $0, 12(%esp)
- movl _ds_size, %eax
- movl %eax, 8(%esp)
- movl _stack_chain, %eax
- movl 24(%eax), %eax
- movl (%eax), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _in_page
- testb %al, %al
- je L19
- movl 12(%ebp), %eax
- movl %eax, 12(%esp)
- movl $7, 8(%esp)
- movl $7, 4(%esp)
- movl $12, (%esp)
- call _general_error
- jmp L16
-L19:
- movl $-1, 12(%esp)
- movl $0, 8(%esp)
- movl _stack_chain, %eax
- movl 28(%eax), %eax
- movl (%eax), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _in_page
- testb %al, %al
- je L21
- movl 12(%ebp), %eax
- movl %eax, 12(%esp)
- movl $7, 8(%esp)
- movl $7, 4(%esp)
- movl $13, (%esp)
- call _general_error
- jmp L16
-L21:
- movl $0, 12(%esp)
- movl _rs_size, %eax
- movl %eax, 8(%esp)
- movl _stack_chain, %eax
- movl 28(%eax), %eax
- movl (%eax), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _in_page
- testb %al, %al
- je L23
- movl 12(%ebp), %eax
- movl %eax, 12(%esp)
- movl $7, 8(%esp)
- movl $7, 4(%esp)
- movl $14, (%esp)
- call _general_error
- jmp L16
-L23:
- movl $0, 12(%esp)
- movl $0, 8(%esp)
- movl _nursery, %eax
- movl 12(%eax), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _in_page
- testb %al, %al
- je L25
- movl $0, 4(%esp)
- movl $LC5, (%esp)
- call _critical_error
- jmp L16
-L25:
- movl $-1, 12(%esp)
- movl $0, 8(%esp)
- movl _gc_locals_region, %eax
- movl (%eax), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _in_page
- testb %al, %al
- je L27
- movl $0, 4(%esp)
- movl $LC6, (%esp)
- call _critical_error
- jmp L16
-L27:
- movl $0, 12(%esp)
- movl $0, 8(%esp)
- movl _gc_locals_region, %eax
- movl 8(%eax), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _in_page
- testb %al, %al
- je L29
- movl $0, 4(%esp)
- movl $LC7, (%esp)
- call _critical_error
- jmp L16
-L29:
- movl $-1, 12(%esp)
- movl $0, 8(%esp)
- movl _extra_roots_region, %eax
- movl (%eax), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _in_page
- testb %al, %al
- je L31
- movl $0, 4(%esp)
- movl $LC8, (%esp)
- call _critical_error
- jmp L16
-L31:
- movl $0, 12(%esp)
- movl $0, 8(%esp)
- movl _extra_roots_region, %eax
- movl 8(%eax), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _in_page
- testb %al, %al
- je L33
- movl $0, 4(%esp)
- movl $LC9, (%esp)
- call _critical_error
- jmp L16
-L33:
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _allot_cell
- movl %eax, %edx
- movl 12(%ebp), %eax
- movl %eax, 12(%esp)
- movl $7, 8(%esp)
- movl %edx, 4(%esp)
- movl $15, (%esp)
- call _general_error
-L16:
- leave
- ret
- .def _allot_cell; .scl 3; .type 32; .endef
-_allot_cell:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- cmpl $268435455, 8(%ebp)
- jbe L36
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _cell_to_bignum
- movl %eax, (%esp)
- call _tag_bignum
- movl %eax, -4(%ebp)
- jmp L35
-L36:
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _tag_fixnum
- movl %eax, -4(%ebp)
-L35:
- movl -4(%ebp), %eax
- leave
- ret
- .def _tag_bignum; .scl 3; .type 32; .endef
-_tag_bignum:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- andl $-8, %eax
- orl $1, %eax
- popl %ebp
- ret
-.globl _signal_error
- .def _signal_error; .scl 2; .type 32; .endef
-_signal_error:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _tag_fixnum
- movl %eax, %edx
- movl 12(%ebp), %eax
- movl %eax, 12(%esp)
- movl $7, 8(%esp)
- movl %edx, 4(%esp)
- movl $5, (%esp)
- call _general_error
- leave
- ret
-.globl _divide_by_zero_error
- .def _divide_by_zero_error; .scl 2; .type 32; .endef
-_divide_by_zero_error:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl 8(%ebp), %eax
- movl %eax, 12(%esp)
- movl $7, 8(%esp)
- movl $7, 4(%esp)
- movl $4, (%esp)
- call _general_error
- leave
- ret
-.globl _memory_signal_handler_impl
- .def _memory_signal_handler_impl; .scl 2; .type 32; .endef
-_memory_signal_handler_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl _signal_callstack_top, %eax
- movl %eax, 4(%esp)
- movl _signal_fault_addr, %eax
- movl %eax, (%esp)
- call _memory_protection_error
- leave
- ret
-.globl _divide_by_zero_signal_handler_impl
- .def _divide_by_zero_signal_handler_impl; .scl 2; .type 32; .endef
-_divide_by_zero_signal_handler_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl _signal_callstack_top, %eax
- movl %eax, (%esp)
- call _divide_by_zero_error
- leave
- ret
-.globl _misc_signal_handler_impl
- .def _misc_signal_handler_impl; .scl 2; .type 32; .endef
-_misc_signal_handler_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl _signal_callstack_top, %eax
- movl %eax, 4(%esp)
- movl _signal_number, %eax
- movl %eax, (%esp)
- call _signal_error
- leave
- ret
-.globl _primitive_throw
- .def _primitive_throw; .scl 2; .type 32; .endef
-_primitive_throw:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_throw_impl
- leave
- ret
- .def _primitive_throw_impl; .scl 3; .type 32; .endef
-_primitive_throw_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpop
- call _dpop
- movl %eax, %ecx
- movl _stack_chain, %eax
- movl (%eax), %edx
- movl %ecx, %eax
- call _throw_impl
- leave
- ret
- .def _dpop; .scl 3; .type 32; .endef
-_dpop:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %esi, (%esp)
- call _get
- movl %eax, -4(%ebp)
- subl $4, %esi
- movl -4(%ebp), %eax
- leave
- ret
- .def _get; .scl 3; .type 32; .endef
-_get:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- movl (%eax), %eax
- popl %ebp
- ret
-.globl _primitive_call_clear
- .def _primitive_call_clear; .scl 2; .type 32; .endef
-_primitive_call_clear:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_call_clear_impl
- leave
- ret
- .def _primitive_call_clear_impl; .scl 3; .type 32; .endef
-_primitive_call_clear_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpop
- movl _stack_chain, %edx
- movl 4(%edx), %edx
- call _throw_impl
- leave
- ret
-.globl _primitive_unimplemented2
- .def _primitive_unimplemented2; .scl 2; .type 32; .endef
-_primitive_unimplemented2:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- call _not_implemented_error
- leave
- ret
-.globl _primitive_unimplemented
- .def _primitive_unimplemented; .scl 2; .type 32; .endef
-_primitive_unimplemented:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_unimplemented_impl
- leave
- ret
- .def _primitive_unimplemented_impl; .scl 3; .type 32; .endef
-_primitive_unimplemented_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _not_implemented_error
- leave
- ret
- .comm _console_open, 16 # 1
- .comm _userenv, 256 # 256
- .comm _T, 16 # 4
- .comm _stack_chain, 16 # 4
- .comm _ds_size, 16 # 4
- .comm _rs_size, 16 # 4
- .comm _stage2, 16 # 1
- .comm _profiling_p, 16 # 1
- .comm _signal_number, 16 # 4
- .comm _signal_fault_addr, 16 # 4
- .comm _signal_callstack_top, 16 # 4
- .comm _secure_gc, 16 # 1
- .comm _data_heap, 16 # 4
- .comm _cards_offset, 16 # 4
- .comm _newspace, 16 # 4
- .comm _nursery, 16 # 4
- .comm _gc_time, 16 # 8
- .comm _nursery_collections, 16 # 4
- .comm _aging_collections, 16 # 4
- .comm _cards_scanned, 16 # 4
- .comm _performing_gc, 16 # 1
- .comm _collecting_gen, 16 # 4
- .comm _collecting_aging_again, 16 # 1
- .comm _last_code_heap_scan, 16 # 4
- .comm _growing_data_heap, 16 # 1
- .comm _old_data_heap, 16 # 4
- .comm _gc_jmp, 208 # 208
- .comm _heap_scan_ptr, 16 # 4
- .comm _gc_off, 16 # 1
- .comm _gc_locals_region, 16 # 4
- .comm _gc_locals, 16 # 4
- .comm _extra_roots_region, 16 # 4
- .comm _extra_roots, 16 # 4
- .comm _bignum_zero, 16 # 4
- .comm _bignum_pos_one, 16 # 4
- .comm _bignum_neg_one, 16 # 4
- .comm _code_heap, 16 # 8
- .comm _data_relocation_base, 16 # 4
- .comm _code_relocation_base, 16 # 4
- .comm _posix_argc, 16 # 4
- .comm _posix_argv, 16 # 4
- .def _save_callstack_top; .scl 3; .type 32; .endef
- .def _getpagesize; .scl 3; .type 32; .endef
- .def _allot_array_4; .scl 3; .type 32; .endef
- .def _print_obj; .scl 3; .type 32; .endef
- .def _throw_impl; .scl 3; .type 32; .endef
- .def _fix_callstack_top; .scl 3; .type 32; .endef
- .def _fix_stacks; .scl 3; .type 32; .endef
- .def _factorbug; .scl 3; .type 32; .endef
- .def _exit; .scl 3; .type 32; .endef
- .def ___getreent; .scl 3; .type 32; .endef
- .def _fprintf; .scl 3; .type 32; .endef
- .def _critical_error; .scl 3; .type 32; .endef
- .def _type_error; .scl 3; .type 32; .endef
- .section .drectve
-
- .ascii " -export:nursery,data"
- .ascii " -export:cards_offset,data"
- .ascii " -export:stack_chain,data"
- .ascii " -export:userenv,data"
diff --git a/vm/run.s b/vm/run.s
deleted file mode 100644
index 78b2adac84..0000000000
--- a/vm/run.s
+++ /dev/null
@@ -1,1511 +0,0 @@
- .file "run.c"
- .text
-.globl _reset_datastack
- .def _reset_datastack; .scl 2; .type 32; .endef
-_reset_datastack:
- pushl %ebp
- movl %esp, %ebp
- movl _stack_chain, %eax
- movl 24(%eax), %eax
- movl (%eax), %esi
- subl $4, %esi
- popl %ebp
- ret
-.globl _reset_retainstack
- .def _reset_retainstack; .scl 2; .type 32; .endef
-_reset_retainstack:
- pushl %ebp
- movl %esp, %ebp
- movl _stack_chain, %eax
- movl 28(%eax), %eax
- movl (%eax), %edi
- subl $4, %edi
- popl %ebp
- ret
-.globl _fix_stacks
- .def _fix_stacks; .scl 2; .type 32; .endef
-_fix_stacks:
- pushl %ebp
- movl %esp, %ebp
- leal 4(%esi), %eax
- movl _stack_chain, %edx
- movl 24(%edx), %edx
- cmpl (%edx), %eax
- jb L5
- leal 256(%esi), %eax
- movl _stack_chain, %edx
- movl 24(%edx), %edx
- cmpl 8(%edx), %eax
- jae L5
- jmp L4
-L5:
- call _reset_datastack
-L4:
- leal 4(%edi), %eax
- movl _stack_chain, %edx
- movl 28(%edx), %edx
- cmpl (%edx), %eax
- jb L7
- leal 256(%edi), %eax
- movl _stack_chain, %edx
- movl 28(%edx), %edx
- cmpl 8(%edx), %eax
- jae L7
- jmp L3
-L7:
- call _reset_retainstack
-L3:
- popl %ebp
- ret
-.globl _save_stacks
- .def _save_stacks; .scl 2; .type 32; .endef
-_save_stacks:
- pushl %ebp
- movl %esp, %ebp
- cmpl $0, _stack_chain
- je L8
- movl _stack_chain, %eax
- movl %esi, 8(%eax)
- movl _stack_chain, %eax
- movl %edi, 12(%eax)
-L8:
- popl %ebp
- ret
-.globl _nest_stacks
- .def _nest_stacks; .scl 2; .type 32; .endef
-_nest_stacks:
- pushl %ebp
- movl %esp, %ebp
- pushl %ebx
- subl $20, %esp
- movl $44, (%esp)
- call _safe_malloc
- movl %eax, -8(%ebp)
- movl -8(%ebp), %eax
- movl $-1, 4(%eax)
- movl -8(%ebp), %eax
- movl $-1, (%eax)
- movl -8(%ebp), %eax
- movl %esi, 16(%eax)
- movl -8(%ebp), %eax
- movl %edi, 20(%eax)
- movl -8(%ebp), %edx
- movl _userenv+8, %eax
- movl %eax, 36(%edx)
- movl -8(%ebp), %edx
- movl _userenv+4, %eax
- movl %eax, 32(%edx)
- movl -8(%ebp), %ebx
- movl _ds_size, %eax
- movl %eax, (%esp)
- call _alloc_segment
- movl %eax, 24(%ebx)
- movl -8(%ebp), %ebx
- movl _rs_size, %eax
- movl %eax, (%esp)
- call _alloc_segment
- movl %eax, 28(%ebx)
- movl -8(%ebp), %edx
- movl _stack_chain, %eax
- movl %eax, 40(%edx)
- movl -8(%ebp), %eax
- movl %eax, _stack_chain
- call _reset_datastack
- call _reset_retainstack
- addl $20, %esp
- popl %ebx
- popl %ebp
- ret
-.globl _unnest_stacks
- .def _unnest_stacks; .scl 2; .type 32; .endef
-_unnest_stacks:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl _stack_chain, %eax
- movl 24(%eax), %eax
- movl %eax, (%esp)
- call _dealloc_segment
- movl _stack_chain, %eax
- movl 28(%eax), %eax
- movl %eax, (%esp)
- call _dealloc_segment
- movl _stack_chain, %eax
- movl 16(%eax), %esi
- movl _stack_chain, %eax
- movl 20(%eax), %edi
- movl _stack_chain, %eax
- movl 36(%eax), %eax
- movl %eax, _userenv+8
- movl _stack_chain, %eax
- movl 32(%eax), %eax
- movl %eax, _userenv+4
- movl _stack_chain, %eax
- movl %eax, -4(%ebp)
- movl -4(%ebp), %eax
- movl 40(%eax), %eax
- movl %eax, _stack_chain
- movl -4(%ebp), %eax
- movl %eax, (%esp)
- call _free
- leave
- ret
-.globl _init_stacks
- .def _init_stacks; .scl 2; .type 32; .endef
-_init_stacks:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- movl %eax, _ds_size
- movl 12(%ebp), %eax
- movl %eax, _rs_size
- movl $0, _stack_chain
- popl %ebp
- ret
-.globl _primitive_drop
- .def _primitive_drop; .scl 2; .type 32; .endef
-_primitive_drop:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_drop_impl
- leave
- ret
- .def _primitive_drop_impl; .scl 3; .type 32; .endef
-_primitive_drop_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpop
- leave
- ret
- .def _dpop; .scl 3; .type 32; .endef
-_dpop:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %esi, (%esp)
- call _get
- movl %eax, -4(%ebp)
- subl $4, %esi
- movl -4(%ebp), %eax
- leave
- ret
- .def _get; .scl 3; .type 32; .endef
-_get:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- movl (%eax), %eax
- popl %ebp
- ret
-.globl _primitive_2drop
- .def _primitive_2drop; .scl 2; .type 32; .endef
-_primitive_2drop:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_2drop_impl
- leave
- ret
- .def _primitive_2drop_impl; .scl 3; .type 32; .endef
-_primitive_2drop_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esi
- popl %ebp
- ret
-.globl _primitive_3drop
- .def _primitive_3drop; .scl 2; .type 32; .endef
-_primitive_3drop:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_3drop_impl
- leave
- ret
- .def _primitive_3drop_impl; .scl 3; .type 32; .endef
-_primitive_3drop_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $12, %esi
- popl %ebp
- ret
-.globl _primitive_dup
- .def _primitive_dup; .scl 2; .type 32; .endef
-_primitive_dup:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_dup_impl
- leave
- ret
- .def _primitive_dup_impl; .scl 3; .type 32; .endef
-_primitive_dup_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpeek
- movl %eax, (%esp)
- call _dpush
- leave
- ret
- .def _dpush; .scl 3; .type 32; .endef
-_dpush:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- addl $4, %esi
- movl 8(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- leave
- ret
- .def _put; .scl 3; .type 32; .endef
-_put:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %edx
- movl 12(%ebp), %eax
- movl %eax, (%edx)
- popl %ebp
- ret
- .def _dpeek; .scl 3; .type 32; .endef
-_dpeek:
- pushl %ebp
- movl %esp, %ebp
- subl $4, %esp
- movl %esi, (%esp)
- call _get
- leave
- ret
-.globl _primitive_2dup
- .def _primitive_2dup; .scl 2; .type 32; .endef
-_primitive_2dup:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_2dup_impl
- leave
- ret
- .def _primitive_2dup_impl; .scl 3; .type 32; .endef
-_primitive_2dup_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $16, %esp
- call _dpeek
- movl %eax, -4(%ebp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -8(%ebp)
- addl $8, %esi
- movl -8(%ebp), %eax
- movl %eax, 4(%esp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _put
- movl -4(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- leave
- ret
-.globl _primitive_3dup
- .def _primitive_3dup; .scl 2; .type 32; .endef
-_primitive_3dup:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_3dup_impl
- leave
- ret
- .def _primitive_3dup_impl; .scl 3; .type 32; .endef
-_primitive_3dup_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $20, %esp
- call _dpeek
- movl %eax, -4(%ebp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -8(%ebp)
- leal -8(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -12(%ebp)
- addl $12, %esi
- movl -4(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- movl -8(%ebp), %eax
- movl %eax, 4(%esp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _put
- movl -12(%ebp), %eax
- movl %eax, 4(%esp)
- leal -8(%esi), %eax
- movl %eax, (%esp)
- call _put
- leave
- ret
-.globl _primitive_rot
- .def _primitive_rot; .scl 2; .type 32; .endef
-_primitive_rot:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_rot_impl
- leave
- ret
- .def _primitive_rot_impl; .scl 3; .type 32; .endef
-_primitive_rot_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $20, %esp
- call _dpeek
- movl %eax, -4(%ebp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -8(%ebp)
- leal -8(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -12(%ebp)
- movl -12(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- movl -4(%ebp), %eax
- movl %eax, 4(%esp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _put
- movl -8(%ebp), %eax
- movl %eax, 4(%esp)
- leal -8(%esi), %eax
- movl %eax, (%esp)
- call _put
- leave
- ret
-.globl _primitive__rot
- .def _primitive__rot; .scl 2; .type 32; .endef
-_primitive__rot:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive__rot_impl
- leave
- ret
- .def _primitive__rot_impl; .scl 3; .type 32; .endef
-_primitive__rot_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $20, %esp
- call _dpeek
- movl %eax, -4(%ebp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -8(%ebp)
- leal -8(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -12(%ebp)
- movl -8(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- movl -12(%ebp), %eax
- movl %eax, 4(%esp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _put
- movl -4(%ebp), %eax
- movl %eax, 4(%esp)
- leal -8(%esi), %eax
- movl %eax, (%esp)
- call _put
- leave
- ret
-.globl _primitive_dupd
- .def _primitive_dupd; .scl 2; .type 32; .endef
-_primitive_dupd:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_dupd_impl
- leave
- ret
- .def _primitive_dupd_impl; .scl 3; .type 32; .endef
-_primitive_dupd_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- call _dpeek
- movl %eax, -4(%ebp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -8(%ebp)
- movl -8(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- movl -8(%ebp), %eax
- movl %eax, 4(%esp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _put
- movl -4(%ebp), %eax
- movl %eax, (%esp)
- call _dpush
- leave
- ret
-.globl _primitive_swapd
- .def _primitive_swapd; .scl 2; .type 32; .endef
-_primitive_swapd:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_swapd_impl
- leave
- ret
- .def _primitive_swapd_impl; .scl 3; .type 32; .endef
-_primitive_swapd_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $16, %esp
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -4(%ebp)
- leal -8(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -8(%ebp)
- movl -8(%ebp), %eax
- movl %eax, 4(%esp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _put
- movl -4(%ebp), %eax
- movl %eax, 4(%esp)
- leal -8(%esi), %eax
- movl %eax, (%esp)
- call _put
- leave
- ret
-.globl _primitive_nip
- .def _primitive_nip; .scl 2; .type 32; .endef
-_primitive_nip:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_nip_impl
- leave
- ret
- .def _primitive_nip_impl; .scl 3; .type 32; .endef
-_primitive_nip_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpop
- movl %eax, -4(%ebp)
- movl -4(%ebp), %eax
- movl %eax, (%esp)
- call _drepl
- leave
- ret
- .def _drepl; .scl 3; .type 32; .endef
-_drepl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl 8(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- leave
- ret
-.globl _primitive_2nip
- .def _primitive_2nip; .scl 2; .type 32; .endef
-_primitive_2nip:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_2nip_impl
- leave
- ret
- .def _primitive_2nip_impl; .scl 3; .type 32; .endef
-_primitive_2nip_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpeek
- movl %eax, -4(%ebp)
- subl $8, %esi
- movl -4(%ebp), %eax
- movl %eax, (%esp)
- call _drepl
- leave
- ret
-.globl _primitive_tuck
- .def _primitive_tuck; .scl 2; .type 32; .endef
-_primitive_tuck:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_tuck_impl
- leave
- ret
- .def _primitive_tuck_impl; .scl 3; .type 32; .endef
-_primitive_tuck_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- call _dpeek
- movl %eax, -4(%ebp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -8(%ebp)
- movl -8(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- movl -4(%ebp), %eax
- movl %eax, 4(%esp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _put
- movl -4(%ebp), %eax
- movl %eax, (%esp)
- call _dpush
- leave
- ret
-.globl _primitive_over
- .def _primitive_over; .scl 2; .type 32; .endef
-_primitive_over:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_over_impl
- leave
- ret
- .def _primitive_over_impl; .scl 3; .type 32; .endef
-_primitive_over_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, (%esp)
- call _dpush
- leave
- ret
-.globl _primitive_pick
- .def _primitive_pick; .scl 2; .type 32; .endef
-_primitive_pick:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_pick_impl
- leave
- ret
- .def _primitive_pick_impl; .scl 3; .type 32; .endef
-_primitive_pick_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- leal -8(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, (%esp)
- call _dpush
- leave
- ret
-.globl _primitive_swap
- .def _primitive_swap; .scl 2; .type 32; .endef
-_primitive_swap:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_swap_impl
- leave
- ret
- .def _primitive_swap_impl; .scl 3; .type 32; .endef
-_primitive_swap_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $16, %esp
- call _dpeek
- movl %eax, -4(%ebp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, -8(%ebp)
- movl -8(%ebp), %eax
- movl %eax, 4(%esp)
- movl %esi, (%esp)
- call _put
- movl -4(%ebp), %eax
- movl %eax, 4(%esp)
- leal -4(%esi), %eax
- movl %eax, (%esp)
- call _put
- leave
- ret
-.globl _primitive_to_r
- .def _primitive_to_r; .scl 2; .type 32; .endef
-_primitive_to_r:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_to_r_impl
- leave
- ret
- .def _primitive_to_r_impl; .scl 3; .type 32; .endef
-_primitive_to_r_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpop
- movl %eax, (%esp)
- call _rpush
- leave
- ret
- .def _rpush; .scl 3; .type 32; .endef
-_rpush:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- addl $4, %edi
- movl 8(%ebp), %eax
- movl %eax, 4(%esp)
- movl %edi, (%esp)
- call _put
- leave
- ret
-.globl _primitive_from_r
- .def _primitive_from_r; .scl 2; .type 32; .endef
-_primitive_from_r:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_from_r_impl
- leave
- ret
- .def _primitive_from_r_impl; .scl 3; .type 32; .endef
-_primitive_from_r_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _rpop
- movl %eax, (%esp)
- call _dpush
- leave
- ret
- .def _rpop; .scl 3; .type 32; .endef
-_rpop:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %edi, (%esp)
- call _get
- movl %eax, -4(%ebp)
- subl $4, %edi
- movl -4(%ebp), %eax
- leave
- ret
-.globl _stack_to_array
- .def _stack_to_array; .scl 2; .type 32; .endef
-_stack_to_array:
- pushl %ebp
- movl %esp, %ebp
- subl $40, %esp
- movl 8(%ebp), %edx
- movl 12(%ebp), %eax
- subl %edx, %eax
- addl $4, %eax
- movl %eax, -4(%ebp)
- cmpl $0, -4(%ebp)
- jns L58
- movl $0, -12(%ebp)
- jmp L57
-L58:
- movl -4(%ebp), %eax
- movl %eax, -16(%ebp)
- cmpl $0, -16(%ebp)
- jns L60
- addl $3, -16(%ebp)
-L60:
- movl -16(%ebp), %eax
- sarl $2, %eax
- movl %eax, 4(%esp)
- movl $8, (%esp)
- call _allot_array_internal
- movl %eax, -8(%ebp)
- movl -4(%ebp), %eax
- movl %eax, 8(%esp)
- movl 8(%ebp), %eax
- movl %eax, 4(%esp)
- movl -8(%ebp), %eax
- addl $8, %eax
- movl %eax, (%esp)
- call _memcpy
- movl -8(%ebp), %eax
- movl %eax, (%esp)
- call _tag_object
- movl %eax, (%esp)
- call _dpush
- movl $1, -12(%ebp)
-L57:
- movl -12(%ebp), %eax
- leave
- ret
- .def _tag_object; .scl 3; .type 32; .endef
-_tag_object:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- andl $-8, %eax
- orl $3, %eax
- popl %ebp
- ret
-.globl _primitive_datastack
- .def _primitive_datastack; .scl 2; .type 32; .endef
-_primitive_datastack:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_datastack_impl
- leave
- ret
- .def _primitive_datastack_impl; .scl 3; .type 32; .endef
-_primitive_datastack_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl %esi, 4(%esp)
- movl _stack_chain, %eax
- movl 24(%eax), %eax
- movl (%eax), %eax
- movl %eax, (%esp)
- call _stack_to_array
- testb %al, %al
- jne L63
- movl $0, 12(%esp)
- movl $7, 8(%esp)
- movl $7, 4(%esp)
- movl $11, (%esp)
- call _general_error
-L63:
- leave
- ret
-.globl _primitive_retainstack
- .def _primitive_retainstack; .scl 2; .type 32; .endef
-_primitive_retainstack:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_retainstack_impl
- leave
- ret
- .def _primitive_retainstack_impl; .scl 3; .type 32; .endef
-_primitive_retainstack_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl %edi, 4(%esp)
- movl _stack_chain, %eax
- movl 28(%eax), %eax
- movl (%eax), %eax
- movl %eax, (%esp)
- call _stack_to_array
- testb %al, %al
- jne L66
- movl $0, 12(%esp)
- movl $7, 8(%esp)
- movl $7, 4(%esp)
- movl $13, (%esp)
- call _general_error
-L66:
- leave
- ret
-.globl _array_to_stack
- .def _array_to_stack; .scl 2; .type 32; .endef
-_array_to_stack:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _array_capacity
- sall $2, %eax
- movl %eax, -4(%ebp)
- movl -4(%ebp), %eax
- movl %eax, 8(%esp)
- movl 8(%ebp), %eax
- addl $8, %eax
- movl %eax, 4(%esp)
- movl 12(%ebp), %eax
- movl %eax, (%esp)
- call _memcpy
- movl -4(%ebp), %eax
- addl 12(%ebp), %eax
- subl $4, %eax
- leave
- ret
- .def _array_capacity; .scl 3; .type 32; .endef
-_array_capacity:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- movl 4(%eax), %eax
- shrl $3, %eax
- popl %ebp
- ret
-.globl _primitive_set_datastack
- .def _primitive_set_datastack; .scl 2; .type 32; .endef
-_primitive_set_datastack:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_set_datastack_impl
- leave
- ret
- .def _primitive_set_datastack_impl; .scl 3; .type 32; .endef
-_primitive_set_datastack_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpop
- movl %eax, (%esp)
- call _untag_array
- movl %eax, %edx
- movl _stack_chain, %eax
- movl 24(%eax), %eax
- movl (%eax), %eax
- movl %eax, 4(%esp)
- movl %edx, (%esp)
- call _array_to_stack
- movl %eax, %esi
- leave
- ret
- .def _untag_array; .scl 3; .type 32; .endef
-_untag_array:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl 8(%ebp), %eax
- movl %eax, 4(%esp)
- movl $8, (%esp)
- call _type_check
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _untag_object
- leave
- ret
- .def _untag_object; .scl 3; .type 32; .endef
-_untag_object:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- andl $-8, %eax
- popl %ebp
- ret
- .def _type_check; .scl 3; .type 32; .endef
-_type_check:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl 12(%ebp), %eax
- movl %eax, (%esp)
- call _type_of
- cmpl 8(%ebp), %eax
- je L74
- movl 12(%ebp), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _type_error
-L74:
- leave
- ret
- .def _type_of; .scl 3; .type 32; .endef
-_type_of:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- movl 8(%ebp), %eax
- andl $7, %eax
- movl %eax, -4(%ebp)
- cmpl $3, -4(%ebp)
- jne L77
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _object_type
- movl %eax, -8(%ebp)
- jmp L76
-L77:
- movl -4(%ebp), %eax
- movl %eax, -8(%ebp)
-L76:
- movl -8(%ebp), %eax
- leave
- ret
- .def _object_type; .scl 3; .type 32; .endef
-_object_type:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl 8(%ebp), %eax
- andl $-8, %eax
- movl %eax, (%esp)
- call _get
- movl %eax, (%esp)
- call _untag_header
- leave
- ret
- .def _untag_header; .scl 3; .type 32; .endef
-_untag_header:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- shrl $3, %eax
- popl %ebp
- ret
-.globl _primitive_set_retainstack
- .def _primitive_set_retainstack; .scl 2; .type 32; .endef
-_primitive_set_retainstack:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_set_retainstack_impl
- leave
- ret
- .def _primitive_set_retainstack_impl; .scl 3; .type 32; .endef
-_primitive_set_retainstack_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpop
- movl %eax, (%esp)
- call _untag_array
- movl %eax, %edx
- movl _stack_chain, %eax
- movl 28(%eax), %eax
- movl (%eax), %eax
- movl %eax, 4(%esp)
- movl %edx, (%esp)
- call _array_to_stack
- movl %eax, %edi
- leave
- ret
-.globl _primitive_getenv
- .def _primitive_getenv; .scl 2; .type 32; .endef
-_primitive_getenv:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_getenv_impl
- leave
- ret
- .def _primitive_getenv_impl; .scl 3; .type 32; .endef
-_primitive_getenv_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpeek
- movl %eax, (%esp)
- call _untag_fixnum_fast
- movl %eax, -4(%ebp)
- movl -4(%ebp), %eax
- movl _userenv(,%eax,4), %eax
- movl %eax, (%esp)
- call _drepl
- leave
- ret
- .def _untag_fixnum_fast; .scl 3; .type 32; .endef
-_untag_fixnum_fast:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- sarl $3, %eax
- popl %ebp
- ret
-.globl _primitive_setenv
- .def _primitive_setenv; .scl 2; .type 32; .endef
-_primitive_setenv:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_setenv_impl
- leave
- ret
- .def _primitive_setenv_impl; .scl 3; .type 32; .endef
-_primitive_setenv_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- call _dpop
- movl %eax, (%esp)
- call _untag_fixnum_fast
- movl %eax, -4(%ebp)
- call _dpop
- movl %eax, -8(%ebp)
- movl -4(%ebp), %edx
- movl -8(%ebp), %eax
- movl %eax, _userenv(,%edx,4)
- leave
- ret
-.globl _primitive_exit
- .def _primitive_exit; .scl 2; .type 32; .endef
-_primitive_exit:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_exit_impl
- leave
- ret
- .def _primitive_exit_impl; .scl 3; .type 32; .endef
-_primitive_exit_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpop
- movl %eax, (%esp)
- call _to_fixnum
- movl %eax, (%esp)
- call _exit
-.globl _primitive_os_env
- .def _primitive_os_env; .scl 2; .type 32; .endef
-_primitive_os_env:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_os_env_impl
- leave
- ret
- .def _primitive_os_env_impl; .scl 3; .type 32; .endef
-_primitive_os_env_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- call _unbox_char_string
- movl %eax, -4(%ebp)
- movl -4(%ebp), %eax
- movl %eax, (%esp)
- call _getenv
- movl %eax, -8(%ebp)
- cmpl $0, -8(%ebp)
- jne L92
- movl $7, (%esp)
- call _dpush
- jmp L91
-L92:
- movl -8(%ebp), %eax
- movl %eax, (%esp)
- call _box_char_string
-L91:
- leave
- ret
-.globl _primitive_eq
- .def _primitive_eq; .scl 2; .type 32; .endef
-_primitive_eq:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_eq_impl
- leave
- ret
- .def _primitive_eq_impl; .scl 3; .type 32; .endef
-_primitive_eq_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- call _dpop
- movl %eax, -4(%ebp)
- call _dpeek
- movl %eax, -8(%ebp)
- movl -4(%ebp), %eax
- cmpl -8(%ebp), %eax
- jne L96
- movl _T, %eax
- movl %eax, -12(%ebp)
- jmp L97
-L96:
- movl $7, -12(%ebp)
-L97:
- movl -12(%ebp), %eax
- movl %eax, (%esp)
- call _drepl
- leave
- ret
-.globl _primitive_millis
- .def _primitive_millis; .scl 2; .type 32; .endef
-_primitive_millis:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_millis_impl
- leave
- ret
- .def _primitive_millis_impl; .scl 3; .type 32; .endef
-_primitive_millis_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _current_millis
- movl %eax, (%esp)
- movl %edx, 4(%esp)
- call _box_unsigned_8
- leave
- ret
-.globl _primitive_sleep
- .def _primitive_sleep; .scl 2; .type 32; .endef
-_primitive_sleep:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_sleep_impl
- leave
- ret
- .def _primitive_sleep_impl; .scl 3; .type 32; .endef
-_primitive_sleep_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpop
- movl %eax, (%esp)
- call _to_cell
- movl %eax, (%esp)
- call _sleep_millis
- leave
- ret
-.globl _primitive_tag
- .def _primitive_tag; .scl 2; .type 32; .endef
-_primitive_tag:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_tag_impl
- leave
- ret
- .def _primitive_tag_impl; .scl 3; .type 32; .endef
-_primitive_tag_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- call _dpeek
- andl $7, %eax
- movl %eax, (%esp)
- call _tag_fixnum
- movl %eax, (%esp)
- call _drepl
- leave
- ret
- .def _tag_fixnum; .scl 3; .type 32; .endef
-_tag_fixnum:
- pushl %ebp
- movl %esp, %ebp
- movl 8(%ebp), %eax
- sall $3, %eax
- andl $-8, %eax
- popl %ebp
- ret
-.globl _primitive_slot
- .def _primitive_slot; .scl 2; .type 32; .endef
-_primitive_slot:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_slot_impl
- leave
- ret
- .def _primitive_slot_impl; .scl 3; .type 32; .endef
-_primitive_slot_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- call _dpop
- movl %eax, (%esp)
- call _untag_fixnum_fast
- movl %eax, -4(%ebp)
- call _dpop
- movl %eax, -8(%ebp)
- movl -8(%ebp), %edx
- andl $-8, %edx
- movl -4(%ebp), %eax
- sall $2, %eax
- leal (%edx,%eax), %eax
- movl %eax, (%esp)
- call _get
- movl %eax, (%esp)
- call _dpush
- leave
- ret
-.globl _primitive_set_slot
- .def _primitive_set_slot; .scl 2; .type 32; .endef
-_primitive_set_slot:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl %eax, -4(%ebp)
- movl %edx, -8(%ebp)
- movl -8(%ebp), %eax
- call _save_callstack_top
- call _primitive_set_slot_impl
- leave
- ret
- .def _primitive_set_slot_impl; .scl 3; .type 32; .endef
-_primitive_set_slot_impl:
- pushl %ebp
- movl %esp, %ebp
- subl $24, %esp
- call _dpop
- movl %eax, (%esp)
- call _untag_fixnum_fast
- movl %eax, -4(%ebp)
- call _dpop
- movl %eax, -8(%ebp)
- call _dpop
- movl %eax, -12(%ebp)
- movl -12(%ebp), %eax
- movl %eax, 8(%esp)
- movl -4(%ebp), %eax
- movl %eax, 4(%esp)
- movl -8(%ebp), %eax
- movl %eax, (%esp)
- call _set_slot
- leave
- ret
- .def _set_slot; .scl 3; .type 32; .endef
-_set_slot:
- pushl %ebp
- movl %esp, %ebp
- subl $8, %esp
- movl 16(%ebp), %eax
- movl %eax, 4(%esp)
- movl 8(%ebp), %edx
- andl $-8, %edx
- movl 12(%ebp), %eax
- sall $2, %eax
- leal (%edx,%eax), %eax
- movl %eax, (%esp)
- call _put
- movl 8(%ebp), %eax
- movl %eax, (%esp)
- call _write_barrier
- leave
- ret
- .def _write_barrier; .scl 3; .type 32; .endef
-_write_barrier:
- pushl %ebp
- movl %esp, %ebp
- subl $4, %esp
- movl 8(%ebp), %eax
- shrl $6, %eax
- addl _cards_offset, %eax
- movl %eax, -4(%ebp)
- movl -4(%ebp), %edx
- movl -4(%ebp), %eax
- movzbl (%eax), %eax
- orb $-64, %al
- movb %al, (%edx)
- leave
- ret
- .comm _console_open, 16 # 1
- .comm _userenv, 256 # 256
- .comm _T, 16 # 4
- .comm _stack_chain, 16 # 4
- .comm _ds_size, 16 # 4
- .comm _rs_size, 16 # 4
- .comm _stage2, 16 # 1
- .comm _profiling_p, 16 # 1
- .comm _signal_number, 16 # 4
- .comm _signal_fault_addr, 16 # 4
- .comm _signal_callstack_top, 16 # 4
- .comm _secure_gc, 16 # 1
- .comm _data_heap, 16 # 4
- .comm _cards_offset, 16 # 4
- .comm _newspace, 16 # 4
- .comm _nursery, 16 # 4
- .comm _gc_time, 16 # 8
- .comm _nursery_collections, 16 # 4
- .comm _aging_collections, 16 # 4
- .comm _cards_scanned, 16 # 4
- .comm _performing_gc, 16 # 1
- .comm _collecting_gen, 16 # 4
- .comm _collecting_aging_again, 16 # 1
- .comm _last_code_heap_scan, 16 # 4
- .comm _growing_data_heap, 16 # 1
- .comm _old_data_heap, 16 # 4
- .comm _gc_jmp, 208 # 208
- .comm _heap_scan_ptr, 16 # 4
- .comm _gc_off, 16 # 1
- .comm _gc_locals_region, 16 # 4
- .comm _gc_locals, 16 # 4
- .comm _extra_roots_region, 16 # 4
- .comm _extra_roots, 16 # 4
- .comm _bignum_zero, 16 # 4
- .comm _bignum_pos_one, 16 # 4
- .comm _bignum_neg_one, 16 # 4
- .comm _code_heap, 16 # 8
- .comm _data_relocation_base, 16 # 4
- .comm _code_relocation_base, 16 # 4
- .comm _posix_argc, 16 # 4
- .comm _posix_argv, 16 # 4
- .def _sleep_millis; .scl 3; .type 32; .endef
- .def _current_millis; .scl 3; .type 32; .endef
- .def _getenv; .scl 3; .type 32; .endef
- .def _exit; .scl 3; .type 32; .endef
- .def _general_error; .scl 3; .type 32; .endef
- .def _memcpy; .scl 3; .type 32; .endef
- .def _allot_array_internal; .scl 3; .type 32; .endef
- .def _save_callstack_top; .scl 3; .type 32; .endef
- .def _free; .scl 3; .type 32; .endef
- .def _dealloc_segment; .scl 3; .type 32; .endef
- .def _alloc_segment; .scl 3; .type 32; .endef
- .def _safe_malloc; .scl 3; .type 32; .endef
- .def _type_error; .scl 3; .type 32; .endef
- .section .drectve
-
- .ascii " -export:nursery,data"
- .ascii " -export:cards_offset,data"
- .ascii " -export:stack_chain,data"
- .ascii " -export:userenv,data"
- .ascii " -export:unnest_stacks"
- .ascii " -export:nest_stacks"
- .ascii " -export:save_stacks"
From 2ee0ab27d123e8af64f47c5f3688b3d358a1bb0d Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 7 Apr 2008 18:30:45 -0500
Subject: [PATCH 231/288] builder: Up bootstrap timeout to 4 hours
---
extra/builder/builder.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 8e9565f82a..0e3a794e24 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -106,7 +106,7 @@ IN: builder
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
- 120 minutes >>timeout ;
+ 240 minutes >>timeout ;
: do-builder-test ( -- )
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
From 56ff4530ff9b34fcc15050fd8af66b71e751b572 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 7 Apr 2008 19:28:54 -0500
Subject: [PATCH 232/288] fix blum-blum-shub
---
.../blum-blum-shub-tests.factor | 28 +++++++++++++++++++
.../blum-blum-shub/blum-blum-shub.factor | 24 ++++++----------
2 files changed, 36 insertions(+), 16 deletions(-)
create mode 100644 extra/random/blum-blum-shub/blum-blum-shub-tests.factor
diff --git a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor
new file mode 100644
index 0000000000..a92f256eeb
--- /dev/null
+++ b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor
@@ -0,0 +1,28 @@
+USING: kernel math tools.test namespaces random
+random.blum-blum-shub ;
+IN: blum-blum-shub.tests
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } random-32*
+] unit-test
+
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } [
+ 32 random-bits
+ ] with-random
+] unit-test
+
+[ 5726770047455156646 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } [
+ 64 random-bits
+ ] with-random
+] unit-test
+
+[ 3716213681 ]
+[
+ 100 T{ blum-blum-shub f 200352954495 846054538649 } tuck [
+ random-32* drop
+ ] curry times
+ random-32*
+] unit-test
diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor
index 017ef402c0..5644cf6d08 100755
--- a/extra/random/blum-blum-shub/blum-blum-shub.factor
+++ b/extra/random/blum-blum-shub/blum-blum-shub.factor
@@ -3,34 +3,26 @@ math.miller-rabin combinators.lib
math.functions accessors random ;
IN: random.blum-blum-shub
-! TODO: take (log log M) bits instead of 1 bit
-! Blum Blum Shub, M = pq
+! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
+! return low bit of x+1
TUPLE: blum-blum-shub x n ;
-C: <blum-blum-shub> blum-blum-shub
+<PRIVATE
: generate-bbs-primes ( numbits -- p q )
- #! two primes congruent to 3 (mod 4)
[ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
-IN: crypto
: <blum-blum-shub> ( numbits -- blum-blum-shub )
- #! returns a Blum-Blum-Shub tuple
generate-bbs-primes *
[ find-relative-prime ] keep
blum-blum-shub construct-boa ;
-! 256 make-bbs blum-blum-shub set-global
-
: next-bbs-bit ( bbs -- bit )
- #! x = x^2 mod n, return low bit of calculated x
- [ [ x>> 2 ] [ n>> ] bi ^mod ]
- [ [ >>x ] keep x>> 1 bitand ] bi ;
+ [ [ x>> 2 ] [ n>> ] bi ^mod ] keep
+ over >>x drop 1 bitand ;
-IN: crypto
-! : random ( n -- n )
- ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256
- ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
+PRIVATE>
M: blum-blum-shub random-32* ( bbs -- r )
- ;
+ 0 32 rot
+ [ next-bbs-bit swap 1 shift bitor ] curry times ;
From f0ae86b884efe75ab55d3f6e8524a019bafd80ac Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 7 Apr 2008 19:30:02 -0500
Subject: [PATCH 233/288] remove outdated file
---
extra/crypto/test/blum-blum-shub.factor | 5 -----
1 file changed, 5 deletions(-)
delete mode 100644 extra/crypto/test/blum-blum-shub.factor
diff --git a/extra/crypto/test/blum-blum-shub.factor b/extra/crypto/test/blum-blum-shub.factor
deleted file mode 100644
index b1b6034373..0000000000
--- a/extra/crypto/test/blum-blum-shub.factor
+++ /dev/null
@@ -1,5 +0,0 @@
-USING: kernel math test namespaces crypto crypto-internals ;
-
-[ 6 ] [ 5 T{ bbs f 590695557939 811977232793 } random-bbs-bits* ] unit-test
-[ 792723710536787233474130382522 ] [ 100 T{ bbs f 200352954495 846054538649 } [ random-bbs-bits* drop ] 2keep random-bbs-bits* ] unit-test
-
From f7f7972756d6de6b4fab6d687092eefea214e319 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 20:07:03 -0500
Subject: [PATCH 234/288] Sequence equality on slices and reversals
---
core/combinators/combinators.factor | 4 ++++
core/sequences/sequences-tests.factor | 20 +++++++++++++++++-
core/sequences/sequences.factor | 30 +++++++++++++++++----------
3 files changed, 42 insertions(+), 12 deletions(-)
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 139c6d8fdf..96c4009ba9 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -59,6 +59,10 @@ ERROR: no-case ;
M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ;
+M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
M: hashtable hashcode*
[
dup assoc-size 1 number=
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index 3a30824084..281b27d540 100755
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -1,6 +1,6 @@
USING: arrays kernel math namespaces sequences kernel.private
sequences.private strings sbufs tools.test vectors bit-arrays
-generic ;
+generic vocabs.loader ;
IN: sequences.tests
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
@@ -100,6 +100,16 @@ unit-test
[ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test
+[ "blah" ] [ "blahxx" 2 head* ] unit-test
+
+[ "xx" ] [ "blahxx" 2 tail* ] unit-test
+
+[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] bi@ = ] unit-test
+
+[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] bi@ = ] unit-test
+
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
@@ -195,6 +205,12 @@ unit-test
! Pathological case
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
+
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
+
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> [ hashcode ] bi@ = ] unit-test
+
[ -10 "hi" "bye" copy ] must-fail
[ 10 "hi" "bye" copy ] must-fail
@@ -244,3 +260,5 @@ unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
+! Hardcore
+[ ] [ "sequences" reload ] unit-test
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 01a1cb9b6a..996aba8e6e 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -172,7 +172,9 @@ TUPLE: reversed seq ;
C: <reversed> reversed
M: reversed virtual-seq reversed-seq ;
+
M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
+
M: reversed length reversed-seq length ;
INSTANCE: reversed virtual-sequence
@@ -198,7 +200,9 @@ ERROR: slice-error reason ;
slice construct-boa ; inline
M: slice virtual-seq slice-seq ;
+
M: slice virtual@ [ slice-from + ] keep slice-seq ;
+
M: slice length dup slice-to swap slice-from - ;
: head-slice ( seq n -- slice ) (head) <slice> ;
@@ -466,6 +470,21 @@ M: sequence <=>
2dup [ length ] bi@ number=
[ mismatch not ] [ 2drop f ] if ; inline
+: sequence-hashcode-step ( oldhash newpart -- newhash )
+ swap [
+ dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
+ fixnum+fast fixnum+fast
+ ] keep fixnum-bitxor ; inline
+
+: sequence-hashcode ( n seq -- x )
+ 0 -rot [
+ hashcode* >fixnum sequence-hashcode-step
+ ] with each ; inline
+
+M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
+
+M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
+
: move ( to from seq -- )
2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
@@ -692,14 +711,3 @@ PRIVATE>
dup [ length ] map infimum
[ <column> dup like ] with map
] unless ;
-
-: sequence-hashcode-step ( oldhash newpart -- newhash )
- swap [
- dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
- fixnum+fast fixnum+fast
- ] keep fixnum-bitxor ; inline
-
-: sequence-hashcode ( n seq -- x )
- 0 -rot [
- hashcode* >fixnum sequence-hashcode-step
- ] with each ; inline
From e4f5448ae1508d979e74db1328643dbea0b7caee Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 20:07:12 -0500
Subject: [PATCH 235/288] Documentation
---
core/parser/parser-docs.factor | 10 ++++++++++
1 file changed, 10 insertions(+)
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index d11f036445..e7984f7ec3 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -153,6 +153,8 @@ ARTICLE: "parser-files" "Parsing source files"
{ $subsection parse-file }
{ $subsection bootstrap-file }
"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
+$nl
+"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "."
{ $see-also "source-files" } ;
ARTICLE: "parser-usage" "Reflective parser usage"
@@ -161,6 +163,13 @@ ARTICLE: "parser-usage" "Reflective parser usage"
"The parser can also parse from a stream:"
{ $subsection parse-stream } ;
+ARTICLE: "top-level-forms" "Top level forms"
+"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file."
+$nl
+"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word."
+$nl
+"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
+
ARTICLE: "parser" "The parser"
"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
$nl
@@ -168,6 +177,7 @@ $nl
{ $subsection "vocabulary-search" }
{ $subsection "parser-files" }
{ $subsection "parser-usage" }
+{ $subsection "top-level-forms" }
"The parser can be extended."
{ $subsection "parsing-words" }
{ $subsection "parser-lexer" }
From 600740d68bfc5977ab459a3555e1f9154dac5341 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 20:07:30 -0500
Subject: [PATCH 236/288] Tweaks
---
core/compiler/compiler.factor | 8 ++++----
core/optimizer/optimizer-tests.factor | 3 +++
2 files changed, 7 insertions(+), 4 deletions(-)
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index a0599f79a1..6f75ca873d 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io inference.backend
-inference.state generator debugger math.parser prettyprint words
-compiler.units continuations vocabs assocs alien.compiler dlists
-optimizer definitions math compiler.errors threads graphs
-generic inference ;
+inference.state generator debugger words compiler.units
+continuations vocabs assocs alien.compiler dlists optimizer
+definitions math compiler.errors threads graphs generic
+inference ;
IN: compiler
: ripple-up ( word -- )
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index 6c6adfa3e6..c8d7a0a0a0 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -370,4 +370,7 @@ HINTS: recursive-inline-hang-2 array ;
HINTS: recursive-inline-hang-3 array ;
+! Regression
+USE: sequences.private
+[ ] [ { (3append) } compile ] unit-test
From 4c08b7dc81448fbfafdc71f33a7156d1394844ed Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 7 Apr 2008 20:19:49 -0500
Subject: [PATCH 237/288] Add zip word, better code-room primitive
---
core/assocs/assocs.factor | 5 ++-
core/cpu/ppc/architecture/architecture.factor | 4 +--
core/generator/registers/registers.factor | 4 +--
core/inference/known-words/known-words.factor | 2 +-
core/mirrors/mirrors.factor | 2 +-
vm/code_gc.c | 33 ++++++++++++++-----
vm/code_gc.h | 2 +-
vm/code_heap.c | 9 +++++
8 files changed, 45 insertions(+), 16 deletions(-)
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 6b6bd3d51a..adb69d317c 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
+: zip ( keys values -- alist )
+ 2array flip ; inline
+
: search-alist ( key alist -- pair i )
[ first = ] with find swap ; inline
@@ -204,7 +207,7 @@ M: enum set-at seq>> set-nth ;
M: enum delete-at enum-seq delete-nth ;
M: enum >alist ( enum -- alist )
- seq>> [ length ] keep 2array flip ;
+ seq>> [ length ] keep zip ;
M: enum assoc-size seq>> length ;
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index bd5273efcb..09ffead029 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -146,7 +146,7 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
-GENERIC: STF ( src dst reg-class -- )
+GENERIC: STF ( src dst off reg-class -- )
M: single-float-regs STF drop STFS ;
@@ -154,7 +154,7 @@ M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
-GENERIC: LF ( src dst reg-class -- )
+GENERIC: LF ( dst src off reg-class -- )
M: single-float-regs LF drop LFS ;
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index b5b3f0b2c0..f3dc0fb10e 100755
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -322,7 +322,7 @@ M: phantom-retainstack finalize-height
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
- [ phantom-locs* ] [ stack>> ] bi 2array flip
+ [ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-subset
values ;
@@ -421,7 +421,7 @@ M: loc lazy-store
: slow-shuffle-mapping ( locs tmp -- pairs )
>r dup length r>
- [ swap - <ds-loc> ] curry map 2array flip ;
+ [ swap - <ds-loc> ] curry map zip ;
: slow-shuffle ( locs -- )
#! We don't have enough free registers to load all shuffle
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 8f505c21a1..33a5da87f4 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -373,7 +373,7 @@ set-primitive-effect
\ data-room { } { integer array } <effect> set-primitive-effect
\ data-room make-flushable
-\ code-room { } { integer integer } <effect> set-primitive-effect
+\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
\ code-room make-flushable
\ os-env { string } { object } <effect> set-primitive-effect
diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor
index a13e1331fa..61cdbdad24 100755
--- a/core/mirrors/mirrors.factor
+++ b/core/mirrors/mirrors.factor
@@ -42,7 +42,7 @@ M: mirror delete-at ( key mirror -- )
M: mirror >alist ( mirror -- alist )
>mirror<
[ [ slot-spec-offset slot ] with map ] keep
- [ slot-spec-name ] map swap 2array flip ;
+ [ slot-spec-name ] map swap zip ;
M: mirror assoc-size mirror-slots length ;
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 93eb49c1be..141f4abbfe 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -198,20 +198,33 @@ void free_unmarked(F_HEAP *heap)
build_free_list(heap,heap->segment->size);
}
-/* Compute total sum of sizes of free blocks */
-CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status)
+/* Compute total sum of sizes of free blocks, and size of largest free block */
+void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
{
- CELL size = 0;
+ *used = 0;
+ *total_free = 0;
+ *max_free = 0;
+
F_BLOCK *scan = first_block(heap);
while(scan)
{
- if(scan->status == status)
- size += scan->size;
+ switch(scan->status)
+ {
+ case B_ALLOCATED:
+ *used += scan->size;
+ break;
+ case B_FREE:
+ *total_free += scan->size;
+ if(scan->size > *max_free)
+ *max_free = scan->size;
+ break;
+ default:
+ critical_error("Invalid scan->status",(CELL)scan);
+ }
+
scan = next_block(heap,scan);
}
-
- return size;
}
/* The size of the heap, not including the last block if it's free */
@@ -283,8 +296,12 @@ void recursive_mark(F_BLOCK *block)
/* Push the free space and total size of the code heap */
DEFINE_PRIMITIVE(code_room)
{
- dpush(tag_fixnum(heap_usage(&code_heap,B_FREE) / 1024));
+ CELL used, total_free, max_free;
+ heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
+ dpush(tag_fixnum(used / 1024));
+ dpush(tag_fixnum(total_free / 1024));
+ dpush(tag_fixnum(max_free / 1024));
}
/* Dump all code blocks for debugging */
diff --git a/vm/code_gc.h b/vm/code_gc.h
index 32f304c16c..658dc990ae 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -32,7 +32,7 @@ void build_free_list(F_HEAP *heap, CELL size);
CELL heap_allot(F_HEAP *heap, CELL size);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
-CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status);
+void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
diff --git a/vm/code_heap.c b/vm/code_heap.c
index ec63441bcb..92915e49d1 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -229,7 +229,16 @@ CELL allot_code_block(CELL size)
/* Insufficient room even after code GC, give up */
if(start == 0)
+ {
+ CELL used, total_free, max_free;
+ heap_usage(&code_heap,&used,&total_free,&max_free);
+
+ fprintf(stderr,"Code heap stats:\n");
+ fprintf(stderr,"Used: %ld\n",used);
+ fprintf(stderr,"Total free space: %ld\n",total_free);
+ fprintf(stderr,"Largest free block: %ld\n",max_free);
fatal_error("Out of memory in add-compiled-block",0);
+ }
}
return start;
From 0f4ac3a8dc1448af61b7110b9830d3b43c2925c4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 20:44:43 -0500
Subject: [PATCH 238/288] Slot shadow warnings
---
core/classes/tuple/tuple-tests.factor | 9 +++++++++
core/classes/tuple/tuple.factor | 6 +++---
core/parser/parser.factor | 29 +++++++++++++++++++--------
3 files changed, 33 insertions(+), 11 deletions(-)
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 729997d3b2..2575570d2f 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -529,3 +529,12 @@ TUPLE: another-forget-accessors-test ;
] unit-test
[ t ] [ \ another-forget-accessors-test class? ] unit-test
+
+! Shadowing test
+[ f ] [
+ t parser-notes? [
+ [
+ "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
+ ] with-string-writer empty?
+ ] with-variable
+] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 608fb8cf6c..aa8ef6cdb7 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -55,6 +55,9 @@ PRIVATE>
"slot-names" word-prop
[ dup array? [ second ] when ] map ;
+: all-slot-names ( class -- slots )
+ superclasses [ slot-names ] map concat \ class prefix ;
+
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
@@ -119,9 +122,6 @@ PRIVATE>
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: all-slot-names ( class -- slots )
- superclasses [ slot-names ] map concat \ class prefix ;
-
: compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 6d091fd1c0..6c09e08f84 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -1,12 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic assocs kernel math
-namespaces prettyprint sequences strings vectors words
-quotations inspector io.styles io combinators sorting
-splitting math.parser effects continuations debugger
-io.files io.streams.string vocabs io.encodings.utf8
-source-files classes hashtables compiler.errors compiler.units
-accessors ;
+USING: arrays definitions generic assocs kernel math namespaces
+prettyprint sequences strings vectors words quotations inspector
+io.styles io combinators sorting splitting math.parser effects
+continuations debugger io.files io.streams.string vocabs
+io.encodings.utf8 source-files classes classes.tuple hashtables
+compiler.errors compiler.units accessors ;
IN: parser
TUPLE: lexer text line line-text line-length column ;
@@ -285,13 +284,27 @@ M: no-word-error summary
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
+: shadowed-slots ( superclass slots -- shadowed )
+ >r all-slot-names r> seq-intersect ;
+
+: check-slot-shadowing ( class superclass slots -- )
+ shadowed-slots [
+ [
+ "Definition of slot ``" %
+ %
+ "'' in class ``" %
+ word-name %
+ "'' shadows a superclass slot" %
+ ] "" make note.
+ ] with each ;
+
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] }
[ >r tuple ";" parse-tokens r> prefix ]
- } case ;
+ } case 3dup check-slot-shadowing ;
ERROR: staging-violation word ;
From a48120c80b2886c56adc4b52ee092a020e78de1d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 7 Apr 2008 21:04:51 -0500
Subject: [PATCH 239/288] Improve memory tooL
---
extra/tools/memory/memory-tests.factor | 4 ++
extra/tools/memory/memory.factor | 58 ++++++++++++++++++--------
2 files changed, 44 insertions(+), 18 deletions(-)
diff --git a/extra/tools/memory/memory-tests.factor b/extra/tools/memory/memory-tests.factor
index 9efbf63f7f..60b54c2a0d 100644
--- a/extra/tools/memory/memory-tests.factor
+++ b/extra/tools/memory/memory-tests.factor
@@ -1,4 +1,8 @@
USING: tools.test tools.memory ;
IN: tools.memory.tests
+\ room. must-infer
+[ ] [ room. ] unit-test
+
+\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test
diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor
index 2077ea497e..b8fdcab280 100644
--- a/extra/tools/memory/memory.factor
+++ b/extra/tools/memory/memory.factor
@@ -1,22 +1,29 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences vectors arrays generic assocs io math
namespaces parser prettyprint strings io.styles vectors words
-system sorting splitting math.parser classes memory ;
+system sorting splitting math.parser classes memory combinators ;
IN: tools.memory
+<PRIVATE
+
+: write-size ( n -- )
+ number>string
+ dup length 4 > [ 3 cut* "," swap 3append ] when
+ " KB" append write-cell ;
+
: write-total/used/free ( free total str -- )
[
write-cell
- dup number>string write-cell
- over - number>string write-cell
- number>string write-cell
+ dup write-size
+ over - write-size
+ write-size
] with-row ;
: write-total ( n str -- )
[
write-cell
- number>string write-cell
+ write-size
[ ] with-cell
[ ] with-cell
] with-row ;
@@ -25,26 +32,41 @@ IN: tools.memory
[ [ write-cell ] each ] with-row ;
: (data-room.) ( -- )
- data-room 2 <groups> 0 [
- "Generation " pick number>string append
- >r first2 r> write-total/used/free 1+
- ] reduce drop
+ data-room 2 <groups> dup length [
+ [ first2 ] [ number>string "Generation " prepend ] bi*
+ write-total/used/free
+ ] 2each
"Cards" write-total ;
-: (code-room.) ( -- )
- code-room "Code space" write-total/used/free ;
+: write-labelled-size ( n string -- )
+ [ write-cell write-size ] with-row ;
-: room. ( -- )
- standard-table-style [
- { "" "Total" "Used" "Free" } write-headings
- (data-room.)
- (code-room.)
- ] tabular-output ;
+: (code-room.) ( -- )
+ code-room {
+ [ "Size:" write-labelled-size ]
+ [ "Used:" write-labelled-size ]
+ [ "Total free space:" write-labelled-size ]
+ [ "Largest free block:" write-labelled-size ]
+ } spread ;
: heap-stat-step ( counts sizes obj -- )
[ dup size swap class rot at+ ] keep
1 swap class rot at+ ;
+PRIVATE>
+
+: room. ( -- )
+ "==== DATA HEAP" print
+ standard-table-style [
+ { "" "Total" "Used" "Free" } write-headings
+ (data-room.)
+ ] tabular-output
+ nl
+ "==== CODE HEAP" print
+ standard-table-style [
+ (code-room.)
+ ] tabular-output ;
+
: heap-stats ( -- counts sizes )
H{ } clone H{ } clone
[ >r 2dup r> heap-stat-step ] each-object ;
From b6befe6100a692d3a24b34645d005d5a0e61e173 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 7 Apr 2008 21:05:00 -0500
Subject: [PATCH 240/288] Remove redundant word
---
extra/assocs/lib/lib.factor | 3 ---
1 file changed, 3 deletions(-)
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index b23ee1f830..92fb9aac81 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -37,9 +37,6 @@ IN: assocs.lib
: insert ( value variable -- ) namespace insert-at ;
-: 2seq>assoc ( keys values exemplar -- assoc )
- >r 2array flip r> assoc-like ;
-
: generate-key ( assoc -- str )
>r 256 random-bits >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
From 9d8062aa46f6dac5161675d7db3f4ac3fb369452 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 22:16:51 -0500
Subject: [PATCH 241/288] Remove *.lib from using
---
extra/peg/peg.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index ee9037ff25..3b1d408ae2 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle
- vectors arrays combinators.lib math.parser
- unicode.categories sequences.lib compiler.units parser
+ vectors arrays math.parser
+ unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
IN: peg
From 8df3751049fe170114b3ced8593af74e267f1d49 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 7 Apr 2008 22:32:46 -0500
Subject: [PATCH 242/288] Load fix
---
extra/sequences/lib/lib.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 945ba1a3b7..2e74708aa9 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -4,7 +4,7 @@
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
arrays math.parser math.private sorting strings ascii macros
-assocs.lib quotations ;
+assocs.lib quotations hashtables ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
@@ -221,7 +221,7 @@ PRIVATE>
[ swap nth ] with map ;
: replace ( str oldseq newseq -- str' )
- H{ } 2seq>assoc substitute ;
+ zip >hashtable substitute ;
: remove-nth ( seq n -- seq' )
cut-slice 1 tail-slice append ;
From 042b5ece238cec0b67de7d441ef22c1b4ca181e7 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 8 Apr 2008 02:24:41 -0500
Subject: [PATCH 243/288] Add a few words to newfx
---
extra/newfx/newfx.factor | 13 ++++++++++---
1 file changed, 10 insertions(+), 3 deletions(-)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index df826dc295..b123fef2a3 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -1,7 +1,8 @@
-USING: kernel sequences assocs qualified ;
+USING: kernel sequences assocs qualified circular ;
QUALIFIED: sequences
+QUALIFIED: circular
IN: newfx
@@ -53,8 +54,10 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: push ( seq obj -- seq ) over sequences:push ;
-: push-on ( obj seq -- seq ) tuck sequences:push ;
+: push ( seq obj -- seq ) over sequences:push ;
+: push-on ( obj seq -- seq ) tuck sequences:push ;
+: pushed ( seq obj -- ) swap sequences:push ;
+: pushed-on ( obj seq -- ) sequences:push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -91,6 +94,10 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: push-circular ( seq elt -- seq ) over circular:push-circular ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
From 9430478503d8fc302371c872501b9cf630356bb2 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 8 Apr 2008 02:25:14 -0500
Subject: [PATCH 244/288] sequences.lib: Add each-percent
---
extra/sequences/lib/lib.factor | 10 ++++++++++
1 file changed, 10 insertions(+)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 945ba1a3b7..ac50d3f6c6 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -37,6 +37,16 @@ MACRO: firstn ( n -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: each-percent ( seq quot -- )
+ >r
+ dup length
+ dup [ / ] curry
+ [ 1+ ] swap compose
+ r> compose
+ 2each ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: sigma ( seq quot -- n )
[ rot slip + ] curry 0 swap reduce ; inline
From e67978b759bf3403e0cb6487418137f7051c7206 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 8 Apr 2008 02:26:02 -0500
Subject: [PATCH 245/288] processing: Move some items from the bubble-chamber
demo
---
extra/processing/processing.factor | 14 +++++++++++++-
1 file changed, 13 insertions(+), 1 deletion(-)
diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor
index acad02363b..02a8325663 100644
--- a/extra/processing/processing.factor
+++ b/extra/processing/processing.factor
@@ -1,6 +1,6 @@
USING: kernel namespaces threads combinators sequences arrays
- math math.functions
+ math math.functions math.ranges random
opengl.gl opengl.glu vars multi-methods shuffle
ui
ui.gestures
@@ -16,6 +16,18 @@ IN: processing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
+
+: 1random ( b -- num ) 0 swap 2random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chance ( fraction -- ? ) 0 1 2random > ;
+
+: percent-chance ( percent -- ? ) 100 / chance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
VAR: fill-color
VAR: stroke-color
From 469470347b6f3692544c0ecb53c483a96708a230 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 8 Apr 2008 02:27:43 -0500
Subject: [PATCH 246/288] bubble-chamber: use inheritance for the particles
---
.../bubble-chamber/bubble-chamber.factor | 92 ++++++++-----------
1 file changed, 38 insertions(+), 54 deletions(-)
diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
index c6e000e74f..5d128d5102 100644
--- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
+++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
@@ -25,12 +25,6 @@ IN: processing.gallery.bubble-chamber
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
-
-: 1random ( b -- num ) 0 swap 2random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -103,23 +97,34 @@ VARS: particles muons quarks hadrons axions ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: initialize-particle ( particle -- particle )
+
+ 0 0 {2} >>pos
+ 0 0 {2} >>vel
+
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ 0 0 0 1 <rgba> >>myc
+ 0 0 0 1 <rgba> >>mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
GENERIC: collide ( particle -- )
GENERIC: move ( particle -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ;
+TUPLE: muon < particle ;
-: <muon> ( -- muon )
- muon construct-empty
- 0 0 2array >>pos
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd
- 0 0 0 1 <rgba> >>myc
- 0 0 0 1 <rgba> >>mya ;
+: <muon> ( -- muon ) muon construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -177,18 +182,9 @@ METHOD: move { muon }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: quark pos vel speed theta speed-d theta-d theta-dd myc ;
+TUPLE: quark < particle ;
-: <quark> ( -- quark )
- quark construct-empty
- 0 0 2array >>pos
- 0 0 2array >>vel
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd
- 0 0 0 1 <rgba> >>myc ;
+: <quark> ( -- quark ) quark construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -228,7 +224,8 @@ METHOD: move { quark }
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
- 1000 random 997 >
+ ! 1000 random 997 >
+ 3/1000 chance
[
dup speed>> neg >>speed
2 over speed-d>> - >>speed-d
@@ -242,18 +239,9 @@ METHOD: move { quark }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: hadron pos vel speed theta speed-d theta-d theta-dd myc ;
+TUPLE: hadron < particle ;
-: <hadron> ( -- hadron )
- hadron construct-empty
- 0 0 2array >>pos
- 0 0 2array >>vel
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd
- 0 0 0 1 <rgba> >>myc ;
+: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -296,12 +284,14 @@ METHOD: move { hadron }
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
- 1000 random 997 >
+ ! 1000 random 997 >
+ 3/1000 chance
[
1.0 >>speed-d
0.00001 >>theta-dd
- 100 random 70 >
+ ! 100 random 70 >
+ 30/100 chance
[
dim 2 / dup 2array >>pos
dup collide
@@ -317,17 +307,9 @@ METHOD: move { hadron }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: axion pos vel speed theta speed-d theta-d theta-dd ;
+TUPLE: axion < particle ;
-: <axion> ( -- axion )
- axion construct-empty
- 0 0 2array >>pos
- 0 0 2array >>vel
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd ;
+: <axion> ( -- axion ) axion construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -381,12 +363,14 @@ METHOD: move { axion }
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
- 1000 random 996 >
+ ! 1000 random 996 >
+ 4/1000 chance
[
dup speed>> neg >>speed
dup speed-d>> neg 2 + >>speed-d
- 100 random 30 >
+ ! 100 random 30 >
+ 70/100 chance
[
dim 2 / dup 2array >>pos
collide
From 71d1848a89c46d3e23cf23bc851cb7e3e8244cb3 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 8 Apr 2008 02:28:25 -0500
Subject: [PATCH 247/288] trails: Factor out some items
---
extra/processing/gallery/trails/trails.factor | 19 ++-----------------
1 file changed, 2 insertions(+), 17 deletions(-)
diff --git a/extra/processing/gallery/trails/trails.factor b/extra/processing/gallery/trails/trails.factor
index f0a8889fbf..dc191bc439 100644
--- a/extra/processing/gallery/trails/trails.factor
+++ b/extra/processing/gallery/trails/trails.factor
@@ -1,5 +1,6 @@
-USING: kernel arrays sequences math qualified circular processing ui ;
+USING: kernel arrays sequences math qualified
+ sequences.lib circular processing ui newfx ;
IN: processing.gallery.trails
@@ -9,22 +10,6 @@ IN: processing.gallery.trails
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-QUALIFIED: circular
-
-: push-circular ( seq elt -- seq ) over circular:push-circular ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: each-percent ( seq quot -- )
- >r
- dup length
- dup [ / ] curry
- [ 1+ ] swap compose
- r> compose
- 2each ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From f71d174f38e5e1f9d4d7caac5c51917be42d6b20 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 8 Apr 2008 02:28:46 -0500
Subject: [PATCH 248/288] Add documentation for bubble-chamber
---
.../bubble-chamber/bubble-chamber-docs.factor | 97 +++++++++++++++++++
1 file changed, 97 insertions(+)
create mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor
diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor
new file mode 100644
index 0000000000..21a845e089
--- /dev/null
+++ b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor
@@ -0,0 +1,97 @@
+
+USING: help.syntax help.markup ;
+
+IN: processing.gallery.bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: muon
+
+ { $class-description
+ "The muon is a colorful particle with an entangled friend."
+ "It draws both itself and its horizontally symmetric partner."
+ "A high range of speed and almost no speed decay allow the"
+ "muon to reach the extents of the window, often forming rings"
+ "where theta has decayed but speed remains stable. The result"
+ "is color almost everywhere in the general direction of collision,"
+ "stabilized into fuzzy rings." } ;
+
+HELP: quark
+
+ { $class-description
+ "The quark draws as a translucent black. Their large numbers"
+ "create fields of blackness overwritten only by the glowing shadows of "
+ "Hadrons. "
+ "quarks are allowed to accelerate away with speed decay values above 1.0. "
+ "Each quark has an entangled friend. Both particles are drawn identically,"
+ "mirrored along the y-axis." } ;
+
+HELP: hadron
+
+ { $class-description
+ "Hadrons collide from totally random directions. "
+ "Those hadrons that do not exit the drawing area, "
+ "tend to stabilize into perfect circular orbits. "
+ "Each hadron draws with a slight glowing emboss. "
+ "The hadron itself is not drawn." } ;
+
+HELP: axion
+
+ { $class-description
+ "The axion particle draws a bold black path. Axions exist "
+ "in a slightly higher dimension and as such are drawn with "
+ "elevated embossed shadows. Axions are quick to stabilize "
+ "and fall into single pixel orbits axions automatically "
+ "recollide themselves after stabilizing." } ;
+
+{ muon quark hadron axion } related-words
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber" "Bubble Chamber"
+
+ { $subsection "bubble-chamber-introduction" }
+ { $subsection "bubble-chamber-particles" }
+ { $subsection "bubble-chamber-author" }
+ { $subsection "bubble-chamber-running" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-introduction" "Introduction"
+
+"The Bubble Chamber is a generative painting system of imaginary "
+"colliding particles. A single super-massive collision produces a "
+"discrete universe of four particle types. Particles draw their "
+"positions over time as pixel exposures. " ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-particles" "Particles"
+
+"Four types of particles exist. The behavior and graphic appearance of "
+"each particle type is unique."
+
+ { $subsection muon }
+ { $subsection quark }
+ { $subsection hadron }
+ { $subsection axion } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-author" "Author"
+
+ "Bubble Chamber was created by Jared Tarbell. "
+ "It was originally implemented in Processing. "
+ "It was ported to Factor by Eduardo Cavazos. "
+ "The original work is on display here: "
+ { $url
+ "http://www.complexification.net/gallery/machines/bubblechamber/" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-running" "How to use"
+
+ "After you run the vocabulary, a window will appear. Click the "
+ "mouse in a random area to fire 11 particles of each type. "
+ "Another way to fire particles is to press the "
+ "spacebar. This fires all the particles." ;
\ No newline at end of file
From e7c3d888f642e379a6af7c8741f5dfe2148e1ae3 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 8 Apr 2008 04:04:12 -0500
Subject: [PATCH 249/288] math.points: Utility words for two and three
dimensional points
---
extra/math/points/points.factor | 22 ++++++++++++++++++++++
1 file changed, 22 insertions(+)
create mode 100644 extra/math/points/points.factor
diff --git a/extra/math/points/points.factor b/extra/math/points/points.factor
new file mode 100644
index 0000000000..5efd6e07e0
--- /dev/null
+++ b/extra/math/points/points.factor
@@ -0,0 +1,22 @@
+
+USING: kernel arrays math.vectors ;
+
+IN: math.points
+
+<PRIVATE
+
+: X ( x -- point ) 0 0 3array ;
+: Y ( y -- point ) 0 swap 0 3array ;
+: Z ( z -- point ) 0 0 rot 3array ;
+
+PRIVATE>
+
+: v+x ( seq x -- seq ) X v+ ;
+: v-x ( seq x -- seq ) X v- ;
+
+: v+y ( seq y -- seq ) Y v+ ;
+: v-y ( seq y -- seq ) Y v- ;
+
+: v+z ( seq z -- seq ) Z v+ ;
+: v-z ( seq z -- seq ) Z v- ;
+
From 94863d980de8c608902186d5b9546098c9cd6f6b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 8 Apr 2008 04:13:02 -0500
Subject: [PATCH 250/288] bubble-chamber: minor refactoring
---
.../gallery/bubble-chamber/bubble-chamber.factor | 14 +++-----------
1 file changed, 3 insertions(+), 11 deletions(-)
diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
index 5d128d5102..2efa04efad 100644
--- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
+++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
@@ -7,6 +7,7 @@ USING: kernel namespaces sequences combinators arrays threads
math.ranges
math.constants
math.functions
+ math.points
ui
ui.gadgets
@@ -76,17 +77,8 @@ VARS: particles muons quarks hadrons axions ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: x>> ( particle -- x ) pos>> first ;
-: y>> ( particle -- x ) pos>> second ;
-
-: >>x ( particle x -- particle ) over y>> 2array >>pos ;
-: >>y ( particle y -- particle ) over x>> swap 2array >>pos ;
-
-: x x>> ;
-: y y>> ;
-
-: v+y ( seq y -- seq ) >r first2 r> + 2array ;
-: v-y ( seq y -- seq ) >r first2 r> - 2array ;
+: x ( particle -- x ) pos>> first ;
+: y ( particle -- x ) pos>> second ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 4cd86a06174816adefef7f3899a82cedf66be585 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Tue, 8 Apr 2008 17:32:37 -0300
Subject: [PATCH 251/288] IRC client update
---
extra/irc/irc.factor | 337 ++++++++++++++++++++++++++-----------------
1 file changed, 206 insertions(+), 131 deletions(-)
diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor
index 8a39846fc4..0105fc53bb 100755
--- a/extra/irc/irc.factor
+++ b/extra/irc/irc.factor
@@ -1,87 +1,130 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar io io.sockets kernel match namespaces
-sequences splitting strings continuations threads ascii
-io.encodings.utf8 ;
+USING: arrays calendar combinators channels concurrency.messaging fry io
+ io.encodings.8-bit io.sockets kernel math namespaces sequences
+ sequences.lib singleton splitting strings threads
+ continuations classes.tuple ascii accessors ;
IN: irc
-! "setup" objects
-TUPLE: profile server port nickname password default-channels ;
-C: <profile> profile
+! utils
+: split-at-first ( seq separators -- before after )
+ dupd '[ , member? ] find
+ [ cut 1 tail ]
+ [ swap ]
+ if ;
-TUPLE: channel-profile name password auto-rejoin ;
-C: <channel-profile> channel-profile
+: spawn-server-linked ( quot name -- thread )
+ >r '[ , [ ] [ ] while ] r>
+ spawn-linked ;
+! ---
+
+! Default irc port
+: irc-port 6667 ;
+
+! Message used when the client isn't running anymore
+SINGLETON: irc-end
+
+! "setup" objects
+TUPLE: irc-profile server port nickname password default-channels ;
+C: <irc-profile> irc-profile
+
+TUPLE: irc-channel-profile name password auto-rejoin ;
+C: <irc-channel-profile> irc-channel-profile
! "live" objects
-TUPLE: irc-client profile nick stream stream-process controller-process ;
-C: <irc-client> irc-client
-
TUPLE: nick name channels log ;
C: <nick> nick
-TUPLE: channel name topic members log attributes ;
-C: <channel> channel
+TUPLE: irc-client profile nick stream stream-channel controller-channel
+ listeners is-running ;
+: <irc-client> ( profile -- irc-client )
+ f V{ } clone V{ } clone <nick>
+ f <channel> <channel> V{ } clone f irc-client construct-boa ;
+
+USE: prettyprint
+TUPLE: irc-listener channel ;
+! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
+! tener la opción de dejar de correr un client??
+: <irc-listener> ( quot -- irc-listener )
+ <channel> irc-listener construct-boa swap
+ [
+ [ channel>> '[ , from ] ]
+ [ '[ , curry f spawn drop ] ]
+ bi* compose "irc-listener" spawn-server-linked drop
+ ] [ drop ] 2bi ;
+
+! TUPLE: irc-channel name topic members log attributes ;
+! C: <irc-channel> irc-channel
! the delegate of all irc messages
-TUPLE: irc-message timestamp ;
+TUPLE: irc-message line prefix command parameters trailing timestamp ;
C: <irc-message> irc-message
! "irc message" objects
-TUPLE: logged-in name text ;
+TUPLE: logged-in < irc-message name ;
C: <logged-in> logged-in
-TUPLE: ping name ;
+TUPLE: ping < irc-message ;
C: <ping> ping
-TUPLE: join name channel ;
-C: <join> join
+TUPLE: join_ < irc-message ;
+C: <join> join_
-TUPLE: part name channel text ;
+TUPLE: part < irc-message name channel ;
C: <part> part
-TUPLE: quit text ;
+TUPLE: quit ;
C: <quit> quit
-TUPLE: privmsg name text ;
+TUPLE: privmsg < irc-message name ;
C: <privmsg> privmsg
-TUPLE: kick channel er ee text ;
+TUPLE: kick < irc-message channel who ;
C: <kick> kick
-TUPLE: roomlist channel names ;
+TUPLE: roomlist < irc-message channel names ;
C: <roomlist> roomlist
-TUPLE: nick-in-use name ;
+TUPLE: nick-in-use < irc-message name ;
C: <nick-in-use> nick-in-use
-TUPLE: notice type text ;
+TUPLE: notice < irc-message type ;
C: <notice> notice
-TUPLE: mode name channel mode text ;
+TUPLE: mode < irc-message name channel mode ;
C: <mode> mode
-! TUPLE: members
-TUPLE: unhandled text ;
+TUPLE: unhandled < irc-message ;
C: <unhandled> unhandled
-! "control message" objects
-TUPLE: command sender ;
-TUPLE: service predicate quot enabled? ;
-TUPLE: chat-command from to text ;
-TUPLE: join-command channel password ;
-TUPLE: part-command channel text ;
-
SYMBOL: irc-client
-: irc-stream> ( -- stream ) irc-client get irc-client-stream ;
-: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ;
+: irc-client> ( -- irc-client ) irc-client get ;
+: irc-stream> ( -- stream ) irc-client> stream>> ;
+
+: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+
: parse-name ( string -- string )
- trim-: "!" split first ;
-: irc-split ( string -- seq )
- 1 swap [ [ CHAR: : = ] find* ] keep
- swap [ swap cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-:
- " " split r> [ 1array append ] when* ;
+ remove-heading-: "!" split-at-first drop ;
+
+: sender>> ( obj -- string )
+ prefix>> parse-name ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head?
+ [ remove-heading-: " " split1 ]
+ [ f swap ]
+ if ;
+
+: split-trailing ( string -- string string/f )
+ ":" split1 ;
+
+: string>irc-message ( string -- object )
+ dup split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip
+ now <irc-message> ;
+
: me? ( name -- ? )
- irc-client get irc-client-nick nick-name = ;
+ irc-client> nick>> name>> = ;
: irc-write ( s -- )
irc-stream> stream-write ;
@@ -89,123 +132,155 @@ SYMBOL: irc-client
: irc-print ( s -- )
irc-stream> [ stream-print ] keep stream-flush ;
-: nick ( nick -- )
+! Irc commands
+
+: NICK ( nick -- )
"NICK " irc-write irc-print ;
-: login ( nick -- )
- dup nick
+: LOGIN ( nick -- )
+ dup NICK
"USER " irc-write irc-write
" hostname servername :irc.factor" irc-print ;
-: connect* ( server port -- )
- <inet> utf8 <client> irc-client get set-irc-client-stream ;
+: CONNECT ( server port -- stream )
+ <inet> latin1 <client> ;
-: connect ( server -- ) 6667 connect* ;
-
-: join ( channel password -- )
+: JOIN ( channel password -- )
"JOIN " irc-write
- [ >r " :" r> 3append ] when* irc-print ;
+ [ " :" swap 3append ] when* irc-print ;
-: part ( channel text -- )
- >r "PART " irc-write irc-write r>
+: PART ( channel text -- )
+ [ "PART " irc-write irc-write ] dip
" :" irc-write irc-print ;
-: say ( line nick -- )
- "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
+: KICK ( channel who -- )
+ [ "KICK " irc-write irc-write ] dip
+ " " irc-write irc-print ;
+
+: PRIVMSG ( nick line -- )
+ [ "PRIVMSG " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
-: quit ( text -- )
+: SAY ( nick line -- )
+ PRIVMSG ;
+
+: ACTION ( nick line -- )
+ [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ;
+
+: QUIT ( text -- )
"QUIT :" irc-write irc-print ;
+: join-channel ( channel-profile -- )
+ [ name>> ] keep password>> JOIN ;
+: irc-connect ( irc-client -- )
+ [ profile>> [ server>> ] keep port>> CONNECT ] keep
+ swap >>stream t >>is-running drop ;
+
GENERIC: handle-irc ( obj -- )
M: object handle-irc ( obj -- )
- "Unhandled irc object" print drop ;
+ drop ;
M: logged-in handle-irc ( obj -- )
- logged-in-name irc-client get [ irc-client-nick set-nick-name ] keep
-
- irc-client-profile profile-default-channels
- [
- [ channel-profile-name ] keep
- channel-profile-password join
- ] each ;
+ name>>
+ irc-client> [ nick>> swap >>name drop ] keep
+ profile>> default-channels>> [ join-channel ] each ;
M: ping handle-irc ( obj -- )
"PONG " irc-write
- ping-name irc-print ;
+ trailing>> irc-print ;
M: nick-in-use handle-irc ( obj -- )
- nick-in-use-name "_" append nick ;
+ name>> "_" append NICK ;
-: delegate-timestamp ( obj -- obj )
- now <irc-message> over set-delegate ;
+: parse-irc-line ( string -- message )
+ string>irc-message
+ dup command>> {
+ { "PING" [ \ ping ] }
+ { "NOTICE" [ \ notice ] }
+ { "001" [ \ logged-in ] }
+ { "433" [ \ nick-in-use ] }
+ { "JOIN" [ \ join_ ] }
+ { "PART" [ \ part ] }
+ { "PRIVMSG" [ \ privmsg ] }
+ { "QUIT" [ \ quit ] }
+ { "MODE" [ \ mode ] }
+ { "KICK" [ \ kick ] }
+ [ drop \ unhandled ]
+ } case
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip add* >tuple ;
-MATCH-VARS: ?name ?name2 ?channel ?text ?mode ;
-SYMBOL: line
-: match-irc ( string -- )
- dup line set
- dup print flush
- irc-split
- {
- { { "PING" ?name }
- [ ?name <ping> ] }
- { { ?name "001" ?name2 ?text }
- [ ?name2 ?text <logged-in> ] }
- { { ?name "433" _ ?name2 "Nickname is already in use." }
- [ ?name2 <nick-in-use> ] }
+! Reader
+: handle-reader-message ( irc-client irc-message -- )
+ dup handle-irc swap stream-channel>> to ;
- { { ?name "JOIN" ?channel }
- [ ?name ?channel <join> ] }
- { { ?name "PART" ?channel ?text }
- [ ?name ?channel ?text <part> ] }
- { { ?name "PRIVMSG" ?channel ?text }
- [ ?name ?channel ?text <privmsg> ] }
- { { ?name "QUIT" ?text }
- [ ?name ?text <quit> ] }
+: reader-loop ( irc-client -- )
+ dup stream>> stream-readln [
+ dup print parse-irc-line handle-reader-message
+ ] [
+ f >>is-running
+ dup stream>> dispose
+ irc-end over controller-channel>> to
+ stream-channel>> irc-end swap to
+ ] if* ;
- { { "NOTICE" ?name ?text }
- [ ?name ?text <notice> ] }
- { { ?name "MODE" ?channel ?mode ?text }
- [ ?name ?channel ?mode ?text <mode> ] }
- { { ?name "KICK" ?channel ?name2 ?text }
- [ ?channel ?name ?name2 ?text <kick> ] }
+! Controller commands
+GENERIC: handle-command ( obj -- )
- ! { { ?name "353" ?name2 _ ?channel ?text }
- ! [ ?text ?channel ?name2 make-member-list ] }
- { _ [ line get <unhandled> ] }
- } match-cond
- delegate-timestamp handle-irc flush ;
+M: object handle-command ( obj -- )
+ . ;
-: irc-loop ( -- )
- irc-stream> stream-readln
- [ match-irc irc-loop ] when* ;
+TUPLE: send-message to text ;
+C: <send-message> send-message
+M: send-message handle-command ( obj -- )
+ dup to>> swap text>> SAY ;
+TUPLE: send-action to text ;
+C: <send-action> send-action
+M: send-action handle-command ( obj -- )
+ dup to>> swap text>> ACTION ;
+
+TUPLE: send-quit text ;
+C: <send-quit> send-quit
+M: send-quit handle-command ( obj -- )
+ text>> QUIT ;
+
+: irc-listen ( irc-client quot -- )
+ [ listeners>> ] [ <irc-listener> ] bi* swap push ;
+
+! Controller loop
+: controller-loop ( irc-client -- )
+ controller-channel>> from handle-command ;
+
+! Multiplexer
+: multiplex-message ( irc-client message -- )
+ swap listeners>> [ channel>> ] map
+ [ '[ , , to ] "message" spawn drop ] each-with ;
+
+: multiplexer-loop ( irc-client -- )
+ dup stream-channel>> from multiplex-message ;
+
+! process looping and starting
+: (spawn-irc-loop) ( irc-client quot name -- )
+ [ over >r curry r> '[ @ , is-running>> ] ] dip
+ spawn-server-linked drop ;
+
+: spawn-irc-loop ( irc-client quot name -- )
+ '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ]
+ f spawn drop ;
+
+: spawn-irc ( irc-client -- )
+ [ [ reader-loop ] "reader-loop" spawn-irc-loop ]
+ [ [ controller-loop ] "controller-loop" spawn-irc-loop ]
+ [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ]
+ tri ;
+
: do-irc ( irc-client -- )
- dup irc-client set
- dup irc-client-profile profile-server
- over irc-client-profile profile-port connect*
- dup irc-client-profile profile-nickname login
- [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ;
-
-: with-infinite-loop ( quot timeout -- quot timeout )
- "looping" print flush
- over [ drop ] recover dup sleep with-infinite-loop ;
-
-: start-irc ( irc-client -- )
- ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ;
- [ do-irc ] curry 3000 with-infinite-loop ;
-
-
-! For testing
-: make-factorbot
- "irc.freenode.org" 6667 "factorbot" f
- [
- "#concatenative-flood" f f <channel-profile> ,
- ] { } make <profile>
- f V{ } clone V{ } clone <nick>
- f f f <irc-client> ;
-
-: test-factorbot
- make-factorbot start-irc ;
-
+ irc-client [
+ irc-client>
+ [ irc-connect ]
+ [ profile>> nickname>> LOGIN ]
+ [ spawn-irc ]
+ tri
+ ] with-variable ;
\ No newline at end of file
From 2cebf7e9e59790ba5a9531e33b4c6509f35f9c4d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 8 Apr 2008 18:51:56 -0500
Subject: [PATCH 252/288] Improve multi-methods: multi-var hooks
---
.../multi-methods/multi-methods-tests.factor | 98 ------
extra/multi-methods/multi-methods.factor | 309 ++++++++++--------
extra/multi-methods/tests/canonicalize.factor | 66 ++++
extra/multi-methods/tests/definitions.factor | 37 +++
extra/multi-methods/tests/legacy.factor | 10 +
extra/multi-methods/tests/syntax.factor | 58 ++++
.../tests/topological-sort.factor | 18 +
7 files changed, 357 insertions(+), 239 deletions(-)
delete mode 100755 extra/multi-methods/multi-methods-tests.factor
create mode 100644 extra/multi-methods/tests/canonicalize.factor
create mode 100644 extra/multi-methods/tests/definitions.factor
create mode 100644 extra/multi-methods/tests/legacy.factor
create mode 100644 extra/multi-methods/tests/syntax.factor
create mode 100644 extra/multi-methods/tests/topological-sort.factor
diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor
deleted file mode 100755
index 8910e64092..0000000000
--- a/extra/multi-methods/multi-methods-tests.factor
+++ /dev/null
@@ -1,98 +0,0 @@
-IN: multi-methods.tests
-USING: multi-methods tools.test kernel math arrays sequences
-prettyprint strings classes hashtables assocs namespaces
-debugger continuations ;
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ -1 ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ 0 ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ 1 ] [
- { object object } { number sequence } classes<
-] unit-test
-
-[
- {
- { { object integer } [ 1 ] }
- { { object object } [ 2 ] }
- { { POSTPONE: f POSTPONE: f } [ 3 ] }
- }
-] [
- {
- { { integer } [ 1 ] }
- { { } [ 2 ] }
- { { f f } [ 3 ] }
- } congruify-methods
-] unit-test
-
-GENERIC: first-test
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-TUPLE: paper ; INSTANCE: paper thing
-TUPLE: scissors ; INSTANCE: scissors thing
-TUPLE: rock ; INSTANCE: rock thing
-
-GENERIC: beats?
-
-METHOD: beats? { paper scissors } t ;
-METHOD: beats? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
-
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ t ] [ T{ paper } T{ scissors } play ] unit-test
-[ f ] [ T{ scissors } T{ paper } play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-GENERIC: legacy-test
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
-
-SYMBOL: some-var
-
-HOOK: hook-test some-var
-
-[ t ] [ \ hook-test hook-generic? ] unit-test
-
-METHOD: hook-test { array array } reverse ;
-METHOD: hook-test { array } class ;
-METHOD: hook-test { hashtable number } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index 115432b14d..0276e1422c 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -3,13 +3,74 @@
USING: kernel math sequences vectors classes classes.algebra
combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
-debugger io compiler.units kernel.private effects ;
+debugger io compiler.units kernel.private effects accessors
+hashtables sorting shuffle ;
IN: multi-methods
-GENERIC: generic-prologue ( combination -- quot )
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
-GENERIC: method-prologue ( combination -- quot )
+SYMBOL: args
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] subset
+ [ length <reversed> [ 1+ neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] subset
+ [ keys [ hooks get push-new ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ >r
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get + r>
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ >r total get object <array> dup <enum> r> update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ >r canonicalize-specializer-0 r> ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ >r canonicalize-specializer-1 r> ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ >r canonicalize-specializer-2 r> ] assoc-map
+
+ args get hooks get length + total set
+
+ [ >r canonicalize-specializer-3 r> ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
: maximal-element ( seq quot -- n elt )
dupd [
swapd [ call 0 < ] 2curry subset empty?
@@ -32,6 +93,10 @@ GENERIC: method-prologue ( combination -- quot )
} cond 2nip
] 2map [ zero? not ] find nip 0 or ;
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
: picker ( n -- quot )
{
{ 0 [ [ dup ] ] }
@@ -52,209 +117,171 @@ GENERIC: method-prologue ( combination -- quot )
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
+: multi-dispatch-quot ( methods generic -- quot )
+ "default-multi-method" word-prop 1quotation swap
+ [ >r multi-predicate r> ] assoc-map reverse alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
: methods ( word -- alist )
"multi-methods" word-prop >alist ;
-: make-method-def ( quot classes generic -- quot )
+: make-generic ( generic -- quot )
[
- swap [ declare ] curry %
- "multi-combination" word-prop method-prologue %
- %
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
] [ ] make ;
-TUPLE: method word def classes generic loc ;
+: update-generic ( word -- )
+ dup make-generic define ;
+! Methods
PREDICATE: method-body < word
- "multi-method" word-prop >boolean ;
+ "multi-method-generic" word-prop >boolean ;
M: method-body stack-effect
- "multi-method" word-prop method-generic stack-effect ;
+ "multi-method-generic" word-prop stack-effect ;
M: method-body crossref?
drop t ;
-: method-word-name ( classes generic -- string )
+: method-word-name ( specializer generic -- string )
+ [ word-name % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
[
- word-name %
- "-(" % [ "," % ] [ word-name % ] interleave ")" %
- ] "" make ;
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
-: <method-word> ( quot classes generic -- word )
- #! We xref here because the "multi-method" word-prop isn't
- #! set yet so crossref? yields f.
- [ make-method-def ] 2keep
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
method-word-name f <word>
- dup rot define
- dup xref ;
+ [ set-word-props ] keep ;
-: <method> ( quot classes generic -- method )
- [ <method-word> ] 3keep f \ method construct-boa
- dup method-word over "multi-method" set-word-prop ;
+: with-methods ( word quot -- )
+ over >r >r "multi-methods" word-prop
+ r> call r> update-generic ; inline
+
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
+
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
+
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
+ ] if ;
TUPLE: no-method arguments generic ;
: no-method ( argument-count generic -- * )
>r narray r> \ no-method construct-boa throw ; inline
-: argument-count ( methods -- n )
- dup assoc-empty? [ drop 0 ] [
- keys [ length ] map supremum
- ] if ;
-
-: multi-dispatch-quot ( methods generic -- quot )
- >r [
- [
- >r multi-predicate r> method-word 1quotation
- ] assoc-map
- ] keep argument-count
- r> [ no-method ] 2curry
- swap reverse alist>quot ;
-
-: congruify-methods ( alist -- alist' )
- dup argument-count [
- swap >r object pad-left [ \ f or ] map r>
- ] curry assoc-map ;
-
-: sorted-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error.
"Type check error" print
nl
- "Generic word " write dup no-method-generic pprint
+ "Generic word " write dup generic>> pprint
" does not have a method applicable to inputs:" print
- dup no-method-arguments short.
+ dup arguments>> short.
nl
"Inputs have signature:" print
- dup no-method-arguments [ class ] map niceify-method .
+ dup arguments>> [ class ] map niceify-method .
nl
- "Defined methods in topological order: " print
- no-method-generic
- methods congruify-methods sorted-methods keys
+ "Available methods: " print
+ generic>> methods keys
[ niceify-method ] map stack. ;
-TUPLE: standard-combination ;
+: make-default-method ( generic -- quot )
+ [ 0 swap no-method ] curry ;
-M: standard-combination method-prologue drop [ ] ;
+: <default-method> ( generic -- method )
+ [ { } swap <method> ] keep
+ [ drop ] [ make-default-method define ] 2bi ;
-M: standard-combination generic-prologue drop [ ] ;
+: define-default-method ( generic -- )
+ dup <default-method> "default-multi-method" set-word-prop ;
-: make-generic ( generic -- quot )
- dup "multi-combination" word-prop generic-prologue swap
- [ methods congruify-methods sorted-methods ] keep
- multi-dispatch-quot append ;
-
-TUPLE: hook-combination var ;
-
-M: hook-combination method-prologue
- drop [ drop ] ;
-
-M: hook-combination generic-prologue
- hook-combination-var [ get ] curry ;
-
-: update-generic ( word -- )
- dup make-generic define ;
-
-: define-generic ( word combination -- )
- over "multi-combination" word-prop over = [
- 2drop
- ] [
- dupd "multi-combination" set-word-prop
- dup H{ } clone "multi-methods" set-word-prop
- update-generic
- ] if ;
-
-: define-standard-generic ( word -- )
- T{ standard-combination } define-generic ;
-
-: GENERIC:
- CREATE define-standard-generic ; parsing
-
-: define-hook-generic ( word var -- )
- hook-combination construct-boa define-generic ;
-
-: HOOK:
- CREATE scan-word define-hook-generic ; parsing
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: with-methods ( word quot -- )
- over >r >r "multi-methods" word-prop
- r> call r> update-generic ; inline
-
-: define-method ( quot classes generic -- )
- >r [ bootstrap-word ] map r>
- [ <method> ] 2keep
- [ set-at ] with-methods ;
-
-: forget-method ( classes generic -- )
+: forget-method ( specializer generic -- )
[ delete-at ] with-methods ;
: method>spec ( method -- spec )
- dup method-classes swap method-generic prefix ;
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
+
+: define-generic ( word -- )
+ dup "multi-methods" word-prop [
+ drop
+ ] [
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ define-default-method ]
+ [ update-generic ]
+ tri
+ ] if ;
+
+! Syntax
+: GENERIC:
+ CREATE define-generic ; parsing
: parse-method ( -- quot classes generic )
- parse-definition dup 2 tail over second rot first ;
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-: METHOD:
- location
- >r parse-method [ define-method ] 2keep prefix r>
- remember-definition ; parsing
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
+
+: CREATE-METHOD
+ scan-word scan-object swap create-method-in ;
+
+: (METHOD:) CREATE-METHOD parse-definition ;
+
+: METHOD: (METHOD:) define ; parsing
! For compatibility
: M:
- scan-word 1array scan-word parse-definition
- -rot define-method ; parsing
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ; parsing
! Definition protocol. We qualify core generics here
USE: qualified
QUALIFIED: syntax
-PREDICATE: generic < word
- "multi-combination" word-prop >boolean ;
+syntax:M: generic definer drop \ GENERIC: f ;
-PREDICATE: standard-generic < word
- "multi-combination" word-prop standard-combination? ;
-
-PREDICATE: hook-generic < word
- "multi-combination" word-prop hook-combination? ;
-
-syntax:M: standard-generic definer drop \ GENERIC: f ;
-
-syntax:M: standard-generic definition drop f ;
-
-syntax:M: hook-generic definer drop \ HOOK: f ;
-
-syntax:M: hook-generic definition drop f ;
-
-syntax:M: hook-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup "multi-combination" word-prop
- hook-combination-var pprint-word stack-effect. ;
+syntax:M: generic definition drop f ;
PREDICATE: method-spec < array
unclip generic? >r [ class? ] all? r> and ;
syntax:M: method-spec where
- dup unclip method [ method-loc ] [ second where ] ?if ;
+ dup unclip method [ ] [ first ] ?if where ;
syntax:M: method-spec set-where
- unclip method set-method-loc ;
+ unclip method set-where ;
syntax:M: method-spec definer
- drop \ METHOD: \ ; ;
+ unclip method definer ;
syntax:M: method-spec definition
- unclip method dup [ method-def ] when ;
+ unclip method definition ;
syntax:M: method-spec synopsis*
- dup definer.
- unclip pprint* pprint* ;
+ unclip method synopsis* ;
syntax:M: method-spec forget*
- unclip forget-method ;
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor
new file mode 100644
index 0000000000..d5baf4914c
--- /dev/null
+++ b/extra/multi-methods/tests/canonicalize.factor
@@ -0,0 +1,66 @@
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ } ;
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ V{ cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor
new file mode 100644
index 0000000000..60ddd32875
--- /dev/null
+++ b/extra/multi-methods/tests/definitions.factor
@@ -0,0 +1,37 @@
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+
+\ GENERIC: must-infer
+\ create-method-in must-infer
+\ define-default-method must-infer
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+
+[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+[ { } \ fake method-word-props ] unit-test
+
+[ t ] [ { } \ fake <method> method-body? ] unit-test
+
+[
+ [ ] [ \ fake define-default-method ] unit-test
+
+ [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+
+ [ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test
+] with-compilation-unit
diff --git a/extra/multi-methods/tests/legacy.factor b/extra/multi-methods/tests/legacy.factor
new file mode 100644
index 0000000000..f4bd0a00b2
--- /dev/null
+++ b/extra/multi-methods/tests/legacy.factor
@@ -0,0 +1,10 @@
+IN: multi-methods.tests
+USING: math strings sequences tools.test ;
+
+GENERIC: legacy-test
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor
new file mode 100644
index 0000000000..5e2e86d04b
--- /dev/null
+++ b/extra/multi-methods/tests/syntax.factor
@@ -0,0 +1,58 @@
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs ;
+
+GENERIC: first-test
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+GENERIC: beats?
+
+METHOD: beats? { paper scissors } t ;
+METHOD: beats? { scissors rock } t ;
+METHOD: beats? { rock paper } t ;
+METHOD: beats? { thing thing } f ;
+
+: play ( obj1 obj2 -- ? ) beats? 2nip ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+GENERIC: hook-test
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+GENERIC: busted-sort
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
diff --git a/extra/multi-methods/tests/topological-sort.factor b/extra/multi-methods/tests/topological-sort.factor
new file mode 100644
index 0000000000..ed8bece4ba
--- /dev/null
+++ b/extra/multi-methods/tests/topological-sort.factor
@@ -0,0 +1,18 @@
+IN: multi-methods.tests
+USING: kernel multi-methods tools.test math arrays sequences ;
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ -1 ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ 0 ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ 1 ] [
+ { object object } { number sequence } classes<
+] unit-test
From a82794a71910cfaea3471a95db65e8d101a95557 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 8 Apr 2008 19:12:48 -0500
Subject: [PATCH 253/288] Fixing error reporting
---
extra/multi-methods/multi-methods.factor | 35 ++++++++------------
extra/multi-methods/tests/definitions.factor | 5 +--
extra/multi-methods/tests/syntax.factor | 8 ++++-
3 files changed, 22 insertions(+), 26 deletions(-)
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index 0276e1422c..8f9e34b1fb 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -117,9 +117,18 @@ SYMBOL: total
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ >r argument-count r> [ >r narray r> no-method ] 2curry ;
+
: multi-dispatch-quot ( methods generic -- quot )
- "default-multi-method" word-prop 1quotation swap
- [ >r multi-predicate r> ] assoc-map reverse alist>quot ;
+ [ make-default-method ]
+ [ drop [ >r multi-predicate r> ] assoc-map reverse ]
+ 2bi alist>quot ;
! Generic words
PREDICATE: generic < word
@@ -178,11 +187,6 @@ M: method-body crossref?
drop [ <method> dup ] 2keep reveal-method
] if ;
-TUPLE: no-method arguments generic ;
-
-: no-method ( argument-count generic -- * )
- >r narray r> \ no-method construct-boa throw ; inline
-
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error.
@@ -196,18 +200,8 @@ M: no-method error.
dup arguments>> [ class ] map niceify-method .
nl
"Available methods: " print
- generic>> methods keys
- [ niceify-method ] map stack. ;
-
-: make-default-method ( generic -- quot )
- [ 0 swap no-method ] curry ;
-
-: <default-method> ( generic -- method )
- [ { } swap <method> ] keep
- [ drop ] [ make-default-method define ] 2bi ;
-
-: define-default-method ( generic -- )
- dup <default-method> "default-multi-method" set-word-prop ;
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
: forget-method ( specializer generic -- )
[ delete-at ] with-methods ;
@@ -221,9 +215,8 @@ M: no-method error.
drop
] [
[ H{ } clone "multi-methods" set-word-prop ]
- [ define-default-method ]
[ update-generic ]
- tri
+ bi
] if ;
! Syntax
diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor
index 60ddd32875..fea8f0c402 100644
--- a/extra/multi-methods/tests/definitions.factor
+++ b/extra/multi-methods/tests/definitions.factor
@@ -4,7 +4,6 @@ kernel strings words compiler.units quotations ;
\ GENERIC: must-infer
\ create-method-in must-infer
-\ define-default-method must-infer
DEFER: fake
\ fake H{ } clone "multi-methods" set-word-prop
@@ -17,11 +16,9 @@ DEFER: fake
[ t ] [ { } \ fake <method> method-body? ] unit-test
[
- [ ] [ \ fake define-default-method ] unit-test
-
[ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test
- [ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
[ t ] [ \ fake make-generic quotation? ] unit-test
diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor
index 5e2e86d04b..597a1cebeb 100644
--- a/extra/multi-methods/tests/syntax.factor
+++ b/extra/multi-methods/tests/syntax.factor
@@ -1,7 +1,7 @@
IN: multi-methods.tests
USING: multi-methods tools.test math sequences namespaces system
kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs ;
+hashtables continuations classes assocs accessors ;
GENERIC: first-test
@@ -25,6 +25,7 @@ METHOD: beats? { thing thing } f ;
[ { } 3 play ] must-fail
[ t ] [ error get no-method? ] unit-test
[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
[ t ] [ paper scissors play ] unit-test
[ f ] [ scissors paper play ] unit-test
@@ -45,6 +46,11 @@ METHOD: hook-test { hashtable { some-var number } } assoc-size ;
5.0 some-var set
[ 0 ] [ H{ } hook-test ] unit-test
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
MIXIN: busted
TUPLE: busted-1 ;
From 9c19ade9810857c98cf41228f59982736ef53d5b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 8 Apr 2008 19:43:54 -0500
Subject: [PATCH 254/288] Fix library path
---
extra/db/postgresql/ffi/ffi.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index 7f428bb6b6..ee5ba622e5 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -6,8 +6,7 @@ IN: db.postgresql.ffi
<< "postgresql" {
{ [ os winnt? ] [ "libpq.dll" ] }
- { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] }
- ! { [ os macosx? ] [ "libpq.dylib" ] }
+ { [ os macosx? ] [ "libpq.dylib" ] }
{ [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
From 0dd8e462c6dc31065dcdee6d33913edd3a3688e5 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 9 Apr 2008 12:52:49 +1200
Subject: [PATCH 255/288] Minor peg refactorings
---
extra/peg/peg.factor | 75 +++++++++++++++++++++++---------------------
1 file changed, 40 insertions(+), 35 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 3b1d408ae2..7390c15684 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -30,6 +30,9 @@ SYMBOL: fail
SYMBOL: lrstack
SYMBOL: heads
+: failed? ( obj -- ? )
+ fail = ;
+
: delegates ( -- cache )
\ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
@@ -66,21 +69,18 @@ C: <head> peg-head
#! that maps the position to the parser result.
id>> packrat get [ drop H{ } clone ] cache ;
+: process-rule-result ( p result -- result )
+ [
+ nip [ ast>> ] [ remaining>> ] bi input-from pos set
+ ] [
+ pos set fail
+ ] if* ;
+
: eval-rule ( rule -- ast )
#! Evaluate a rule, return an ast resulting from it.
#! Return fail if the rule failed. The rule has
#! stack effect ( input -- parse-result )
- pos get swap
- execute
-! drop f f <parse-result>
- [
- nip
- [ ast>> ] [ remaining>> ] bi
- input-from pos set
- ] [
- pos set
- fail
- ] if* ; inline
+ pos get swap execute process-rule-result ; inline
: memo ( pos rule -- memo-entry )
#! Return the result from the memo cache.
@@ -90,21 +90,29 @@ C: <head> peg-head
#! Store an entry in the cache
rule-parser input-cache set-at ;
-:: (grow-lr) ( r p m h -- )
- p pos set
- h involved-set>> clone h (>>eval-set)
+: update-m ( ast m -- )
+ swap >>ans pos get >>pos drop ;
+
+: stop-growth? ( ast m -- ? )
+ [ failed? pos get ] dip
+ pos>> <= or ;
+
+: setup-growth ( h p -- )
+ pos set dup involved-set>> clone >>eval-set drop ;
+
+:: (grow-lr) ( h p r m -- )
+ h p setup-growth
r eval-rule
- dup fail = pos get m pos>> <= or [
+ dup m stop-growth? [
drop
] [
- m (>>ans)
- pos get m (>>pos)
- r p m h (grow-lr)
+ m update-m
+ h p r m (grow-lr)
] if ; inline
-:: grow-lr ( r p m h -- ast )
+:: grow-lr ( h p r m -- ast )
h p heads get set-at
- r p m h (grow-lr)
+ h p r m (grow-lr)
p heads get delete-at
m pos>> pos set m ans>>
; inline
@@ -128,10 +136,10 @@ C: <head> peg-head
|
h rule>> r eq? [
m ans>> seed>> m (>>ans)
- m ans>> fail = [
+ m ans>> failed? [
fail
] [
- r p m h grow-lr
+ h p r m grow-lr
] if
] [
m ans>> seed>>
@@ -150,8 +158,7 @@ C: <head> peg-head
r h eval-set>> member? [
h [ r swap remove ] change-eval-set drop
r eval-rule
- m (>>ans)
- pos get m (>>pos)
+ m update-m
m
] [
m
@@ -207,20 +214,18 @@ C: <head> peg-head
GENERIC: (compile) ( parser -- quot )
+: execute-parser ( word -- result )
+ pos get apply-rule dup failed? [
+ drop f
+ ] [
+ input-slice swap <parse-result>
+ ] if ; inline
-:: parser-body ( parser -- quot )
+: parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version
#! of the parser.
- [let* | rule [ gensym dup parser (compile) 0 1 <effect> define-declared dup parser "peg" set-word-prop ]
- |
- [
- rule pos get apply-rule dup fail = [
- drop f
- ] [
- input-slice swap <parse-result>
- ] if
- ]
- ] ;
+ gensym 2dup swap (compile) 0 1 <effect> define-declared swap dupd "peg" set-word-prop
+ [ execute-parser ] curry ;
: compiled-parser ( parser -- word )
#! Look to see if the given parser has been compiled.
From 411a13756395cbf142d7212868cc8512eff50aff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 8 Apr 2008 21:29:37 -0500
Subject: [PATCH 256/288] Fix unit test
---
extra/multi-methods/tests/definitions.factor | 2 --
1 file changed, 2 deletions(-)
diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor
index fea8f0c402..c112a67776 100644
--- a/extra/multi-methods/tests/definitions.factor
+++ b/extra/multi-methods/tests/definitions.factor
@@ -29,6 +29,4 @@ DEFER: fake
[ ] [ \ testing define-generic ] unit-test
[ t ] [ \ testing generic? ] unit-test
-
- [ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test
] with-compilation-unit
From 6c5935a3b0e604afa7606384f66183bbfc87e577 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 8 Apr 2008 23:08:11 -0500
Subject: [PATCH 257/288] add set-os-env, unset-os-env
---
core/bootstrap/primitives.factor | 2 ++
core/inference/known-words/known-words.factor | 4 ++++
vm/os-unix.c | 15 +++++++++++++++
vm/primitives.c | 2 ++
vm/run.h | 2 ++
5 files changed, 25 insertions(+)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 233de6f4ee..9d3c28b068 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -732,6 +732,8 @@ define-builtin
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
{ "(os-envs)" "system.private" }
+ { "set-os-env" "system" }
+ { "unset-os-env" "system" }
{ "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
{ "resize-bit-array" "bit-arrays" }
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 33a5da87f4..453e2460b0 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -587,6 +587,10 @@ set-primitive-effect
\ (os-envs) { } { array } <effect> set-primitive-effect
+\ set-os-env { string string } { } <effect> set-primitive-effect
+
+\ unset-os-env { string } { } <effect> set-primitive-effect
+
\ (set-os-envs) { array } { } <effect> set-primitive-effect
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
diff --git a/vm/os-unix.c b/vm/os-unix.c
index 74320288aa..2991cde78c 100755
--- a/vm/os-unix.c
+++ b/vm/os-unix.c
@@ -103,6 +103,21 @@ DEFINE_PRIMITIVE(os_envs)
dpush(result);
}
+DEFINE_PRIMITIVE(set_os_env)
+{
+ char *key = unbox_char_string();
+ REGISTER_C_STRING(key);
+ char *value = unbox_char_string();
+ UNREGISTER_C_STRING(key);
+ setenv(key, value, 1);
+}
+
+DEFINE_PRIMITIVE(unset_os_env)
+{
+ char *key = unbox_char_string();
+ unsetenv(key);
+}
+
DEFINE_PRIMITIVE(set_os_envs)
{
F_ARRAY *array = untag_array(dpop());
diff --git a/vm/primitives.c b/vm/primitives.c
index 533fcebc9a..2906a154a2 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -182,6 +182,8 @@ void *primitives[] = {
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_os_envs,
+ primitive_set_os_env,
+ primitive_unset_os_env,
primitive_set_os_envs,
primitive_resize_byte_array,
primitive_resize_bit_array,
diff --git a/vm/run.h b/vm/run.h
index c112c5f587..e2afb08525 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -249,6 +249,8 @@ DECLARE_PRIMITIVE(setenv);
DECLARE_PRIMITIVE(exit);
DECLARE_PRIMITIVE(os_env);
DECLARE_PRIMITIVE(os_envs);
+DECLARE_PRIMITIVE(set_os_env);
+DECLARE_PRIMITIVE(unset_os_env);
DECLARE_PRIMITIVE(set_os_envs);
DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
From c19505cd844e9fb14fffadf937bdfee7d52089b4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 8 Apr 2008 23:35:28 -0500
Subject: [PATCH 258/288] set-os-env on windows
---
vm/os-windows.c | 15 +++++++++++++++
1 file changed, 15 insertions(+)
diff --git a/vm/os-windows.c b/vm/os-windows.c
index 664df9e774..b3fc1c917f 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.c
@@ -215,6 +215,21 @@ void sleep_millis(DWORD msec)
Sleep(msec);
}
+DEFINE_PRIMITIVE(set_os_env)
+{
+ char *key = unbox_char_string();
+ REGISTER_C_STRING(key);
+ char *value = unbox_char_string();
+ UNREGISTER_C_STRING(key);
+ SetEnvironmentVariable(key, value);
+}
+
+DEFINE_PRIMITIVE(unset_os_env)
+{
+ char *key = unbox_char_string();
+ SetEnvironmentVariable(key, f);
+}
+
DEFINE_PRIMITIVE(set_os_envs)
{
not_implemented_error();
From 52bb93cf40a878577ce33ebd8f9766ffeab102cb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 9 Apr 2008 00:19:56 -0500
Subject: [PATCH 259/288] Working on faster refresh-all
---
extra/tools/vocabs/monitor/monitor.factor | 39 +++++++++++-----
extra/tools/vocabs/vocabs.factor | 57 ++++++++++++-----------
2 files changed, 56 insertions(+), 40 deletions(-)
diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor
index 071f179676..ada539c60a 100755
--- a/extra/tools/vocabs/monitor/monitor.factor
+++ b/extra/tools/vocabs/monitor/monitor.factor
@@ -1,24 +1,39 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: threads io.files io.monitors init kernel
-vocabs.loader tools.vocabs namespaces continuations ;
+vocabs vocabs.loader tools.vocabs namespaces continuations
+sequences splitting assocs ;
IN: tools.vocabs.monitor
-! Use file system change monitoring to flush the tags/authors
-! cache
-SYMBOL: vocab-monitor
+: vocab-dir>vocab-name ( path -- vocab )
+ left-trim-separators right-trim-separators
+ { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;
-: monitor-thread ( -- )
- vocab-monitor get-global
- next-change 2drop
- t sources-changed? set-global reset-cache ;
+: path>vocab-name ( path -- vocab )
+ dup ".factor" tail? [ parent-directory ] when
+ dup [ vocab-dir>vocab-name ] when ;
-: start-monitor-thread
+: changed-vocab ( vocab -- )
+ dup vocab
+ [ dup changed-vocabs get-global set-at ] [ drop ] if ;
+
+: monitor-thread ( path monitor -- )
+ #! On OS X, monitors give us the full path, so we chop it
+ #! off if its there.
+ next-change drop swap ?head drop
+ path>vocab-name changed-vocab reset-cache ;
+
+: start-monitor-thread ( root -- )
#! Silently ignore errors during monitor creation since
#! monitors are not supported on all platforms.
+ (normalize-path) dup t <monitor> [ monitor-thread t ] 2curry
+ "Vocabulary monitor" spawn-server drop ;
+
+: start-monitor-threads ( -- )
[
- "" resource-path t <monitor> vocab-monitor set-global
- [ monitor-thread t ] "Vocabulary monitor" spawn-server drop
+ vocab-roots get [ start-monitor-thread ] each
+ H{ } clone changed-vocabs set-global
+ vocabs [ changed-vocab ] each
] ignore-errors ;
-[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook
+[ start-monitor-threads ] "tools.vocabs.monitor" add-init-hook
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index 2f941ad2ce..825d2a6329 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -21,15 +21,15 @@ IN: tools.vocabs
: vocab-tests ( vocab -- tests )
[
- dup vocab-tests-file [ , ] when*
- vocab-tests-dir [ % ] when*
+ [ vocab-tests-file [ , ] when* ]
+ [ vocab-tests-dir [ % ] when* ] bi
] { } make ;
: vocab-files ( vocab -- seq )
[
- dup vocab-source-path [ , ] when*
- dup vocab-docs-path [ , ] when*
- vocab-tests %
+ [ vocab-source-path [ , ] when* ]
+ [ vocab-docs-path [ , ] when* ]
+ [ vocab-tests % ] tri
] { } make ;
: source-modified? ( path -- ? )
@@ -56,20 +56,27 @@ IN: tools.vocabs
: modified-docs ( vocabs -- seq )
[ vocab-docs-path ] modified ;
+SYMBOL: changed-vocabs
+
+[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
+
+: filter-changed ( vocabs -- vocabs' )
+ changed-vocabs get [
+ [ delete-at* nip ] curry subset
+ ] when* ;
+
: to-refresh ( prefix -- modified-sources modified-docs )
- child-vocabs
- dup modified-sources swap modified-docs ;
+ child-vocabs filter-changed
+ [ modified-sources ] [ modified-docs ] bi ;
: vocab-heading. ( vocab -- )
nl
"==== " write
- dup vocab-name swap vocab write-object ":" print
+ [ vocab-name ] [ vocab write-object ] bi ":" print
nl ;
: load-error. ( triple -- )
- dup first vocab-heading.
- dup second print-error
- drop ;
+ [ first vocab-heading. ] [ second print-error ] bi ;
: load-failures. ( failures -- )
[ load-error. nl ] each ;
@@ -89,30 +96,24 @@ SYMBOL: failures
] with-compiler-errors ;
: do-refresh ( modified-sources modified-docs -- )
- 2dup
- [ f swap set-vocab-docs-loaded? ] each
- [ f swap set-vocab-source-loaded? ] each
- append prune require-all load-failures. ;
+ [
+ [ [ f swap set-vocab-source-loaded? ] each ]
+ [ [ f swap set-vocab-docs-loaded? ] each ] bi*
+ ]
+ [ append prune require-all load-failures. ] 2bi ;
: refresh ( prefix -- ) to-refresh do-refresh ;
-SYMBOL: sources-changed?
+: refresh-all ( -- ) "" refresh ;
-[ t sources-changed? set-global ] "tools.vocabs" add-init-hook
-
-: refresh-all ( -- )
- "" refresh f sources-changed? set-global ;
-
-MEMO: (vocab-file-contents) ( path -- lines )
- dup exists? [ utf8 file-lines ] [ drop f ] if ;
-
-: vocab-file-contents ( vocab name -- seq )
- vocab-append-path dup [ (vocab-file-contents) ] when ;
+MEMO: vocab-file-contents ( vocab name -- seq )
+ vocab-append-path dup
+ [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-append-path [
utf8 set-file-lines
- \ (vocab-file-contents) reset-memoized
+ \ vocab-file-contents reset-memoized
] [
"The " swap vocab-name
" vocabulary was not loaded from the file system"
@@ -261,7 +262,7 @@ MEMO: all-authors ( -- seq )
: reset-cache ( -- )
root-cache get-global clear-assoc
- \ (vocab-file-contents) reset-memoized
+ \ vocab-file-contents reset-memoized
\ all-vocabs-seq reset-memoized
\ all-authors reset-memoized
\ all-tags reset-memoized ;
From 16fa44fc8222b15d81c6bb3295eb3a38b3835f2b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 9 Apr 2008 00:22:25 -0500
Subject: [PATCH 260/288] Fix irc loading
---
extra/irc/irc.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor
index 0105fc53bb..27f82b25eb 100755
--- a/extra/irc/irc.factor
+++ b/extra/irc/irc.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar combinators channels concurrency.messaging fry io
io.encodings.8-bit io.sockets kernel math namespaces sequences
- sequences.lib singleton splitting strings threads
+ sequences.lib splitting strings threads
continuations classes.tuple ascii accessors ;
IN: irc
@@ -209,7 +209,7 @@ M: nick-in-use handle-irc ( obj -- )
{ "KICK" [ \ kick ] }
[ drop \ unhandled ]
} case
- [ [ tuple-slots ] [ parameters>> ] bi append ] dip add* >tuple ;
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
! Reader
: handle-reader-message ( irc-client irc-message -- )
From c5229fcbd1a1148545c47ec6caa57c83ecfd5b40 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 9 Apr 2008 00:32:18 -0500
Subject: [PATCH 261/288] add some docs for environment variables
---
core/system/system-docs.factor | 35 ++++++++++++++++++++++++++++------
1 file changed, 29 insertions(+), 6 deletions(-)
diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index df112bd786..d0b2cfb194 100755
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -7,9 +7,7 @@ ABOUT: "system"
ARTICLE: "system" "System interface"
{ $subsection "cpu" }
{ $subsection "os" }
-"Reading environment variables:"
-{ $subsection os-env }
-{ $subsection os-envs }
+{ $subsection "environment-variables" }
"Getting the path to the Factor VM and image:"
{ $subsection vm }
{ $subsection image }
@@ -19,7 +17,16 @@ ARTICLE: "system" "System interface"
{ $subsection exit }
{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
-ARTICLE: "cpu" "Processor Detection"
+ARTICLE: "environment-variables" "Environment variables"
+"Reading environment variables:"
+{ $subsection os-env }
+{ $subsection os-envs }
+"Writing environment variables:"
+{ $subsection set-os-env }
+{ $subsection unset-os-env }
+{ $subsection set-os-envs } ;
+
+ARTICLE: "cpu" "Processor detection"
"Processor detection:"
{ $subsection cpu }
"Supported processors:"
@@ -30,7 +37,7 @@ ARTICLE: "cpu" "Processor Detection"
"Processor families:"
{ $subsection x86 } ;
-ARTICLE: "os" "Operating System Detection"
+ARTICLE: "os" "Operating system detection"
"Operating system detection:"
{ $subsection os }
"Supported operating systems:"
@@ -98,7 +105,23 @@ HELP: set-os-envs
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-{ os-env os-envs set-os-envs } related-words
+HELP: set-os-env ( value key -- )
+{ $values { "value" string } { "key" string } }
+{ $description "Set an environment variable." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+HELP: unset-os-env ( key -- )
+{ $values { "key" string } }
+{ $description "Unset an environment variable." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
HELP: image
{ $values { "path" "a pathname string" } }
From d1cc5cc650461cff50e15ba4640f2e746e72dece Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 9 Apr 2008 00:33:29 -0500
Subject: [PATCH 262/288] windows environment variables
---
vm/os-windows.c | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/vm/os-windows.c b/vm/os-windows.c
index b3fc1c917f..77a32f6f9f 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.c
@@ -217,17 +217,17 @@ void sleep_millis(DWORD msec)
DEFINE_PRIMITIVE(set_os_env)
{
- char *key = unbox_char_string();
+ F_CHAR *key = unbox_u16_string();
REGISTER_C_STRING(key);
- char *value = unbox_char_string();
+ F_CHAR *value = unbox_u16_string();
UNREGISTER_C_STRING(key);
SetEnvironmentVariable(key, value);
}
DEFINE_PRIMITIVE(unset_os_env)
{
- char *key = unbox_char_string();
- SetEnvironmentVariable(key, f);
+ F_CHAR *key = unbox_u16_string();
+ SetEnvironmentVariable(key, NULL);
}
DEFINE_PRIMITIVE(set_os_envs)
From c6e1347c6718c793dbb7d3949c48147e2e2259d5 Mon Sep 17 00:00:00 2001
From: Eric Mertens <emertens@galois.com>
Date: Tue, 8 Apr 2008 22:36:49 -0700
Subject: [PATCH 263/288] Two small spelling fixes
---
core/inference/backend/backend-docs.factor | 2 +-
extra/io/monitors/monitors-docs.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor
index 1d742e144a..32978d5814 100755
--- a/core/inference/backend/backend-docs.factor
+++ b/core/inference/backend/backend-docs.factor
@@ -4,7 +4,7 @@ kernel.private combinators sequences.private ;
HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
-{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
+{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
HELP: too-many->r
{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }
diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor
index 76a354b0bd..4f24879e19 100755
--- a/extra/io/monitors/monitors-docs.factor
+++ b/extra/io/monitors/monitors-docs.factor
@@ -9,7 +9,7 @@ $nl
HELP: next-change
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
-{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
+{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
HELP: with-monitor
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
From 639871900a65a25617fed0ee19342e6cd4971dac Mon Sep 17 00:00:00 2001
From: Eric Mertens <emertens@galois.com>
Date: Tue, 8 Apr 2008 23:22:28 -0700
Subject: [PATCH 264/288] Import extra/unionfind, a disjoint set datastructure
---
extra/unionfind/authors.txt | 1 +
extra/unionfind/summary.txt | 1 +
extra/unionfind/unionfind.factor | 71 ++++++++++++++++++++++++++++++++
3 files changed, 73 insertions(+)
create mode 100644 extra/unionfind/authors.txt
create mode 100644 extra/unionfind/summary.txt
create mode 100644 extra/unionfind/unionfind.factor
diff --git a/extra/unionfind/authors.txt b/extra/unionfind/authors.txt
new file mode 100644
index 0000000000..16e1588016
--- /dev/null
+++ b/extra/unionfind/authors.txt
@@ -0,0 +1 @@
+Eric Mertens
diff --git a/extra/unionfind/summary.txt b/extra/unionfind/summary.txt
new file mode 100644
index 0000000000..c282cc29bb
--- /dev/null
+++ b/extra/unionfind/summary.txt
@@ -0,0 +1 @@
+A efficient implementation of a disjoint-set datastructure
diff --git a/extra/unionfind/unionfind.factor b/extra/unionfind/unionfind.factor
new file mode 100644
index 0000000000..1f0d8be927
--- /dev/null
+++ b/extra/unionfind/unionfind.factor
@@ -0,0 +1,71 @@
+USING: accessors arrays combinators kernel math sequences namespaces ;
+
+IN: unionfind
+
+<PRIVATE
+
+TUPLE: unionfind parents ranks counts ;
+
+SYMBOL: uf
+
+: count ( a -- n )
+ uf get counts>> nth ;
+
+: add-count ( p a -- )
+ count [ + ] curry uf get counts>> swap change-nth ;
+
+: parent ( a -- p )
+ uf get parents>> nth ;
+
+: set-parent ( p a -- )
+ uf get parents>> set-nth ;
+
+: link-sets ( p a -- )
+ [ set-parent ]
+ [ add-count ] 2bi ;
+
+: rank ( a -- r )
+ uf get ranks>> nth ;
+
+: inc-rank ( a -- )
+ uf get ranks>> [ 1+ ] change-nth ;
+
+: topparent ( a -- p )
+ [ parent ] keep
+ 2dup = [
+ [ topparent ] dip
+ 2dup set-parent
+ ] unless drop ;
+
+PRIVATE>
+
+: <unionfind> ( n -- unionfind )
+ [ >array ]
+ [ 0 <array> ]
+ [ 1 <array> ] tri
+ unionfind construct-boa ;
+
+: equiv-set-size ( a uf -- n )
+ uf [ topparent count ] with-variable ;
+
+: equiv? ( a b uf -- ? )
+ uf [ [ topparent ] bi@ = ] with-variable ;
+
+: equate ( a b uf -- )
+ uf [
+ [ topparent ] bi@
+ 2dup [ rank ] compare sgn
+ {
+ { -1 [ swap link-sets ] }
+ { 1 [ link-sets ] }
+ { 0 [
+ 2dup =
+ [ 2drop ]
+ [
+ [ link-sets ]
+ [ drop inc-rank ] 2bi
+ ] if
+ ]
+ }
+ } case
+ ] with-variable ;
From 8d8c39ecca0496b8e684a810211c6f662ed0ac36 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 9 Apr 2008 02:53:21 -0500
Subject: [PATCH 265/288] Fix circularity
---
core/inference/backend/backend-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor
index 32978d5814..0125f04efa 100755
--- a/core/inference/backend/backend-docs.factor
+++ b/core/inference/backend/backend-docs.factor
@@ -1,6 +1,7 @@
USING: help.syntax help.markup words effects inference.dataflow
-inference.state inference.backend kernel sequences
+inference.state kernel sequences
kernel.private combinators sequences.private ;
+IN: inference.backend
HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
From 6b16f7082257ab897c9d6e9f0a1cb54c618dbc6e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 9 Apr 2008 02:53:29 -0500
Subject: [PATCH 266/288] Try a different strategy
---
.../tools/vocabs/monitor/monitor-tests.factor | 6 +++++
extra/tools/vocabs/monitor/monitor.factor | 26 +++++++++++++------
2 files changed, 24 insertions(+), 8 deletions(-)
create mode 100644 extra/tools/vocabs/monitor/monitor-tests.factor
diff --git a/extra/tools/vocabs/monitor/monitor-tests.factor b/extra/tools/vocabs/monitor/monitor-tests.factor
new file mode 100644
index 0000000000..f1eece91c2
--- /dev/null
+++ b/extra/tools/vocabs/monitor/monitor-tests.factor
@@ -0,0 +1,6 @@
+USING: tools.test tools.vocabs.monitor io.files ;
+IN: tools.vocabs.monitor.tests
+
+[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test
+[ "kernel" ] [ "core/kernel/" path>vocab ] unit-test
+[ "kernel" ] [ "core/kernel/" resource-path path>vocab ] unit-test
diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor
index ada539c60a..b96f76d3ba 100755
--- a/extra/tools/vocabs/monitor/monitor.factor
+++ b/extra/tools/vocabs/monitor/monitor.factor
@@ -11,27 +11,37 @@ IN: tools.vocabs.monitor
: path>vocab-name ( path -- vocab )
dup ".factor" tail? [ parent-directory ] when
- dup [ vocab-dir>vocab-name ] when ;
+ ;
+
+: chop-vocab-root ( path -- path' )
+ "resource:" prepend-path (normalize-path)
+ dup vocab-roots get
+ [ (normalize-path) ] map
+ [ head? ] with find nip
+ ?head drop ;
+
+: path>vocab ( path -- vocab )
+ chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
: changed-vocab ( vocab -- )
dup vocab
[ dup changed-vocabs get-global set-at ] [ drop ] if ;
-: monitor-thread ( path monitor -- )
+: monitor-thread ( monitor -- )
#! On OS X, monitors give us the full path, so we chop it
#! off if its there.
- next-change drop swap ?head drop
- path>vocab-name changed-vocab reset-cache ;
+ next-change drop path>vocab changed-vocab reset-cache ;
-: start-monitor-thread ( root -- )
+: start-monitor-thread ( monitor -- )
#! Silently ignore errors during monitor creation since
#! monitors are not supported on all platforms.
- (normalize-path) dup t <monitor> [ monitor-thread t ] 2curry
- "Vocabulary monitor" spawn-server drop ;
+ [ monitor-thread t ] curry
+ "Vocabulary monitor" spawn-server
+ drop ;
: start-monitor-threads ( -- )
[
- vocab-roots get [ start-monitor-thread ] each
+ "" resource-path t <monitor> start-monitor-thread
H{ } clone changed-vocabs set-global
vocabs [ changed-vocab ] each
] ignore-errors ;
From 17931bb5353c3ea994a1bc15890fa7510e93da7a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 9 Apr 2008 02:56:17 -0500
Subject: [PATCH 267/288] Add command-line switch for disabling the refresh-all
monitor
---
extra/tools/vocabs/monitor/monitor.factor | 20 +++++++++++---------
1 file changed, 11 insertions(+), 9 deletions(-)
diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor
index b96f76d3ba..867c3b2903 100755
--- a/extra/tools/vocabs/monitor/monitor.factor
+++ b/extra/tools/vocabs/monitor/monitor.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: threads io.files io.monitors init kernel
vocabs vocabs.loader tools.vocabs namespaces continuations
-sequences splitting assocs ;
+sequences splitting assocs command-line ;
IN: tools.vocabs.monitor
: vocab-dir>vocab-name ( path -- vocab )
@@ -32,18 +32,20 @@ IN: tools.vocabs.monitor
#! off if its there.
next-change drop path>vocab changed-vocab reset-cache ;
-: start-monitor-thread ( monitor -- )
+: start-monitor-thread ( -- )
#! Silently ignore errors during monitor creation since
#! monitors are not supported on all platforms.
- [ monitor-thread t ] curry
- "Vocabulary monitor" spawn-server
- drop ;
-
-: start-monitor-threads ( -- )
[
- "" resource-path t <monitor> start-monitor-thread
+ "" resource-path t <monitor> [ monitor-thread t ] curry
+ "Vocabulary monitor" spawn-server drop
+
H{ } clone changed-vocabs set-global
+
vocabs [ changed-vocab ] each
] ignore-errors ;
-[ start-monitor-threads ] "tools.vocabs.monitor" add-init-hook
+[
+ "-no-monitors" cli-args get member? [
+ start-monitor-thread
+ ] unless
+] "tools.vocabs.monitor" add-init-hook
From 5204d7065c25c8d73b00d9fa96756f9daac1dc0f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 9 Apr 2008 03:00:15 -0500
Subject: [PATCH 268/288] Improve docs
---
core/inference/inference-docs.factor | 26 +++++++++++++++-----------
1 file changed, 15 insertions(+), 11 deletions(-)
diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor
index a837cfce5e..e32c94ed37 100755
--- a/core/inference/inference-docs.factor
+++ b/core/inference/inference-docs.factor
@@ -79,6 +79,18 @@ ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph"
"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
$nl ;
+ARTICLE: "inference-errors" "Inference errors"
+"Main wrapper for all inference errors:"
+{ $subsection inference-error }
+"Specific inference errors:"
+{ $subsection no-effect }
+{ $subsection literal-expected }
+{ $subsection too-many->r }
+{ $subsection too-many-r> }
+{ $subsection unbalanced-branches-error }
+{ $subsection effect-error }
+{ $subsection recursive-declare-error } ;
+
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
$nl
@@ -93,7 +105,8 @@ $nl
{ $subsection "inference-combinators" }
{ $subsection "inference-branches" }
{ $subsection "inference-recursive" }
-{ $subsection "inference-limitations" }
+{ $subsection "inference-limitations" }
+{ $subsection "inference-errors" }
{ $subsection "dataflow-graphs" }
{ $subsection "compiler-transforms" } ;
@@ -105,16 +118,7 @@ HELP: inference-error
{ $error-description
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
$nl
- "The " { $snippet "error" } " slot contains one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
- { $list
- { $link no-effect }
- { $link literal-expected }
- { $link too-many->r }
- { $link too-many-r> }
- { $link unbalanced-branches-error }
- { $link effect-error }
- { $link recursive-declare-error }
- }
+ "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
} ;
From 20148a1106dafacee41b5fc1f54d7ef76f3dfcc4 Mon Sep 17 00:00:00 2001
From: Eric Mertens <emertens@galois.com>
Date: Wed, 9 Apr 2008 01:20:45 -0700
Subject: [PATCH 269/288] Minor typo corrections in cookbook.factor
---
extra/help/cookbook/cookbook.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor
index 075ce2d0e8..f1d4ac4ca7 100755
--- a/extra/help/cookbook/cookbook.factor
+++ b/extra/help/cookbook/cookbook.factor
@@ -224,7 +224,7 @@ $nl
":errors - print 2 compiler errors."
":warnings - print 50 compiler warnings."
}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erronous stack effect declarations."
+"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
{ $references
"To learn more about the compiler and static stack effect inference, read these articles:"
"compiler"
@@ -259,7 +259,7 @@ $nl
{ $code "#! /usr/bin/env factor -script" }
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
$nl
-"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch supresses compiler messages, and exits Factor when the script finishes."
+"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes."
{ $references
{ }
"cli"
@@ -273,7 +273,7 @@ $nl
$nl
"Keep the following guidelines in mind to avoid losing your sense of balance:"
{ $list
- "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
+ "Simplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
"In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code."
"If your code looks repetitive, factor it some more."
"If after factoring, your code still looks repetitive, introduce combinators."
@@ -285,7 +285,7 @@ $nl
"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
{ "Learn to use the " { $link "inference" } " tool." }
{ "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
- "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution."
+ "Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution."
{ "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
{ "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." }
{ "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." }
@@ -312,7 +312,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
$nl
"Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
{ $code "\"inference\" test" }
- "In general, you should strive to write code with inferrable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
+ "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
From 02886132f3b667d5eb03edb4a97a337d2f1f3ff4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 9 Apr 2008 12:50:58 -0500
Subject: [PATCH 270/288] add [un]set-os-env tests
---
core/system/system-tests.factor | 7 +++++++
1 file changed, 7 insertions(+)
diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor
index 14e34ccb17..d5a48080c2 100755
--- a/core/system/system-tests.factor
+++ b/core/system/system-tests.factor
@@ -12,3 +12,10 @@ os unix? [
[ ] [ "envs" get set-os-envs ] unit-test
[ t ] [ os-envs "envs" get = ] unit-test
] when
+
+[ ] [ "factor-test-key-1" unset-os-env ] unit-test
+[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
+[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
+[ ] [ "factor-test-key-1" unset-os-env ] unit-test
+[ f ] [ "factor-test-key-1" os-env ] unit-test
+
From d748c367c0d373c4f6575931cfecb1f923c98a24 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 9 Apr 2008 14:01:04 -0500
Subject: [PATCH 271/288] ppc64 architecture is now recognized
---
build-support/factor.sh | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/build-support/factor.sh b/build-support/factor.sh
index ea0c35aa83..4bcd9e3086 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -89,6 +89,11 @@ set_md5sum() {
set_gcc() {
case $OS in
openbsd) ensure_program_installed egcc; CC=egcc;;
+ netbsd) if [[ $WORD -eq 64 ]] ; then
+ CC=/usr/pkg/gcc34/bin/gcc
+ else
+ CC=gcc
+ fi ;;
*) CC=gcc;;
esac
}
@@ -185,6 +190,7 @@ find_architecture() {
i386) ARCH=x86;;
i686) ARCH=x86;;
amd64) ARCH=x86;;
+ ppc64) ARCH=ppc;;
*86) ARCH=x86;;
*86_64) ARCH=x86;;
"Power Macintosh") ARCH=ppc;;
From 409d984c3c35a233e25b7e3e90e563bf83e9c3b3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 9 Apr 2008 16:57:21 -0500
Subject: [PATCH 272/288] move os_env from run to os-unix.c/os-windows.c
---
vm/os-unix.c | 10 ++++++++++
vm/os-windows.c | 21 ++++++++++++++++++---
vm/run.c | 10 ----------
3 files changed, 28 insertions(+), 13 deletions(-)
diff --git a/vm/os-unix.c b/vm/os-unix.c
index 2991cde78c..6363ce68a9 100755
--- a/vm/os-unix.c
+++ b/vm/os-unix.c
@@ -85,6 +85,16 @@ DEFINE_PRIMITIVE(read_dir)
dpush(result);
}
+DEFINE_PRIMITIVE(os_env)
+{
+ char *name = unbox_char_string();
+ char *value = getenv(name);
+ if(value == NULL)
+ dpush(F);
+ else
+ box_char_string(value);
+}
+
DEFINE_PRIMITIVE(os_envs)
{
GROWABLE_ARRAY(result);
diff --git a/vm/os-windows.c b/vm/os-windows.c
index 77a32f6f9f..136168807a 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.c
@@ -215,19 +215,34 @@ void sleep_millis(DWORD msec)
Sleep(msec);
}
+DEFINE_PRIMITIVE(os_env)
+{
+ F_CHAR *key = unbox_u16_string();
+ F_CHAR *value = safe_malloc(MAX_UNICODE_PATH);
+ int ret;
+ ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH);
+ if(ret == 0)
+ dpush(F);
+ else
+ dpush(tag_object(from_u16_string(value)));
+ free(value);
+}
+
DEFINE_PRIMITIVE(set_os_env)
{
F_CHAR *key = unbox_u16_string();
REGISTER_C_STRING(key);
F_CHAR *value = unbox_u16_string();
UNREGISTER_C_STRING(key);
- SetEnvironmentVariable(key, value);
+ if(!SetEnvironmentVariable(key, value))
+ general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
}
DEFINE_PRIMITIVE(unset_os_env)
{
- F_CHAR *key = unbox_u16_string();
- SetEnvironmentVariable(key, NULL);
+ if(!SetEnvironmentVariable(unbox_u16_string(), NULL)
+ && GetLastError() != ERROR_ENVVAR_NOT_FOUND)
+ general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
}
DEFINE_PRIMITIVE(set_os_envs)
diff --git a/vm/run.c b/vm/run.c
index 282be0a447..ae0c91d9e6 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -280,16 +280,6 @@ DEFINE_PRIMITIVE(exit)
exit(to_fixnum(dpop()));
}
-DEFINE_PRIMITIVE(os_env)
-{
- char *name = unbox_char_string();
- char *value = getenv(name);
- if(value == NULL)
- dpush(F);
- else
- box_char_string(value);
-}
-
DEFINE_PRIMITIVE(eq)
{
CELL lhs = dpop();
From 2da9aa9d18f529344a057f140aac10e2da96b3af Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 9 Apr 2008 16:58:55 -0500
Subject: [PATCH 273/288] Fix Linux/PPC port
---
vm/os-linux-ppc.h | 8 ++++++++
vm/os-macosx.h | 8 +++++++-
vm/os-unix-ucontext.h | 7 -------
vm/platform.h | 2 --
4 files changed, 15 insertions(+), 10 deletions(-)
delete mode 100644 vm/os-unix-ucontext.h
diff --git a/vm/os-linux-ppc.h b/vm/os-linux-ppc.h
index 86f0509e38..eb28af53e4 100644
--- a/vm/os-linux-ppc.h
+++ b/vm/os-linux-ppc.h
@@ -1,4 +1,12 @@
+#include <ucontext.h>
+
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
+}
+
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
diff --git a/vm/os-macosx.h b/vm/os-macosx.h
index 4c35087752..701bb8da01 100644
--- a/vm/os-macosx.h
+++ b/vm/os-macosx.h
@@ -15,4 +15,10 @@ DLLEXPORT void c_to_factor_toplevel(CELL quot);
#ifndef environ
extern char ***_NSGetEnviron(void);
#define environ (*_NSGetEnviron())
-#endif
\ No newline at end of file
+#endif
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return ucontext->uc_stack.ss_sp;
+}
diff --git a/vm/os-unix-ucontext.h b/vm/os-unix-ucontext.h
deleted file mode 100644
index 9ed0620a83..0000000000
--- a/vm/os-unix-ucontext.h
+++ /dev/null
@@ -1,7 +0,0 @@
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return ucontext->uc_stack.ss_sp;
-}
diff --git a/vm/platform.h b/vm/platform.h
index a8c8ba756f..2f97cb9d1d 100644
--- a/vm/platform.h
+++ b/vm/platform.h
@@ -27,7 +27,6 @@
#include "os-unix.h"
#ifdef __APPLE__
- #include "os-unix-ucontext.h"
#include "os-macosx.h"
#include "mach_signal.h"
@@ -84,7 +83,6 @@
#if defined(FACTOR_X86)
#include "os-linux-x86.32.h"
#elif defined(FACTOR_PPC)
- #include "os-unix-ucontext.h"
#include "os-linux-ppc.h"
#elif defined(FACTOR_ARM)
#include "os-linux-arm.h"
From 9373df5c4c5614a4a45afa215b26d249d1390611 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@vista64.(none)>
Date: Wed, 9 Apr 2008 17:04:09 -0500
Subject: [PATCH 274/288] Fix -generations=1
---
vm/data_gc.h | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/vm/data_gc.h b/vm/data_gc.h
index d3b8b6e39e..2490ed8805 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -315,7 +315,7 @@ INLINE void* allot_object(CELL type, CELL a)
{
CELL *object;
- if(nursery->size - ALLOT_BUFFER_ZONE > a)
+ if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a)
{
/* If there is insufficient room, collect the nursery */
if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
From f6e73abc0249e31bbd97918e285ccc851a043528 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@vista64.(none)>
Date: Wed, 9 Apr 2008 19:30:54 -0500
Subject: [PATCH 275/288] Redo refresh-all
---
core/vocabs/loader/loader-tests.factor | 2 +
extra/tools/vocabs/monitor/monitor.factor | 7 +-
extra/tools/vocabs/vocabs.factor | 116 ++++++++++++++--------
3 files changed, 80 insertions(+), 45 deletions(-)
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 1191594fe5..45b0d6b019 100755
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -110,6 +110,8 @@ IN: vocabs.loader.tests
] with-compilation-unit
] unit-test
+[ ] [ "vocabs.loader.test.b" changed-vocab ] unit-test
+
[ ] [ "vocabs.loader.test.b" refresh ] unit-test
[ 3 ] [ "count-me" get-global ] unit-test
diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor
index 867c3b2903..826d410480 100755
--- a/extra/tools/vocabs/monitor/monitor.factor
+++ b/extra/tools/vocabs/monitor/monitor.factor
@@ -10,8 +10,7 @@ IN: tools.vocabs.monitor
{ { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;
: path>vocab-name ( path -- vocab )
- dup ".factor" tail? [ parent-directory ] when
- ;
+ dup ".factor" tail? [ parent-directory ] when ;
: chop-vocab-root ( path -- path' )
"resource:" prepend-path (normalize-path)
@@ -23,10 +22,6 @@ IN: tools.vocabs.monitor
: path>vocab ( path -- vocab )
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
-: changed-vocab ( vocab -- )
- dup vocab
- [ dup changed-vocabs get-global set-at ] [ drop ] if ;
-
: monitor-thread ( monitor -- )
#! On OS X, monitors give us the full path, so we chop it
#! off if its there.
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index 825d2a6329..211b396c50 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -32,43 +32,6 @@ IN: tools.vocabs
[ vocab-tests % ] tri
] { } make ;
-: source-modified? ( path -- ? )
- dup source-files get at [
- dup source-file-path
- dup exists? [
- utf8 file-lines lines-crc32
- swap source-file-checksum = not
- ] [
- 2drop f
- ] if
- ] [
- exists?
- ] ?if ;
-
-: modified ( seq quot -- seq )
- [ dup ] swap compose { } map>assoc
- [ nip ] assoc-subset
- [ nip source-modified? ] assoc-subset keys ; inline
-
-: modified-sources ( vocabs -- seq )
- [ vocab-source-path ] modified ;
-
-: modified-docs ( vocabs -- seq )
- [ vocab-docs-path ] modified ;
-
-SYMBOL: changed-vocabs
-
-[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
-
-: filter-changed ( vocabs -- vocabs' )
- changed-vocabs get [
- [ delete-at* nip ] curry subset
- ] when* ;
-
-: to-refresh ( prefix -- modified-sources modified-docs )
- child-vocabs filter-changed
- [ modified-sources ] [ modified-docs ] bi ;
-
: vocab-heading. ( vocab -- )
nl
"==== " write
@@ -95,12 +58,87 @@ SYMBOL: failures
failures get
] with-compiler-errors ;
-: do-refresh ( modified-sources modified-docs -- )
+: source-modified? ( path -- ? )
+ dup source-files get at [
+ dup source-file-path
+ dup exists? [
+ utf8 file-lines lines-crc32
+ swap source-file-checksum = not
+ ] [
+ 2drop f
+ ] if
+ ] [
+ exists?
+ ] ?if ;
+
+SYMBOL: changed-vocabs
+
+[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
+
+: changed-vocab ( vocab -- )
+ dup vocab
+ [ dup changed-vocabs get-global set-at ] [ drop ] if ;
+
+: unchanged-vocab ( vocab -- )
+ changed-vocabs get-global delete-at ;
+
+: unchanged-vocabs ( vocabs -- )
+ [ unchanged-vocab ] each ;
+
+: filter-changed ( vocabs -- vocabs' )
+ changed-vocabs get [
+ [ key? ] curry subset
+ ] when* ;
+
+SYMBOL: modified-sources
+SYMBOL: modified-docs
+
+: (to-refresh) ( vocab variable loaded? path -- )
+ dup [
+ swap [
+ pick changed-vocabs get key? [
+ source-modified? [ get push ] [ 2drop ] if
+ ] [ 3drop ] if
+ ] [ drop get push ] if
+ ] [ 2drop 2drop ] if ;
+
+: to-refresh ( prefix -- modified-sources modified-docs unchanged )
+ [
+ V{ } clone modified-sources set
+ V{ } clone modified-docs set
+
+ child-vocabs [
+ [
+ [
+ [ modified-sources ]
+ [ vocab-source-loaded? ]
+ [ vocab-source-path ]
+ tri (to-refresh)
+ ] [
+ [ modified-docs ]
+ [ vocab-docs-loaded? ]
+ [ vocab-docs-path ]
+ tri (to-refresh)
+ ] bi
+ ] each
+
+ modified-sources get
+ modified-docs get
+ ]
+ [ modified-sources get modified-docs get append swap seq-diff ] bi
+ ] with-scope ;
+
+: do-refresh ( modified-sources modified-docs unchanged -- )
+ unchanged-vocabs
[
[ [ f swap set-vocab-source-loaded? ] each ]
[ [ f swap set-vocab-docs-loaded? ] each ] bi*
]
- [ append prune require-all load-failures. ] 2bi ;
+ [
+ append prune
+ [ unchanged-vocabs ]
+ [ require-all load-failures. ] bi
+ ] 2bi ;
: refresh ( prefix -- ) to-refresh do-refresh ;
From 0e723f64cc2cd97e767cccab9f4b3a8ecb197385 Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Wed, 9 Apr 2008 19:47:10 -0500
Subject: [PATCH 276/288] Add unit tests for monitors
---
extra/io/monitors/monitors-tests.factor | 29 +++++++++++++++++++++++++
1 file changed, 29 insertions(+)
create mode 100644 extra/io/monitors/monitors-tests.factor
diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor
new file mode 100644
index 0000000000..fb687f6876
--- /dev/null
+++ b/extra/io/monitors/monitors-tests.factor
@@ -0,0 +1,29 @@
+IN: io.monitors.tests
+USING: io.monitors tools.test io.files system sequences
+continuations namespaces concurrency.count-downs kernel io
+threads calendar ;
+
+os { winnt macosx linux } member? [
+ [ "monitor-test" temp-file delete-tree ] ignore-errors
+
+ [ ] [ "monitor-test" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
+
+ [ ] [ 1 <count-down> "c" set ] unit-test
+
+ [ ] [
+ [
+ [
+ "m" get next-change drop
+ dup print flush
+ "test.txt" tail? not
+ ] [ ] [ ] while
+ "c" get count-down
+ ] "Monitor test thread" spawn drop
+ ] unit-test
+
+ [ ] [ "monitor-test/test.txt" touch-file ] unit-test
+
+ [ ] [ "c" get 30 seconds await-timeout ] unit-test
+] when
From b63edfd493bc13c424edd81f96752918115610a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@vista64.(none)>
Date: Wed, 9 Apr 2008 19:54:48 -0500
Subject: [PATCH 277/288] Add unit tests for monitors
---
extra/io/monitors/monitors-tests.factor | 15 ++++++++++-----
1 file changed, 10 insertions(+), 5 deletions(-)
diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor
index fb687f6876..4bb5db9f0a 100644
--- a/extra/io/monitors/monitors-tests.factor
+++ b/extra/io/monitors/monitors-tests.factor
@@ -1,29 +1,34 @@
IN: io.monitors.tests
USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io
-threads calendar ;
+threads calendar prettyprint ;
os { winnt macosx linux } member? [
[ "monitor-test" temp-file delete-tree ] ignore-errors
- [ ] [ "monitor-test" temp-file make-directory ] unit-test
+ [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
+ [ ] [ 1 <count-down> "b" set ] unit-test
+
[ ] [ 1 <count-down> "c" set ] unit-test
[ ] [
[
+ "b" get count-down
[
"m" get next-change drop
- dup print flush
- "test.txt" tail? not
+ dup print flush right-trim-separators
+ "xyz" tail? not
] [ ] [ ] while
"c" get count-down
] "Monitor test thread" spawn drop
] unit-test
- [ ] [ "monitor-test/test.txt" touch-file ] unit-test
+ [ ] [ "b" get await ] unit-test
+
+ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
[ ] [ "c" get 30 seconds await-timeout ] unit-test
] when
From 48a16b542d0f4e5e23956012194c4fe61d76c6b4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@vista64.(none)>
Date: Wed, 9 Apr 2008 20:14:14 -0500
Subject: [PATCH 278/288] Unit test fixes
---
core/definitions/definitions-tests.factor | 20 --------------------
extra/io/monitors/monitors-tests.factor | 4 ++++
2 files changed, 4 insertions(+), 20 deletions(-)
diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
index 3dc28139ea..b20d81ec7c 100755
--- a/core/definitions/definitions-tests.factor
+++ b/core/definitions/definitions-tests.factor
@@ -2,26 +2,6 @@ IN: definitions.tests
USING: tools.test generic kernel definitions sequences
compiler.units words ;
-TUPLE: combination-1 ;
-
-M: combination-1 perform-combination drop [ ] define ;
-
-M: combination-1 make-default-method 2drop [ "No method" throw ] ;
-
-SYMBOL: generic-1
-
-[
- generic-1 T{ combination-1 } define-generic
-
- object \ generic-1 create-method [ ] define
-] with-compilation-unit
-
-[ ] [
- [
- { combination-1 { object generic-1 } } forget-all
- ] with-compilation-unit
-] unit-test
-
GENERIC: some-generic ( a -- b )
USE: arrays
diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor
index 4bb5db9f0a..7170e824c8 100644
--- a/extra/io/monitors/monitors-tests.factor
+++ b/extra/io/monitors/monitors-tests.factor
@@ -31,4 +31,8 @@ os { winnt macosx linux } member? [
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
[ ] [ "c" get 30 seconds await-timeout ] unit-test
+
+ [ ] [ "m" get dispose ] unit-test
+
+ [ "m" get dispose ] must-fail
] when
From b4c9bbdf805bc79256bc6f21f47d07cac0829251 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 9 Apr 2008 21:01:00 -0500
Subject: [PATCH 279/288] processing: at-fraction
---
extra/processing/processing.factor | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)
diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor
index 02a8325663..0f21634dc8 100644
--- a/extra/processing/processing.factor
+++ b/extra/processing/processing.factor
@@ -8,7 +8,7 @@ USING: kernel namespaces threads combinators sequences arrays
combinators
combinators.lib
combinators.cleave
- rewrite-closures fry accessors
+ rewrite-closures fry accessors newfx
processing.color
processing.gadget ;
@@ -28,6 +28,12 @@ IN: processing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
+
+: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
VAR: fill-color
VAR: stroke-color
@@ -282,7 +288,7 @@ VAR: frame-rate-value
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-VAR: slate
+! VAR: slate
VAR: loop-flag
From a135aa479b9cf2c024e28a746dad0da9dea9093e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 9 Apr 2008 21:01:34 -0500
Subject: [PATCH 280/288] bubble-chamber: Refactoring
---
.../bubble-chamber/bubble-chamber.factor | 207 ++++++++----------
1 file changed, 91 insertions(+), 116 deletions(-)
diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
index 2efa04efad..1a5fa37fa6 100644
--- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
+++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
@@ -32,6 +32,8 @@ IN: processing.gallery.bubble-chamber
: dim ( -- dim ) 1000 ;
+: center ( -- point ) dim 2 / dup {2} ; foldable
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: collision-theta
@@ -73,7 +75,7 @@ VARS: particles muons quarks hadrons axions ;
T{ rgba f 0.47 0.42 0.56 1 }
} ;
-: good-color ( i -- color ) good-colors nth-of ;
+: anti-colors ( -- seq ) good-colors <reversed> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -89,6 +91,26 @@ VARS: particles muons quarks hadrons axions ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
+
+: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: turn ( particle -- particle )
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
+: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
+: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
+: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -120,32 +142,36 @@ TUPLE: muon < particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
+
+: set-good-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ good-colors at-fraction-of >>myc ]
+ [ drop ]
+ if ;
+
+: set-anti-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ anti-colors at-fraction-of >>mya ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
METHOD: collide { muon }
- dim 2 / dup 2array >>pos
- 2 32 [a,b] random >>speed
- 0.0001 0.001 2random >>speed-d
+ center >>pos
+ 2 32 [a,b] random >>speed
+ 0.0001 0.001 2random >>speed-d
collision-theta> -0.1 0.1 2random + >>theta
0 >>theta-d
0 >>theta-dd
- [ dup theta-dd>> abs 0.001 < ]
- [ -0.1 0.1 2random >>theta-dd ]
- [ ]
- while
+ [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
- dup theta>> pi +
- 2 pi * /
- good-colors length 1 - *
- [ ] [ good-colors length >= ] [ 0 < ] tri or
- [ drop ]
- [
- [ good-color >>myc ]
- [ good-colors length swap - 1 - good-color >>mya ]
- bi
- ]
- if
+ set-good-color
+ set-anti-color
drop ;
@@ -163,14 +189,11 @@ METHOD: move { muon }
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
move-by
- [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
- [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
- [ ] [ speed>> ] [ speed-d>> ] tri - >>speed
+ step-theta
+ step-theta-d
+ step-speed-sub
- out-of-bounds?
- [ collide ]
- [ drop ]
- if ;
+ out-of-bounds? [ collide ] [ drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -182,7 +205,7 @@ TUPLE: quark < particle ;
METHOD: collide { quark }
- dim 2 / dup 2array >>pos
+ center >>pos
collision-theta> -0.11 0.11 2random + >>theta
0.5 3.0 2random >>speed
@@ -190,10 +213,7 @@ METHOD: collide { quark }
0 >>theta-d
0 >>theta-dd
- [ dup theta-dd>> abs 0.00001 < ]
- [ -0.001 0.001 2random >>theta-dd ]
- [ ]
- while
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
drop ;
@@ -208,26 +228,20 @@ METHOD: move { quark }
[ ] [ vel>> ] bi move-by
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel
+ turn
- [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
- [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
- [ ] [ speed>> ] [ speed-d>> ] tri * >>speed
+ step-theta
+ step-theta-d
+ step-speed-mul
- ! 1000 random 997 >
- 3/1000 chance
+ 1000 random 997 >
[
dup speed>> neg >>speed
2 over speed-d>> - >>speed-d
]
when
- out-of-bounds?
- [ collide ]
- [ drop ]
- if ;
+ out-of-bounds? [ collide ] [ drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -239,18 +253,14 @@ TUPLE: hadron < particle ;
METHOD: collide { hadron }
- dim 2 / dup 2array >>pos
- 2 pi * 1random >>theta
- 0.5 3.5 2random >>speed
-
+ center >>pos
+ 2 pi * 1random >>theta
+ 0.5 3.5 2random >>speed
0.996 1.001 2random >>speed-d
0 >>theta-d
0 >>theta-dd
- [ dup theta-dd>> abs 0.00001 < ]
- [ -0.001 0.001 2random >>theta-dd ]
- [ ]
- while
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
0 1 0 <rgb> >>myc
@@ -268,34 +278,22 @@ METHOD: move { hadron }
dup vel>> move-by
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel
+ turn
- [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
- [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
- [ ] [ speed>> ] [ speed-d>> ] tri * >>speed
+ step-theta
+ step-theta-d
+ step-speed-mul
- ! 1000 random 997 >
- 3/1000 chance
+ 1000 random 997 >
[
1.0 >>speed-d
0.00001 >>theta-dd
- ! 100 random 70 >
- 30/100 chance
- [
- dim 2 / dup 2array >>pos
- dup collide
- ]
- when
+ 100 random 70 > [ dup collide ] when
]
when
- out-of-bounds?
- [ collide ]
- [ drop ]
- if ;
+ out-of-bounds? [ collide ] [ drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -307,82 +305,59 @@ TUPLE: axion < particle ;
METHOD: collide { axion }
- dim 2 / dup 2array >>pos
- 2 pi * 1random >>theta
- 1.0 6.0 2random >>speed
-
+ center >>pos
+ 2 pi * 1random >>theta
+ 1.0 6.0 2random >>speed
0.998 1.000 2random >>speed-d
0 >>theta-d
0 >>theta-dd
- [ dup theta-dd>> abs 0.00001 < ]
- [ -0.001 0.001 2random >>theta-dd ]
- [ ]
- while
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
+
+: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
+: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
+
+: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
+: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
METHOD: move { axion }
{ 0.06 0.59 } stroke
dup pos>> point
- 1 4 [a,b]
- [| dy |
- 1 30 dy 6 * - 255.0 / 2array stroke
- dup pos>> 0 dy neg 2array v+ point
- ] with-locals
- each
-
- 1 4 [a,b]
- [| dy |
- 0 30 dy 6 * - 255.0 / 2array stroke
- dup pos>> dy v+y point
- ] with-locals
- each
+ 1 4 [a,b] [ axion-white axion-point- ] each
+ 1 4 [a,b] [ axion-black axion-point+ ] each
dup vel>> move-by
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel
+ turn
- [ ] [ theta>> ] [ theta-d>> ] tri + >>theta
- [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
- [ ] [ speed>> ] [ speed-d>> ] tri * >>speed
+ step-theta
+ step-theta-d
+ step-speed-mul
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
- ! 1000 random 996 >
- 4/1000 chance
+ 1000 random 996 >
[
- dup speed>> neg >>speed
+ dup speed>> neg >>speed
dup speed-d>> neg 2 + >>speed-d
- ! 100 random 30 >
- 70/100 chance
- [
- dim 2 / dup 2array >>pos
- collide
- ]
- [ drop ]
- if
+ 100 random 30 > [ collide ] [ drop ] if
]
[ drop ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : draw ( -- )
-
-! boom>
-! [ particles> [ move ] each ]
-! when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: collide-all ( -- )
2 pi * 1random >collision-theta
From 2a85901ccaa040bf0481108c43b12f22e4192dd7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 10 Apr 2008 19:35:06 -0500
Subject: [PATCH 281/288] add some windows messages
---
extra/windows/messages/messages.factor | 22 ++++++++++++++++++++++
1 file changed, 22 insertions(+)
diff --git a/extra/windows/messages/messages.factor b/extra/windows/messages/messages.factor
index 733071d197..3b0db96d63 100644
--- a/extra/windows/messages/messages.factor
+++ b/extra/windows/messages/messages.factor
@@ -1001,3 +1001,25 @@ windows-messages set-global
: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline
: LM_SETITEM WM_USER HEX: 0302 + ; inline
: LM_GETITEM WM_USER HEX: 0303 + ; inline
+
+
+: WA_INACTIVE 0 ; inline
+: WA_ACTIVE 1 ; inline
+: WA_CLICKACTIVE 2 ; inline
+
+: SC_SIZE HEX: f000 ; inline
+: SC_MOVE HEX: f010 ; inline
+: SC_MINIMIZE HEX: f020 ; inline
+: SC_MAXIMIZE HEX: f030 ; inline
+: SC_NEXTWINDOW HEX: f040 ; inline
+: SC_PREVWINDOW HEX: f050 ; inline
+: SC_CLOSE HEX: f060 ; inline
+: SC_VSCROLL HEX: f070 ; inline
+: SC_HSCROLL HEX: f080 ; inline
+: SC_MOUSEMENU HEX: f090 ; inline
+: SC_KEYMENU HEX: f100 ; inline
+: SC_ARRANGE HEX: f110 ; inline
+: SC_RESTORE HEX: f120 ; inline
+: SC_TASKLIST HEX: f130 ; inline
+: SC_SCREENSAVE HEX: f140 ; inline
+: SC_HOTKEY HEX: f150 ; inline
From 2cefe124d6c9c05b2b2dea665e7609ed63b85b3a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 10 Apr 2008 21:17:23 -0500
Subject: [PATCH 282/288] try not to render to factor windows when they're
minimized
---
extra/ui/windows/windows.factor | 14 ++++++++++++--
1 file changed, 12 insertions(+), 2 deletions(-)
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index e0c9f24122..0adfc676f8 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -7,7 +7,7 @@ vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types windows.nt
windows threads libc combinators continuations command-line
shuffle opengl ui.render unicode.case ascii math.bitfields
-locals symbols ;
+locals symbols accessors ;
IN: ui.windows
SINGLETON: windows-ui-backend
@@ -203,8 +203,18 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
wParam keystroke>gesture <key-up>
hWnd window-focus send-gesture drop ;
+: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ >r 4dup r> 2nip nip
+ swap window set-world-active? DefWindowProc ;
+
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
- dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
+ {
+ { [ over SC_MINIMIZE = ] [ f set-window-active ] }
+ { [ over SC_RESTORE = ] [ t set-window-active ] }
+ { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
+ { [ dup alpha? ] [ 4drop 0 ] }
+ { [ t ] [ DefWindowProc ] }
+ } cond ;
: cleanup-window ( handle -- )
dup win-title [ free ] when*
From a1b050fd88f5b3d3ba0a5b031dd1156d318e5b6a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 10 Apr 2008 21:49:08 -0500
Subject: [PATCH 283/288] Fix interactor
---
.../tools/interactor/interactor-tests.factor | 25 ++++++++++++++++++-
extra/ui/tools/interactor/interactor.factor | 4 ++-
2 files changed, 27 insertions(+), 2 deletions(-)
diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor
index fe0a654217..94953f9c72 100755
--- a/extra/ui/tools/interactor/interactor-tests.factor
+++ b/extra/ui/tools/interactor/interactor-tests.factor
@@ -1,4 +1,27 @@
IN: ui.tools.interactor.tests
-USING: ui.tools.interactor tools.test ;
+USING: ui.tools.interactor ui.gadgets.panes namespaces
+ui.gadgets.editors concurrency.promises threads listener
+tools.test kernel calendar ;
\ <interactor> must-infer
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[
+ "interactor" get stream-read-quot "promise" get fulfill
+] "Interactor test" spawn drop
+
+! This should not throw an exception
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+
+[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 8232094e76..86ba51df95 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -138,7 +138,9 @@ M: interactor stream-read-partial
drop parse-lines-interactive
] [
2nip
- dup delegate unexpected-eof? [ drop f ] when
+ dup parse-error? [
+ dup error>> unexpected-eof? [ drop f ] when
+ ] when
] recover ;
: handle-interactive ( lines interactor -- quot/f ? )
From 039c344e8745bc0f1a5afb975c0c57eb14eb1ea8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 10 Apr 2008 22:02:23 -0500
Subject: [PATCH 284/288] Fix unit test failure on BSD
---
extra/tools/vocabs/vocabs-tests.factor | 8 ++++++++
extra/tools/vocabs/vocabs.factor | 6 +++---
2 files changed, 11 insertions(+), 3 deletions(-)
create mode 100644 extra/tools/vocabs/vocabs-tests.factor
diff --git a/extra/tools/vocabs/vocabs-tests.factor b/extra/tools/vocabs/vocabs-tests.factor
new file mode 100644
index 0000000000..ae74d516e4
--- /dev/null
+++ b/extra/tools/vocabs/vocabs-tests.factor
@@ -0,0 +1,8 @@
+IN: tools.vocabs.tests
+USING: tools.test tools.vocabs namespaces continuations ;
+
+[ ] [
+ changed-vocabs get-global
+ f changed-vocabs set-global
+ [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
+] unit-test
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index 211b396c50..371bbc7813 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -76,11 +76,11 @@ SYMBOL: changed-vocabs
[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
: changed-vocab ( vocab -- )
- dup vocab
- [ dup changed-vocabs get-global set-at ] [ drop ] if ;
+ dup vocab changed-vocabs get and
+ [ dup changed-vocabs get set-at ] [ drop ] if ;
: unchanged-vocab ( vocab -- )
- changed-vocabs get-global delete-at ;
+ changed-vocabs get delete-at ;
: unchanged-vocabs ( vocabs -- )
[ unchanged-vocab ] each ;
From 1214f7e71334b2e355488471231b2f27d6c759ea Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 10 Apr 2008 22:31:12 -0500
Subject: [PATCH 285/288] newfx: Move to generics for getters and setters
---
extra/newfx/newfx.factor | 91 +++++++++++++++++++++++++++++++---------
1 file changed, 72 insertions(+), 19 deletions(-)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index b123fef2a3..3df3b3ed05 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -1,56 +1,109 @@
USING: kernel sequences assocs qualified circular ;
+USING: math multi-methods ;
+
QUALIFIED: sequences
+QUALIFIED: assocs
QUALIFIED: circular
IN: newfx
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Now, we can see a new world coming into view.
! A world in which there is the very real prospect of a new world order.
!
! - George Herbert Walker Bush
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: at ( col key -- val )
+GENERIC: of ( key col -- val )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-at ( seq i -- val ) swap nth ;
-: nth-of ( i seq -- val ) nth ;
+GENERIC: grab ( col key -- col val )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-is ( seq i val -- seq ) swap pick set-nth ;
-: is-nth ( seq val i -- seq ) pick set-nth ;
+GENERIC: is ( col key val -- col )
+GENERIC: as ( col val key -- col )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ;
-: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ;
+GENERIC: is-of ( key val col -- col )
+GENERIC: as-of ( val key col -- col )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: mutate-nth ( seq i val -- ) swap rot set-nth ;
-: mutate-nth-at ( seq val i -- ) rot set-nth ;
-
-: mutate-nth-of ( i val seq -- ) swapd set-nth ;
-: mutate-nth-at-of ( val i seq -- ) set-nth ;
+GENERIC: mutate-at ( col key val -- )
+GENERIC: mutate-as ( col val key -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: at-key ( tbl key -- val ) swap at ;
-: key-of ( key tbl -- val ) at ;
+GENERIC: at-mutate ( key val col -- )
+GENERIC: as-mutate ( val key col -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! sequence
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at { sequence number } swap nth ;
+METHOD: of { number sequence } nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: key-is ( tbl key val -- tbl ) swap pick set-at ;
-: is-key ( tbl val key -- tbl ) pick set-at ;
+METHOD: grab { sequence number } dupd swap nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: mutate-key ( tbl key val -- ) swap rot set-at ;
-: mutate-at-key ( tbl val key -- ) rot set-at ;
+METHOD: is { sequence number object } swap pick set-nth ;
+METHOD: as { sequence object number } pick set-nth ;
-: mutate-key-of ( key val tbl -- ) swapd set-at ;
-: mutate-at-key-of ( val key tbl -- ) set-at ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is-of { number object sequence } dup >r swapd set-nth r> ;
+METHOD: as-of { object number sequence } dup >r set-nth r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { sequence number object } swap rot set-nth ;
+METHOD: mutate-as { sequence object number } rot set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at-mutate { number object sequence } swapd set-nth ;
+METHOD: as-mutate { object number sequence } set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! assoc
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at { assoc object } swap assocs:at ;
+METHOD: of { object assoc } assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: grab { assoc object } dupd swap assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is { assoc object object } swap pick set-at ;
+METHOD: as { assoc object object } pick set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is-of { object object assoc } dup >r swapd set-at r> ;
+METHOD: as-of { object object assoc } dup >r set-at r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { assoc object object } swap rot set-at ;
+METHOD: mutate-as { assoc object object } rot set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at-mutate { object object assoc } swapd set-at ;
+METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From c71a46d15e23881c57a4359bf28e703ab0ea3978 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 10 Apr 2008 22:33:22 -0500
Subject: [PATCH 286/288] Remove bubble-chamber from gallery (moving to root)
---
.../bubble-chamber/bubble-chamber-docs.factor | 97 ----
.../bubble-chamber/bubble-chamber.factor | 428 ------------------
2 files changed, 525 deletions(-)
delete mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor
delete mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber.factor
diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor
deleted file mode 100644
index 21a845e089..0000000000
--- a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor
+++ /dev/null
@@ -1,97 +0,0 @@
-
-USING: help.syntax help.markup ;
-
-IN: processing.gallery.bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: muon
-
- { $class-description
- "The muon is a colorful particle with an entangled friend."
- "It draws both itself and its horizontally symmetric partner."
- "A high range of speed and almost no speed decay allow the"
- "muon to reach the extents of the window, often forming rings"
- "where theta has decayed but speed remains stable. The result"
- "is color almost everywhere in the general direction of collision,"
- "stabilized into fuzzy rings." } ;
-
-HELP: quark
-
- { $class-description
- "The quark draws as a translucent black. Their large numbers"
- "create fields of blackness overwritten only by the glowing shadows of "
- "Hadrons. "
- "quarks are allowed to accelerate away with speed decay values above 1.0. "
- "Each quark has an entangled friend. Both particles are drawn identically,"
- "mirrored along the y-axis." } ;
-
-HELP: hadron
-
- { $class-description
- "Hadrons collide from totally random directions. "
- "Those hadrons that do not exit the drawing area, "
- "tend to stabilize into perfect circular orbits. "
- "Each hadron draws with a slight glowing emboss. "
- "The hadron itself is not drawn." } ;
-
-HELP: axion
-
- { $class-description
- "The axion particle draws a bold black path. Axions exist "
- "in a slightly higher dimension and as such are drawn with "
- "elevated embossed shadows. Axions are quick to stabilize "
- "and fall into single pixel orbits axions automatically "
- "recollide themselves after stabilizing." } ;
-
-{ muon quark hadron axion } related-words
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber" "Bubble Chamber"
-
- { $subsection "bubble-chamber-introduction" }
- { $subsection "bubble-chamber-particles" }
- { $subsection "bubble-chamber-author" }
- { $subsection "bubble-chamber-running" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-introduction" "Introduction"
-
-"The Bubble Chamber is a generative painting system of imaginary "
-"colliding particles. A single super-massive collision produces a "
-"discrete universe of four particle types. Particles draw their "
-"positions over time as pixel exposures. " ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-particles" "Particles"
-
-"Four types of particles exist. The behavior and graphic appearance of "
-"each particle type is unique."
-
- { $subsection muon }
- { $subsection quark }
- { $subsection hadron }
- { $subsection axion } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-author" "Author"
-
- "Bubble Chamber was created by Jared Tarbell. "
- "It was originally implemented in Processing. "
- "It was ported to Factor by Eduardo Cavazos. "
- "The original work is on display here: "
- { $url
- "http://www.complexification.net/gallery/machines/bubblechamber/" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber-running" "How to use"
-
- "After you run the vocabulary, a window will appear. Click the "
- "mouse in a random area to fire 11 particles of each type. "
- "Another way to fire particles is to press the "
- "spacebar. This fires all the particles." ;
\ No newline at end of file
diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
deleted file mode 100644
index 1a5fa37fa6..0000000000
--- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor
+++ /dev/null
@@ -1,428 +0,0 @@
-
-USING: kernel namespaces sequences combinators arrays threads
-
- math
- math.libm
- math.vectors
- math.ranges
- math.constants
- math.functions
- math.points
-
- ui
- ui.gadgets
-
- random accessors multi-methods
- combinators.cleave
- vars locals
-
- newfx
-
- processing
- processing.gadget
- processing.color ;
-
-IN: processing.gallery.bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dim ( -- dim ) 1000 ;
-
-: center ( -- point ) dim 2 / dup {2} ; foldable
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: collision-theta
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: boom
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VARS: particles muons quarks hadrons axions ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: good-colors ( -- seq )
- {
- T{ rgba f 0.23 0.14 0.17 1 }
- T{ rgba f 0.23 0.14 0.15 1 }
- T{ rgba f 0.21 0.14 0.15 1 }
- T{ rgba f 0.51 0.39 0.33 1 }
- T{ rgba f 0.49 0.33 0.20 1 }
- T{ rgba f 0.55 0.45 0.32 1 }
- T{ rgba f 0.69 0.63 0.51 1 }
- T{ rgba f 0.64 0.39 0.18 1 }
- T{ rgba f 0.73 0.42 0.20 1 }
- T{ rgba f 0.71 0.45 0.29 1 }
- T{ rgba f 0.79 0.45 0.22 1 }
- T{ rgba f 0.82 0.56 0.34 1 }
- T{ rgba f 0.88 0.72 0.49 1 }
- T{ rgba f 0.85 0.69 0.40 1 }
- T{ rgba f 0.96 0.92 0.75 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.85 0.82 0.69 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.82 0.82 0.79 1 }
- T{ rgba f 0.65 0.69 0.67 1 }
- T{ rgba f 0.53 0.60 0.55 1 }
- T{ rgba f 0.57 0.53 0.68 1 }
- T{ rgba f 0.47 0.42 0.56 1 }
- } ;
-
-: anti-colors ( -- seq ) good-colors <reversed> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x ( particle -- x ) pos>> first ;
-: y ( particle -- x ) pos>> second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: out-of-bounds? ( particle -- particle ? )
- dup
- { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
- or or or ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
-
-: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: turn ( particle -- particle )
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
-: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
-: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
-: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: initialize-particle ( particle -- particle )
-
- 0 0 {2} >>pos
- 0 0 {2} >>vel
-
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- 0 0 0 1 <rgba> >>myc
- 0 0 0 1 <rgba> >>mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: collide ( particle -- )
-GENERIC: move ( particle -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: muon < particle ;
-
-: <muon> ( -- muon ) muon construct-empty initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
-
-: set-good-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ good-colors at-fraction-of >>myc ]
- [ drop ]
- if ;
-
-: set-anti-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ anti-colors at-fraction-of >>mya ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { muon }
-
- center >>pos
- 2 32 [a,b] random >>speed
- 0.0001 0.001 2random >>speed-d
-
- collision-theta> -0.1 0.1 2random + >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
-
- set-good-color
- set-anti-color
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { muon }
-
- dup myc>> 0.16 >>alpha stroke
- dup pos>> point
-
- dup mya>> 0.16 >>alpha stroke
- dup pos>> first2 >r dim swap - r> 2array point
-
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- move-by
-
- step-theta
- step-theta-d
- step-speed-sub
-
- out-of-bounds? [ collide ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: quark < particle ;
-
-: <quark> ( -- quark ) quark construct-empty initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { quark }
-
- center >>pos
- collision-theta> -0.11 0.11 2random + >>theta
- 0.5 3.0 2random >>speed
-
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { quark }
-
- dup myc>> 0.13 >>alpha stroke
- dup pos>> point
-
- dup pos>> first2 >r dim swap - r> 2array point
-
- [ ] [ vel>> ] bi move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- dup speed>> neg >>speed
- 2 over speed-d>> - >>speed-d
- ]
- when
-
- out-of-bounds? [ collide ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: hadron < particle ;
-
-: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { hadron }
-
- center >>pos
- 2 pi * 1random >>theta
- 0.5 3.5 2random >>speed
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
- 0 1 0 <rgb> >>myc
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { hadron }
-
- { 1 0.11 } stroke
- dup pos>> 1 v-y point
-
- { 0 0.11 } stroke
- dup pos>> 1 v+y point
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- 1.0 >>speed-d
- 0.00001 >>theta-dd
-
- 100 random 70 > [ dup collide ] when
- ]
- when
-
- out-of-bounds? [ collide ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: axion < particle ;
-
-: <axion> ( -- axion ) axion construct-empty initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { axion }
-
- center >>pos
- 2 pi * 1random >>theta
- 1.0 6.0 2random >>speed
- 0.998 1.000 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
-
-: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
-: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
-
-: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
-: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { axion }
-
- { 0.06 0.59 } stroke
- dup pos>> point
-
- 1 4 [a,b] [ axion-white axion-point- ] each
- 1 4 [a,b] [ axion-black axion-point+ ] each
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
-
- 1000 random 996 >
- [
- dup speed>> neg >>speed
- dup speed-d>> neg 2 + >>speed-d
-
- 100 random 30 > [ collide ] [ drop ] if
- ]
- [ drop ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-all ( -- )
-
- 2 pi * 1random >collision-theta
-
- particles> [ collide ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-one ( -- )
-
- dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
-
- hadrons> random collide
- quarks> random collide
- muons> random collide ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse-pressed ( -- )
- boom on
- 1 background ! kludge
- 11 [ drop collide-one ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: key-released ( -- )
- key " " =
- [
- boom on
- 1 background
- collide-all
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bubble-chamber ( -- )
-
- 1000 1000 size*
-
- [
- 1 background
- no-stroke
-
- 1789 [ drop <muon> ] map >muons
- 1300 [ drop <quark> ] map >quarks
- 1000 [ drop <hadron> ] map >hadrons
- 111 [ drop <axion> ] map >axions
-
- muons> quarks> hadrons> axions> 3append append >particles
-
- collide-one
- ] setup
-
- [
- boom>
- [ particles> [ move ] each ]
- when
- ] draw
-
- [ mouse-pressed ] button-down
- [ key-released ] key-up
-
- ;
-
-: go ( -- ) [ bubble-chamber run ] with-ui ;
-
-MAIN: go
\ No newline at end of file
From bbf5234a9e1442d0561bc9b5e54ac99b7e742f0c Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 10 Apr 2008 22:34:26 -0500
Subject: [PATCH 287/288] processing: use 'at'
---
extra/processing/processing.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor
index 0f21634dc8..e089b15e7e 100644
--- a/extra/processing/processing.factor
+++ b/extra/processing/processing.factor
@@ -28,7 +28,9 @@ IN: processing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
+! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
+
+: at-fraction ( seq fraction -- val ) over length 1- * at ;
: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
From cd9c92d9011b6675a2c4607c5cbece8ed051cbfa Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 10 Apr 2008 22:34:43 -0500
Subject: [PATCH 288/288] bubble-chamber: big refactoring
---
extra/bubble-chamber/bubble-chamber.factor | 88 +++++++++++++++++++
extra/bubble-chamber/common/common.factor | 12 +++
.../particle/axion/axion.factor | 67 ++++++++++++++
.../particle/hadron/hadron.factor | 60 +++++++++++++
.../particle/muon/colors/colors.factor | 53 +++++++++++
.../bubble-chamber/particle/muon/muon.factor | 62 +++++++++++++
extra/bubble-chamber/particle/particle.factor | 68 ++++++++++++++
.../particle/quark/quark.factor | 53 +++++++++++
8 files changed, 463 insertions(+)
create mode 100644 extra/bubble-chamber/bubble-chamber.factor
create mode 100644 extra/bubble-chamber/common/common.factor
create mode 100644 extra/bubble-chamber/particle/axion/axion.factor
create mode 100644 extra/bubble-chamber/particle/hadron/hadron.factor
create mode 100644 extra/bubble-chamber/particle/muon/colors/colors.factor
create mode 100644 extra/bubble-chamber/particle/muon/muon.factor
create mode 100644 extra/bubble-chamber/particle/particle.factor
create mode 100644 extra/bubble-chamber/particle/quark/quark.factor
diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor
new file mode 100644
index 0000000000..4b0db46c35
--- /dev/null
+++ b/extra/bubble-chamber/bubble-chamber.factor
@@ -0,0 +1,88 @@
+
+USING: kernel namespaces sequences random math math.constants math.libm vars
+ ui
+ processing
+ processing.gadget
+ bubble-chamber.common
+ bubble-chamber.particle
+ bubble-chamber.particle.muon
+ bubble-chamber.particle.quark
+ bubble-chamber.particle.hadron
+ bubble-chamber.particle.axion ;
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VARS: particles muons quarks hadrons axions ;
+
+VAR: boom
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-all ( -- )
+
+ 2 pi * 1random >collision-theta
+
+ particles> [ collide ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-one ( -- )
+
+ dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
+
+ hadrons> random collide
+ quarks> random collide
+ muons> random collide ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-pressed ( -- )
+ boom on
+ 1 background ! kludge
+ 11 [ drop collide-one ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key-released ( -- )
+ key " " =
+ [
+ boom on
+ 1 background
+ collide-all
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber ( -- )
+
+ 1000 1000 size*
+
+ [
+ 1 background
+ no-stroke
+
+ 1789 [ drop <muon> ] map >muons
+ 1300 [ drop <quark> ] map >quarks
+ 1000 [ drop <hadron> ] map >hadrons
+ 111 [ drop <axion> ] map >axions
+
+ muons> quarks> hadrons> axions> 3append append >particles
+
+ collide-one
+ ] setup
+
+ [
+ boom>
+ [ particles> [ move ] each ]
+ when
+ ] draw
+
+ [ mouse-pressed ] button-down
+ [ key-released ] key-up ;
+
+: go ( -- ) [ bubble-chamber run ] with-ui ;
+
+MAIN: go
\ No newline at end of file
diff --git a/extra/bubble-chamber/common/common.factor b/extra/bubble-chamber/common/common.factor
new file mode 100644
index 0000000000..c9ce687535
--- /dev/null
+++ b/extra/bubble-chamber/common/common.factor
@@ -0,0 +1,12 @@
+
+USING: kernel math accessors combinators.cleave vars ;
+
+IN: bubble-chamber.common
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: collision-theta
+
+: dim ( -- dim ) 1000 ;
+
+: center ( -- point ) dim 2 / dup {2} ; foldable
diff --git a/extra/bubble-chamber/particle/axion/axion.factor b/extra/bubble-chamber/particle/axion/axion.factor
new file mode 100644
index 0000000000..9e9bf99272
--- /dev/null
+++ b/extra/bubble-chamber/particle/axion/axion.factor
@@ -0,0 +1,67 @@
+
+USING: kernel sequences random accessors multi-methods
+ math math.constants math.ranges math.points combinators.cleave
+ processing bubble-chamber.common bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.axion
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: axion < particle ;
+
+: <axion> ( -- axion ) axion construct-empty initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { axion }
+
+ center >>pos
+ 2 pi * 1random >>theta
+ 1.0 6.0 2random >>speed
+ 0.998 1.000 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
+
+: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
+: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
+
+: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
+: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { axion }
+
+ { 0.06 0.59 } stroke
+ dup pos>> point
+
+ 1 4 [a,b] [ axion-white axion-point- ] each
+ 1 4 [a,b] [ axion-black axion-point+ ] each
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
+
+ 1000 random 996 >
+ [
+ dup speed>> neg >>speed
+ dup speed-d>> neg 2 + >>speed-d
+
+ 100 random 30 > [ collide ] [ drop ] if
+ ]
+ [ drop ]
+ if ;
diff --git a/extra/bubble-chamber/particle/hadron/hadron.factor b/extra/bubble-chamber/particle/hadron/hadron.factor
new file mode 100644
index 0000000000..2994577838
--- /dev/null
+++ b/extra/bubble-chamber/particle/hadron/hadron.factor
@@ -0,0 +1,60 @@
+
+USING: kernel random math math.constants math.points accessors multi-methods
+ processing
+ processing.color
+ bubble-chamber.common
+ bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.hadron
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: hadron < particle ;
+
+: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { hadron }
+
+ center >>pos
+ 2 pi * 1random >>theta
+ 0.5 3.5 2random >>speed
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ 0 1 0 <rgb> >>myc
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { hadron }
+
+ { 1 0.11 } stroke
+ dup pos>> 1 v-y point
+
+ { 0 0.11 } stroke
+ dup pos>> 1 v+y point
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ 1.0 >>speed-d
+ 0.00001 >>theta-dd
+
+ 100 random 70 > [ dup collide ] when
+ ]
+ when
+
+ out-of-bounds? [ collide ] [ drop ] if ;
diff --git a/extra/bubble-chamber/particle/muon/colors/colors.factor b/extra/bubble-chamber/particle/muon/colors/colors.factor
new file mode 100644
index 0000000000..ab72f65b4b
--- /dev/null
+++ b/extra/bubble-chamber/particle/muon/colors/colors.factor
@@ -0,0 +1,53 @@
+
+USING: kernel sequences math math.constants accessors
+ processing
+ processing.color ;
+
+IN: bubble-chamber.particle.muon.colors
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: good-colors ( -- seq )
+ {
+ T{ rgba f 0.23 0.14 0.17 1 }
+ T{ rgba f 0.23 0.14 0.15 1 }
+ T{ rgba f 0.21 0.14 0.15 1 }
+ T{ rgba f 0.51 0.39 0.33 1 }
+ T{ rgba f 0.49 0.33 0.20 1 }
+ T{ rgba f 0.55 0.45 0.32 1 }
+ T{ rgba f 0.69 0.63 0.51 1 }
+ T{ rgba f 0.64 0.39 0.18 1 }
+ T{ rgba f 0.73 0.42 0.20 1 }
+ T{ rgba f 0.71 0.45 0.29 1 }
+ T{ rgba f 0.79 0.45 0.22 1 }
+ T{ rgba f 0.82 0.56 0.34 1 }
+ T{ rgba f 0.88 0.72 0.49 1 }
+ T{ rgba f 0.85 0.69 0.40 1 }
+ T{ rgba f 0.96 0.92 0.75 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.85 0.82 0.69 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.82 0.82 0.79 1 }
+ T{ rgba f 0.65 0.69 0.67 1 }
+ T{ rgba f 0.53 0.60 0.55 1 }
+ T{ rgba f 0.57 0.53 0.68 1 }
+ T{ rgba f 0.47 0.42 0.56 1 }
+ } ;
+
+: anti-colors ( -- seq ) good-colors <reversed> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
+
+: set-good-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ good-colors at-fraction-of >>myc ]
+ [ drop ]
+ if ;
+
+: set-anti-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ anti-colors at-fraction-of >>mya ]
+ [ drop ]
+ if ;
diff --git a/extra/bubble-chamber/particle/muon/muon.factor b/extra/bubble-chamber/particle/muon/muon.factor
new file mode 100644
index 0000000000..44c7d9f134
--- /dev/null
+++ b/extra/bubble-chamber/particle/muon/muon.factor
@@ -0,0 +1,62 @@
+
+USING: kernel arrays sequences random
+ math
+ math.ranges
+ math.functions
+ math.vectors
+ multi-methods accessors
+ combinators.cleave
+ processing
+ bubble-chamber.common
+ bubble-chamber.particle
+ bubble-chamber.particle.muon.colors ;
+
+IN: bubble-chamber.particle.muon
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: muon < particle ;
+
+: <muon> ( -- muon ) muon construct-empty initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { muon }
+
+ center >>pos
+ 2 32 [a,b] random >>speed
+ 0.0001 0.001 2random >>speed-d
+
+ collision-theta> -0.1 0.1 2random + >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
+
+ set-good-color
+ set-anti-color
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { muon }
+
+ dup myc>> 0.16 >>alpha stroke
+ dup pos>> point
+
+ dup mya>> 0.16 >>alpha stroke
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ move-by
+
+ step-theta
+ step-theta-d
+ step-speed-sub
+
+ out-of-bounds? [ collide ] [ drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
diff --git a/extra/bubble-chamber/particle/particle.factor b/extra/bubble-chamber/particle/particle.factor
new file mode 100644
index 0000000000..755a414b71
--- /dev/null
+++ b/extra/bubble-chamber/particle/particle.factor
@@ -0,0 +1,68 @@
+
+USING: kernel sequences combinators
+ math math.vectors math.functions multi-methods
+ accessors combinators.cleave processing processing.color
+ bubble-chamber.common ;
+
+IN: bubble-chamber.particle
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: collide ( particle -- )
+GENERIC: move ( particle -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: initialize-particle ( particle -- particle )
+
+ 0 0 {2} >>pos
+ 0 0 {2} >>vel
+
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ 0 0 0 1 <rgba> >>myc
+ 0 0 0 1 <rgba> >>mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
+
+: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: turn ( particle -- particle )
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
+: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
+: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
+: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x ( particle -- x ) pos>> first ;
+: y ( particle -- x ) pos>> second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: out-of-bounds? ( particle -- particle ? )
+ dup
+ { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
+ or or or ;
diff --git a/extra/bubble-chamber/particle/quark/quark.factor b/extra/bubble-chamber/particle/quark/quark.factor
new file mode 100644
index 0000000000..32d95c8f00
--- /dev/null
+++ b/extra/bubble-chamber/particle/quark/quark.factor
@@ -0,0 +1,53 @@
+
+USING: kernel arrays sequences random math accessors multi-methods
+ processing
+ bubble-chamber.common
+ bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.quark
+
+TUPLE: quark < particle ;
+
+: <quark> ( -- quark ) quark construct-empty initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { quark }
+
+ center >>pos
+ collision-theta> -0.11 0.11 2random + >>theta
+ 0.5 3.0 2random >>speed
+
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { quark }
+
+ dup myc>> 0.13 >>alpha stroke
+ dup pos>> point
+
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ [ ] [ vel>> ] bi move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ dup speed>> neg >>speed
+ 2 over speed-d>> - >>speed-d
+ ]
+ when
+
+ out-of-bounds? [ collide ] [ drop ] if ;