From d44b88778e6794e0b54bf075381c65d1a0d56472 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Thu, 10 Jan 2008 15:29:11 -1000
Subject: [PATCH 01/45] [ first2 ] each -> assoc-each
---
core/cpu/x86/64/64.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index 4f1bbcb833..08952792f6 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
-alien alien.compiler alien.structs slots splitting ;
+alien alien.compiler alien.structs slots splitting assocs ;
IN: cpu.x86.64
PREDICATE: x86-backend amd64-backend
@@ -183,7 +183,7 @@ T{ stack-params } "__stack_value" c-type set-c-type-reg-class
: split-struct ( pairs -- seq )
[
- [ first2 8 mod zero? [ t , ] when , ] each
+ [ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] subset ;
: flatten-large-struct ( type -- )
From 112eed47048621e1bb3af64120a57a0936afdc62 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Thu, 10 Jan 2008 16:40:00 -1000
Subject: [PATCH 02/45] add missing IN:
---
extra/delegate/delegate-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/delegate/delegate-docs.factor b/extra/delegate/delegate-docs.factor
index 5ceeac42bb..f123c3a802 100644
--- a/extra/delegate/delegate-docs.factor
+++ b/extra/delegate/delegate-docs.factor
@@ -1,4 +1,5 @@
-USING: delegate help.syntax help.markup ;
+USING: help.syntax help.markup ;
+IN: delegate
HELP: define-protocol
{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } }
From 5cec55ecdae35ad6e4a60a2d1ccfbe3f9acde54a Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Thu, 10 Jan 2008 16:45:34 -1000
Subject: [PATCH 03/45] add IN:
---
extra/hexdump/hexdump-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/hexdump/hexdump-docs.factor b/extra/hexdump/hexdump-docs.factor
index 3fe9bd9594..adf31d3787 100644
--- a/extra/hexdump/hexdump-docs.factor
+++ b/extra/hexdump/hexdump-docs.factor
@@ -1,4 +1,5 @@
-USING: help.markup help.syntax hexdump kernel ;
+USING: help.markup help.syntax kernel ;
+IN: hexdump
HELP: hexdump.
{ $values { "seq" "a sequence" } }
From f9f824edfb78f27120267b0f311433cbd8399b73 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Thu, 10 Jan 2008 16:45:51 -1000
Subject: [PATCH 04/45] with-compilation-unit
---
extra/html/elements/elements.factor | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor
index d737c113a8..e5e2e573be 100644
--- a/extra/html/elements/elements.factor
+++ b/extra/html/elements/elements.factor
@@ -4,7 +4,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
-sequences strings words xml.writer ;
+sequences strings words xml.writer compiler.units ;
IN: html.elements
@@ -60,7 +60,9 @@ SYMBOL: html
: html-word ( name def -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
- >r elements-vocab create r> define-compound ;
+ [
+ >r elements-vocab create r> define
+ ] with-compilation-unit ;
: <foo> "<" swap ">" 3append ;
From f627598905391b95d31fd81124e2b92156447b1f Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Thu, 10 Jan 2008 16:55:38 -1000
Subject: [PATCH 05/45] add with* assoc-each-with
---
extra/combinators/lib/lib.factor | 22 ++++++++++++++++++++++
1 file changed, 22 insertions(+)
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 1c786a2559..44edb0ef96 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -67,6 +67,28 @@ MACRO: napply ( n -- )
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
+: 2with ( param1 param2 obj quot -- obj curry )
+ with with ; inline
+
+: 3with ( param1 param2 param3 obj quot -- obj curry )
+ with with with ; inline
+
+: with* ( obj assoc quot -- assoc curry )
+ swapd [ [ -rot ] dip call ] 2curry ; inline
+
+: 2with* ( obj1 obj2 assoc quot -- assoc curry )
+ with* with* ; inline
+
+: 3with* ( obj1 obj2 obj3 assoc quot -- assoc curry )
+ with* with* with* ; inline
+
+: assoc-each-with ( obj assoc quot -- )
+ with* assoc-each ; inline
+
+: assoc-map-with ( obj assoc quot -- assoc )
+ with* assoc-map ; inline
+
+
MACRO: nfirst ( n -- )
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
From 9a599ec459378d72708753ced8af2ea2999a8c2f Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Thu, 10 Jan 2008 16:56:32 -1000
Subject: [PATCH 06/45] add bit-banging words
---
extra/math/functions/functions.factor | 5 +++++
1 file changed, 5 insertions(+)
diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor
index 2c1a69a3d5..59ade44365 100755
--- a/extra/math/functions/functions.factor
+++ b/extra/math/functions/functions.factor
@@ -30,6 +30,11 @@ 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
+
GENERIC: (^) ( x y -- z ) foldable
: ^n ( z w -- z^w )
From eb2a6a7d2228d53bb775ca86c247897d610d6055 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 11 Jan 2008 00:48:04 -0500
Subject: [PATCH 07/45] Fixing httpd
---
extra/crypto/common/common-docs.factor | 3 +-
extra/furnace/furnace.factor | 15 ++--
extra/help/markup/markup.factor | 2 +-
extra/html/elements/elements-tests.factor | 8 ++
extra/html/elements/elements.factor | 89 ++++++++++---------
extra/html/html.factor | 5 +-
.../http/server/responders/responders.factor | 4 +
extra/http/server/server.factor | 4 -
.../http/server/templating/templating.factor | 3 +-
extra/webapps/cgi/cgi.factor | 4 +-
10 files changed, 78 insertions(+), 59 deletions(-)
create mode 100644 extra/html/elements/elements-tests.factor
diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor
index 1292e04777..032e174eb1 100644
--- a/extra/crypto/common/common-docs.factor
+++ b/extra/crypto/common/common-docs.factor
@@ -1,5 +1,6 @@
USING: help.markup help.syntax kernel math sequences quotations
-crypto.common math.private ;
+math.private ;
+IN: crypto.common
HELP: >32-bit
{ $values { "x" "an integer" } { "y" "an integer" } }
diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor
index 09c175f94c..80419e9c8d 100644
--- a/extra/furnace/furnace.factor
+++ b/extra/furnace/furnace.factor
@@ -1,11 +1,11 @@
-! Copyright (C) 2006 Slava Pestov, Doug Coleman
+! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs calendar debugger furnace.sessions furnace.validator
-hashtables heaps html.elements http http.server.responders
-http.server.templating io.files kernel math namespaces
-quotations sequences splitting words strings vectors
-webapps.callback ;
-USING: continuations io prettyprint ;
+USING: arrays assocs calendar debugger furnace.sessions
+furnace.validator hashtables heaps html.elements http
+http.server.responders http.server.templating io.files kernel
+math namespaces quotations sequences splitting words strings
+vectors webapps.callback continuations tuples classes vocabs
+html io ;
IN: furnace
: code>quotation ( word/quot -- quot )
@@ -174,7 +174,6 @@ PREDICATE: word action "action" word-prop ;
[ service-post ] "post" set
] make-responder ;
-USING: classes html tuples vocabs ;
: explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ;
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
index 5d90fd367c..5f1b027823 100644
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -44,7 +44,7 @@ M: f print-element drop ;
: with-default-style ( quot -- )
default-style get [
last-element off
- H{ } swap with-nesting
+ default-style get swap with-nesting
] with-style ; inline
: print-content ( element -- )
diff --git a/extra/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor
new file mode 100644
index 0000000000..786fe0e68c
--- /dev/null
+++ b/extra/html/elements/elements-tests.factor
@@ -0,0 +1,8 @@
+IN: temporary
+USING: tools.test html html.elements io.streams.string ;
+
+: make-html-string
+ [ with-html-stream ] string-out ;
+
+[ "<a href='h&o'>" ]
+[ [ <a "h&o" =href a> ] make-html-string ] unit-test
diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor
index d737c113a8..ff3e7b1283 100644
--- a/extra/html/elements/elements.factor
+++ b/extra/html/elements/elements.factor
@@ -4,17 +4,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
-sequences strings words xml.writer ;
+sequences strings words xml.writer compiler.units effects ;
IN: html.elements
! These words are used to provide a means of writing
! formatted HTML to standard output with a familiar 'html' look
-! and feel in the code.
+! and feel in the code.
!
! HTML tags can be used in a number of different ways. The highest
! level involves a similar syntax to HTML:
-!
+!
! <p> "someoutput" write </p>
!
! <p> will output the opening tag and </p> will output the closing
@@ -28,7 +28,7 @@ IN: html.elements
! in that namespace. Before the attribute word should come the
! value of that attribute.
! The finishing word will print out the operning tag including
-! attributes.
+! attributes.
! Any writes after this will appear after the opening tag.
!
! Values for attributes can be used directly without any stack
@@ -57,54 +57,59 @@ SYMBOL: html
: print-html ( str -- )
write-html "\n" write-html ;
-: html-word ( name def -- )
+: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
- >r elements-vocab create r> define-compound ;
-
+ >r >r elements-vocab create r> r> define-declared ;
+
: <foo> "<" swap ">" 3append ;
+: empty-effect T{ effect f 0 0 } ;
+
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
- dup <foo> swap [ <foo> write-html ] curry html-word ;
+ dup <foo> swap [ <foo> write-html ] curry
+ empty-effect html-word ;
: <foo "<" swap append ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
#! word.
- <foo dup [ write-html ] curry html-word ;
+ <foo dup [ write-html ] curry
+ empty-effect html-word ;
: foo> ">" append ;
: def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned
#! word.
- foo> [ ">" write-html ] html-word ;
+ foo> [ ">" write-html ] empty-effect html-word ;
: </foo> [ "</" % % ">" % ] "" make ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
- #! word.
- </foo> dup [ write-html ] curry html-word ;
+ #! word.
+ </foo> dup [ write-html ] curry empty-effect html-word ;
: <foo/> [ "<" % % "/>" % ] "" make ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
#! word.
- dup <foo/> swap [ <foo/> write-html ] curry html-word ;
+ dup <foo/> swap [ <foo/> write-html ] curry
+ empty-effect html-word ;
: foo/> "/>" append ;
: def-for-html-word-foo/> ( name -- )
#! Return the name and code for the foo/> patterned
- #! word.
- foo/> [ "/>" write-html ] html-word ;
+ #! word.
+ foo/> [ "/>" write-html ] empty-effect html-word ;
-: define-closed-html-word ( name -- )
+: define-closed-html-word ( name -- )
#! Given an HTML tag name, define the words for
#! that closable HTML tag.
dup def-for-html-word-<foo>
@@ -112,7 +117,7 @@ SYMBOL: html
dup def-for-html-word-foo>
def-for-html-word-</foo> ;
-: define-open-html-word ( name -- )
+: define-open-html-word ( name -- )
#! Given an HTML tag name, define the words for
#! that open HTML tag.
dup def-for-html-word-<foo/>
@@ -123,34 +128,38 @@ SYMBOL: html
" " write-html
write-html
"='" write-html
- escape-quoted-string write
+ escape-quoted-string write-html
"'" write-html ;
+: attribute-effect T{ effect f { "string" } 0 } ;
+
: define-attribute-word ( name -- )
dup "=" swap append swap
- [ write-attr ] curry html-word ;
+ [ write-attr ] curry attribute-effect html-word ;
-! Define some closed HTML tags
[
- "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
- "ol" "li" "form" "a" "p" "html" "head" "body" "title"
- "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
- "script" "div" "span" "select" "option" "style"
-] [ define-closed-html-word ] each
+ ! Define some closed HTML tags
+ [
+ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
+ "ol" "li" "form" "a" "p" "html" "head" "body" "title"
+ "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
+ "script" "div" "span" "select" "option" "style"
+ ] [ define-closed-html-word ] each
-! Define some open HTML tags
-[
- "input"
- "br"
- "link"
- "img"
-] [ define-open-html-word ] each
+ ! Define some open HTML tags
+ [
+ "input"
+ "br"
+ "link"
+ "img"
+ ] [ define-open-html-word ] each
-! Define some attributes
-[
- "method" "action" "type" "value" "name"
- "size" "href" "class" "border" "rows" "cols"
- "id" "onclick" "style" "valign" "accesskey"
- "src" "language" "colspan" "onchange" "rel"
- "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
-] [ define-attribute-word ] each
+ ! Define some attributes
+ [
+ "method" "action" "type" "value" "name"
+ "size" "href" "class" "border" "rows" "cols"
+ "id" "onclick" "style" "valign" "accesskey"
+ "src" "language" "colspan" "onchange" "rel"
+ "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
+ ] [ define-attribute-word ] each
+] with-compilation-unit
diff --git a/extra/html/html.factor b/extra/html/html.factor
index 391737ca61..700951dfdd 100755
--- a/extra/html/html.factor
+++ b/extra/html/html.factor
@@ -109,7 +109,10 @@ M: html-span-stream stream-close
page-color [ bg-css, ] apply-style
border-color [ border-css, ] apply-style
border-width [ padding-css, ] apply-style
- wrap-margin [ pre-css, ] apply-style
+ ! FIXME: This is a hack for webapps.help
+ building get empty? [
+ wrap-margin over at pre-css,
+ ] unless
] make-css ;
: div-tag ( style quot -- )
diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor
index 2dfbf73004..8dcaa7223d 100644
--- a/extra/http/server/responders/responders.factor
+++ b/extra/http/server/responders/responders.factor
@@ -124,6 +124,10 @@ SYMBOL: max-post-request
: header-param ( key -- value ) "header" get at ;
+: host ( -- string )
+ #! The host the current responder was called from.
+ "Host" header-param ":" split1 drop ;
+
: add-responder ( responder -- )
#! Add a responder object to the list.
"responder" over at responders get set-at ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 58ef587150..99ed41afa3 100644
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -28,10 +28,6 @@ IN: http.server
{ "HEAD" "head" }
} at "bad" or ;
-: host ( -- string )
- #! The host the current responder was called from.
- "Host" header-param ":" split1 drop ;
-
: (handle-request) ( arg cmd -- method path host )
request-method dup "method" set swap
prepare-url prepare-header host ;
diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor
index 680f7b73d5..69f8b4e7fd 100755
--- a/extra/http/server/templating/templating.factor
+++ b/extra/http/server/templating/templating.factor
@@ -77,7 +77,6 @@ DEFER: <% delimiter
[
[
"quiet" on
- file-vocabs
parser-notes off
templating-vocab use+
dup source-file file set ! so that reload works properly
@@ -85,7 +84,7 @@ DEFER: <% delimiter
?resource-path file-contents
[ eval-template ] [ html-error. drop ] recover
] keep
- ] with-scope
+ ] with-file-vocabs
] assert-depth drop ;
: run-relative-template-file ( filename -- )
diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor
index 3588b21bda..26b8f31eae 100644
--- a/extra/webapps/cgi/cgi.factor
+++ b/extra/webapps/cgi/cgi.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators
-arrays io.launcher io http.server http.server.responders
-webapps.file sequences strings ;
+arrays io.launcher io http.server.responders webapps.file
+sequences strings ;
IN: webapps.cgi
SYMBOL: cgi-root
From 53ae4f9133a748b3874b483fdcac018f51295ae4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 11 Jan 2008 01:01:23 -0500
Subject: [PATCH 08/45] Further html fixes
---
extra/html/html-tests.factor | 8 +++++++-
extra/html/html.factor | 29 +++++++++++++++++++----------
2 files changed, 26 insertions(+), 11 deletions(-)
diff --git a/extra/html/html-tests.factor b/extra/html/html-tests.factor
index 798d5563fe..5c33df18b3 100644
--- a/extra/html/html-tests.factor
+++ b/extra/html/html-tests.factor
@@ -54,10 +54,16 @@ M: funky browser-link-href
] make-html-string
] unit-test
-[ "<div style='background-color: #ff00ff; '>cdr</div>" ]
+[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
[
[
H{ { page-color { 1 0 1 1 } } }
[ "cdr" write ] with-nesting
] make-html-string
] unit-test
+
+[
+ "<div style='white-space: pre; font-family: monospace; '></div>"
+] [
+ [ H{ } [ ] with-nesting nl ] make-html-string
+] unit-test
diff --git a/extra/html/html.factor b/extra/html/html.factor
index 700951dfdd..f9d5bde5e6 100755
--- a/extra/html/html.factor
+++ b/extra/html/html.factor
@@ -10,7 +10,19 @@ GENERIC: browser-link-href ( presented -- href )
M: object browser-link-href drop f ;
-TUPLE: html-stream ;
+TUPLE: html-stream last-div? ;
+
+! A hack: stream-nl after with-nesting or tabular-output is
+! ignored, so that HTML stream output looks like UI pane output
+: test-last-div? ( stream -- ? )
+ dup html-stream-last-div?
+ f rot set-html-stream-last-div? ;
+
+: not-a-div ( stream -- stream )
+ dup test-last-div? drop ; inline
+
+: a-div ( stream -- straem )
+ t over set-html-stream-last-div? ; inline
: <html-stream> ( stream -- stream )
html-stream construct-delegate ;
@@ -94,7 +106,7 @@ TUPLE: html-sub-stream style stream ;
TUPLE: html-span-stream ;
M: html-span-stream stream-close
- end-sub-stream format-html-span ;
+ end-sub-stream not-a-div format-html-span ;
: border-css, ( border -- )
"border: 1px solid #" % hex-color, "; " % ;
@@ -109,10 +121,7 @@ M: html-span-stream stream-close
page-color [ bg-css, ] apply-style
border-color [ border-css, ] apply-style
border-width [ padding-css, ] apply-style
- ! FIXME: This is a hack for webapps.help
- building get empty? [
- wrap-margin over at pre-css,
- ] unless
+ wrap-margin over at pre-css,
] make-css ;
: div-tag ( style quot -- )
@@ -130,7 +139,7 @@ M: html-span-stream stream-close
TUPLE: html-block-stream ;
M: html-block-stream stream-close ( quot style stream -- )
- end-sub-stream format-html-div ;
+ end-sub-stream a-div format-html-div ;
: border-spacing-css,
"padding: " % first2 max 2 /i # "px; " % ;
@@ -154,7 +163,7 @@ M: html-stream stream-write1 ( char stream -- )
>r 1string r> stream-write ;
M: html-stream stream-write ( str stream -- )
- >r escape-string r> delegate stream-write ;
+ not-a-div >r escape-string r> delegate stream-write ;
M: html-stream make-span-stream ( style stream -- stream' )
html-span-stream <html-sub-stream> ;
@@ -167,7 +176,7 @@ M: html-stream make-block-stream ( style stream -- stream' )
html-block-stream <html-sub-stream> ;
M: html-stream stream-write-table ( grid style stream -- )
- [
+ a-div [
<table dup table-attrs table> swap [
<tr> [
<td "top" =valign swap table-style =style td>
@@ -181,7 +190,7 @@ M: html-stream make-cell-stream ( style stream -- stream' )
(html-sub-stream) ;
M: html-stream stream-nl ( stream -- )
- [ <br/> ] with-stream* ;
+ dup test-last-div? [ drop ] [ [ <br/> ] with-stream* ] if ;
! Utilities
: with-html-stream ( quot -- )
From d2222179c649b47cf16eabb2efe1b05b5493bf99 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 11 Jan 2008 01:01:38 -0500
Subject: [PATCH 09/45] Clean up compiler.errors
---
core/compiler/errors/errors.factor | 7 ++++---
1 file changed, 4 insertions(+), 3 deletions(-)
diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor
index 65de89524a..363c13c478 100755
--- a/core/compiler/errors/errors.factor
+++ b/core/compiler/errors/errors.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs prettyprint io sequences
-sorting continuations debugger math ;
+sorting continuations debugger math math.parser ;
IN: compiler.errors
SYMBOL: compiler-errors
@@ -41,8 +41,9 @@ M: object compiler-warning? drop f ;
: (compiler-report) ( what assoc -- )
length dup zero? [ 2drop ] [
- ":" write over write " - print " write pprint
- " compiler " write write "." print
+ [
+ ":" % over % " - print " % # " compiler " % % "." %
+ ] "" make print
] if ;
: compiler-report ( -- )
From 554a0d387742c24596ae72c272e395ffbe23d4d2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 11 Jan 2008 03:32:25 -0500
Subject: [PATCH 10/45] Documentation updates
---
core/bootstrap/stage2.factor | 6 +-
core/command-line/command-line-docs.factor | 2 +-
core/compiler/compiler-docs.factor | 2 +
core/compiler/test/redefine.factor | 9 +-
core/continuations/continuations-docs.factor | 2 +-
core/generic/generic.factor | 5 +-
core/memory/memory-docs.factor | 18 +--
core/parser/parser-docs.factor | 2 +-
extra/help/cookbook/cookbook.factor | 93 +++++++----
extra/help/handbook/handbook.factor | 7 +-
extra/help/tutorial/tutorial.factor | 153 +++++++++++++++++++
extra/tools/memory/memory-docs.factor | 15 +-
extra/tools/test/test-docs.factor | 6 +-
extra/tools/test/test.factor | 15 +-
extra/ui/tools/deploy/deploy-docs.factor | 2 +
extra/ui/tools/deploy/deploy.factor | 2 +-
16 files changed, 278 insertions(+), 61 deletions(-)
create mode 100644 extra/help/tutorial/tutorial.factor
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index 2bcd4ce82f..f9c738a8d0 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -4,7 +4,8 @@ USING: init command-line namespaces words debugger io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
-definitions assocs compiler.errors compiler.units ;
+definitions assocs compiler.errors compiler.units
+math.parser ;
IN: bootstrap.stage2
! Wrap everything in a catch which starts a listener so
@@ -67,7 +68,8 @@ IN: bootstrap.stage2
] [ print-error 1 exit ] recover
] set-boot-quot
- : count-words all-words swap subset length pprint ;
+ : count-words ( pred -- )
+ all-words swap subset length number>string write ;
[ compiled? ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
diff --git a/core/command-line/command-line-docs.factor b/core/command-line/command-line-docs.factor
index 0c9bbd131a..e41d316792 100644
--- a/core/command-line/command-line-docs.factor
+++ b/core/command-line/command-line-docs.factor
@@ -4,7 +4,7 @@ IN: command-line
ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table
- { { $snippet "-i=" { $emphasis "image" } } "Specifies the image file to use" }
+ { { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" }
diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor
index ccddf97244..17e6938a0c 100755
--- a/core/compiler/compiler-docs.factor
+++ b/core/compiler/compiler-docs.factor
@@ -3,6 +3,8 @@ assocs words.private sequences ;
IN: 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 points to the optimizing compiler:"
{ $subsection compile }
{ $subsection recompile }
diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor
index ed7a0399fb..d9ba349cc2 100755
--- a/core/compiler/test/redefine.factor
+++ b/core/compiler/test/redefine.factor
@@ -174,6 +174,7 @@ DEFER: hints-test-2
[ 10 ] [ hints-test-2 ] unit-test
+DEFER: inline-then-not-inline-test-1
DEFER: inline-then-not-inline-test-2
[ ] [ "IN: temporary : inline-then-not-inline-test-1 1 2 3 ; inline" eval ] unit-test
@@ -182,6 +183,10 @@ DEFER: inline-then-not-inline-test-2
[ 1 2 3 ] [ inline-then-not-inline-test-2 ] unit-test
-[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 9 ;" eval ] unit-test
+\ inline-then-not-inline-test-2 word-xt "a" set
-[ 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
+[ ] [ "IN: temporary : inline-then-not-inline-test-1 6 6 9 ;" eval ] unit-test
+
+[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test
+
+[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index 87616d8833..2918f3340b 100644
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -3,7 +3,7 @@ continuations.private parser vectors arrays namespaces
threads assocs words quotations ;
IN: continuations
-ARTICLE: "errors-restartable" "Restartable error handling"
+ARTICLE: "errors-restartable" "Restartable errors"
"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:"
{ $subsection throw-restarts }
{ $subsection rethrow-restarts }
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 961c962e42..5ee6b9c87c 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -85,7 +85,10 @@ M: method-spec definer drop \ M: \ ; ;
M: method-spec definition first2 method method-def ;
-M: method-spec forget* first2 [ delete-at ] with-methods ;
+: forget-method ( class generic -- )
+ check-method [ delete-at ] with-methods ;
+
+M: method-spec forget* first2 forget-method ;
: implementors* ( classes -- words )
all-words [
diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor
index 80670a6db5..7d99e6311e 100644
--- a/core/memory/memory-docs.factor
+++ b/core/memory/memory-docs.factor
@@ -1,25 +1,15 @@
USING: help.markup help.syntax debugger sequences kernel ;
IN: memory
-ARTICLE: "memory" "Object memory"
-"You can query memory status:"
-{ $subsection data-room }
-{ $subsection code-room }
-"There are a pair of combinators, analogous to " { $link each } " and " { $link subset } ", which operate on the entire collection of objects in the object heap:"
-{ $subsection each-object }
-{ $subsection instances }
-"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 }
-"The current image can be saved:"
+ARTICLE: "images" "Images"
+"The current image can be saved; the image contains a complete dump of all data and code in the current Factor instance:"
{ $subsection save }
{ $subsection save-image }
{ $subsection save-image-and-exit }
+"To start Factor with a custom image, use the " { $snippet "-i=" { $emphasis "image" } } " command line switch; see " { $link "runtime-cli-args" } "."
{ $see-also "tools.memory" } ;
-ABOUT: "memory"
+ABOUT: "image"
HELP: begin-scan ( -- )
{ $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index a896deb4d5..de56dc55db 100755
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -49,7 +49,7 @@ ARTICLE: "vocabulary-search-errors" "Word lookup errors"
}
"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ;
-ARTICLE: "vocabulary-search" "Vocabulary search"
+ARTICLE: "vocabulary-search" "Vocabulary search path"
"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
$nl
"For a source file the vocabulary search path starts off with two vocabularies:"
diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor
index 5cb168b1fd..654f863fd6 100755
--- a/extra/help/cookbook/cookbook.factor
+++ b/extra/help/cookbook/cookbook.factor
@@ -1,5 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces inference ;
+IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
"The following is a simple snippet of Factor code:"
@@ -176,16 +177,7 @@ $nl
"parser"
} ;
-ARTICLE: "cookbook-sources" "Source file cookbook"
-"By convention, code is stored in files with the " { $snippet ".factor" } " filename extension. You can load source files using " { $link run-file } ":"
-{ $code "\"hello.factor\" run-file" }
-{ $references
- "Programs larger than one source file or programs which depend on other libraries should be loaded via the vocabulary system instead. Advanced functionality can be implemented by calling the parser and source reader at run time."
- "parser-files"
- "vocabs.loader"
-} ;
-
-ARTICLE: "cookbook-io" "I/O cookbook"
+ARTICLE: "cookbook-io" "Input and output cookbook"
"Ask the user for their age, and print it back:"
{ $code
": ask-age ( -- ) \"How old are you?\" print ;"
@@ -205,6 +197,12 @@ ARTICLE: "cookbook-io" "I/O cookbook"
{ $code
"\"data.bin\" <file-reader> [ 1024 read ] with-stream"
}
+"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory:"
+{ $code
+ "\"mydata.dat\" dup file-length ["
+ " 4 <sliced-groups> [ reverse-here ] change-each"
+ "] with-mapped-file"
+}
"Send some bytes to a remote host:"
{ $code
"\"myhost\" 1033 <inet> <client>"
@@ -216,6 +214,58 @@ ARTICLE: "cookbook-io" "I/O cookbook"
"io"
} ;
+ARTICLE: "cookbook-compiler" "Compiler cookbook"
+"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is a fully transparent process. However, there are a few things worth knowing about the compilation process."
+$nl
+"The optimizing compiler trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
+$nl
+"After loading a vocabulary, you might see messages like:"
+{ $code
+ ":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."
+{ $references
+ "To learn more about the compiler and static stack effect inference, read these articles:"
+ "compiler"
+ "compiler-errors"
+ "inference"
+} ;
+
+ARTICLE: "cookbook-application" "Application cookbook"
+"Vocabularies can define a main entry point:"
+{ $code "IN: game-of-life"
+"..."
+": play-life ... ;"
+""
+"MAIN: play-life"
+}
+"See " { $link POSTPONE: MAIN: } " for details. The " { $link run } " word loads a vocabulary if necessary, and calls its main entry point; try the following, it's fun:"
+{ $code "\"tetris\" run" }
+"On Mac OS X and Windows, stand-alone applications can also be deployed; these are genuine, 100% native code double-clickable executables:"
+{ $code "\"tetris\" deploy-tool" }
+{ $references
+ { }
+ "vocabs.loader"
+ "tools.deploy"
+ "ui.tools.deploy"
+ "cookbook-scripts"
+} ;
+
+ARTICLE: "cookbook-scripts" "Scripting cookbook"
+"Factor can be used for command-line scripting on Unix-like systems."
+$nl
+"A text file can begin with a comment like the following, and made executable:"
+{ $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."
+{ $references
+ { }
+ "cli"
+ "cookbook-application"
+} ;
+
ARTICLE: "cookbook-philosophy" "Factor philosophy"
"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write."
$nl
@@ -251,28 +301,17 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
} ;
ARTICLE: "cookbook" "Factor cookbook"
-{ $list
- { "Factor is a dynamically-typed, stack-based language." }
- { { $link .s } " prints the contents of the stack." }
- { { $link . } " prints the object at the top of the stack." }
- { { "You can load vocabularies from " { $snippet "core/" } ", " { $snippet "extra/" } " or " { $snippet "work/" } " with " { $link require } ":" }
- { $code "\"http.server\" require" } }
- { { "Some vocabularies have a defined main entry point, and can be run just like applications in an operating system:" }
- { $code "\"tetris\" run" }
- }
- { "Make sure to browse the " { $link "vocab-index" } "." }
-
- { "You can load source files with " { $link run-file } ":"
- { $code "\"my-program.factor\" run-file" }
- "However, the vocabulary system should be used instead of loading source files directly; it provides automatic code organization and dependency management." }
- { "If you are reading this from the Factor UI, take a look at " { $link "ui-tools" } "." }
-}
+"The Factor cookbook is a high-level overview of the most important concepts required to program in Factor."
{ $subsection "cookbook-syntax" }
{ $subsection "cookbook-colon-defs" }
{ $subsection "cookbook-combinators" }
{ $subsection "cookbook-variables" }
{ $subsection "cookbook-vocabs" }
-{ $subsection "cookbook-sources" }
{ $subsection "cookbook-io" }
+{ $subsection "cookbook-application" }
+{ $subsection "cookbook-scripts" }
+{ $subsection "cookbook-compiler" }
{ $subsection "cookbook-philosophy" }
{ $subsection "cookbook-pitfalls" } ;
+
+ABOUT: "cookbook"
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index bb2d633545..fdfc6b6604 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -181,14 +181,15 @@ ARTICLE: "program-org" "Program organization"
{ $subsection "parser" }
{ $subsection "vocabs.loader" } ;
-USE: help.cookbook
+USING: help.cookbook help.tutorial ;
ARTICLE: "handbook" "Factor documentation"
+"Welcome to Factor. Factor is dynamically-typed, stack-based, and very expressive. It is one of the most powerful and flexible programming languages ever invented. Have fun with Factor!"
{ $heading "Starting points" }
{ $subsection "cookbook" }
+{ $subsection "first-program" }
{ $subsection "vocab-index" }
{ $subsection "changes" }
-{ $subsection "cli" }
{ $heading "Language reference" }
{ $subsection "conventions" }
{ $subsection "syntax" }
@@ -202,6 +203,8 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "os" }
{ $subsection "alien" }
{ $heading "Environment reference" }
+{ $subsection "cli" }
+{ $subsection "images" }
{ $subsection "prettyprint" }
{ $subsection "tools" }
{ $subsection "help" }
diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor
new file mode 100644
index 0000000000..a4d5e36b06
--- /dev/null
+++ b/extra/help/tutorial/tutorial.factor
@@ -0,0 +1,153 @@
+USING: help.markup help.syntax ui.commands ui.operations
+ui.tools.search ui.tools.workspace editors vocabs.loader
+kernel sequences prettyprint tools.test strings ;
+IN: help.tutorial
+
+ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
+"Factor source code is organized into " { $link "vocabularies" } ". Before we can write our first program, we must create a vocabulary for it."
+$nl
+"Start by asking Factor for the path to your ``work'' directory, where you will place your own code:"
+{ $code "\"work\" resource-path ." }
+"Open the work directory in your file manager, and create a subdirectory named " { $snippet "palindrome" } ". Inside this directory, create a file named " { $snippet "palindrome.factor" } " using your favorite text editor. Leave the file empty for now."
+$nl
+"Inside the Factor listener, type"
+{ $code "USE: palindrome" }
+"The source file should now load. Since it is empty, it does nothing. If you get an error message, make sure you created the directory and the file in the right place and gave them the right names."
+$nl
+"Now, we will start filling out this source file. Go back to your editor, and type:"
+{ $code
+ "! Copyright (C) 2008 <your name here>"
+ "! See http://factorcode.org/license.txt for BSD license."
+}
+"This is the standard header for Factor source files; it consists of two " { $link "syntax-comments" } "."
+$nl
+"Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
+{ $code "IN: palindrome" }
+"You are now ready to go onto the nex section." ;
+
+ARTICLE: "first-program-logic" "Writing some logic in your first program"
+"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
+{ $code
+ "! Copyright (C) 2008 <your name here>"
+ "! See http://factorcode.org/license.txt for BSD license."
+ "IN: palindrome"
+}
+"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
+$nl
+"Recall that a string is a palindrome if it is spelled the same forwards or backwards; that is, if the string is equal to its reverse. We can express this in Factor as follows:"
+{ $code ": palindrome? ( string -- ? ) dup reverse = ;" }
+"Place this definition at the end of your source file."
+$nl
+"Now we have changed the source file, we must reload it into Factor so that we can test the new definition. To do this, simply go to the Factor workspace and press " { $command workspace "workflow" refresh-all } ". This will find any previously-loaded source files which have changed on disk, and reload them."
+$nl
+"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
+$nl
+"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary by entering the following in the listener:"
+{ $code "\\ dup see" }
+"This shows the definition of " { $link dup } ", along with an " { $link POSTPONE: IN: } " form."
+$nl
+"Now, add the following at the start of the source file:"
+{ $code "USING: kernel ;" }
+"Next, find out what vocabulary " { $link reverse } " lives in:"
+{ $code "\\ reverse see" }
+"It lives in the " { $vocab-link "sequences" } " vocabulary, so we add that to the search path:"
+{ $code "USING: kernel sequences ;" }
+"Finally, check what vocabulary " { $link = } " lives in:"
+{ $code "\\ = see" }
+"It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
+
+"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors." ;
+
+ARTICLE: "first-program-test" "Testing your first program"
+"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
+{ $code
+ "! Copyright (C) 2008 <your name here>"
+ "! See http://factorcode.org/license.txt for BSD license."
+ "IN: palindrome"
+ "USING: kernel sequences ;"
+ ""
+ ": palindrome? ( str -- ? ) dup reverse = ;"
+}
+"We will now test our new word in the listener. First, push a string on the stack:"
+{ $code "\"hello\"" }
+"Note that the stack display at the top of the workspace now shows this string. Having supplied the input, we call our word:"
+{ $code "palindrome?" }
+"The stack display should now have a boolean false - " { $link f } " - which is the word's output. Since ``hello'' is not a palindrome, this is what we expect. We can get rid of this boolean by calling " { $link drop } ". The stack should be empty after this is done."
+$nl
+"Now, let's try it with a palindrome; we will push the string and call the word in the same line of code:"
+{ $code "\"racecar\" palindrome?" }
+"The stack should now contain a boolean true - " { $link t } ". We can print it and drop it using the " { $link . } " word:"
+{ $code "." }
+"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
+$nl
+"Create a file named " { $snippet "palindrome-tests.factor" } " in the same directory as " { $snippet "palindrome.factor" } ". Now, we can run unit tests from the listener:"
+{ $code "\"palindrome\" test" }
+"We will add some unit tests corresponding to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
+$nl
+"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
+{ $code
+ "USING: palindrome tools.test ;"
+ "[ f ] [ \"hello\" palindrome? ] unit-test"
+ "[ t ] [ \"racecar\" palindrome? ] unit-test"
+}
+"Now, you can run unit tests:"
+{ $code "\"palindrome\" test" }
+"It should report that all tests have passed." ;
+
+ARTICLE: "first-program-extend" "Extending your first program"
+"Our palindrome program works well, however we'd like to extend it to ignore spaces and non-alphabetical characters in the input."
+$nl
+"For example, we'd like it to identify the following as a palindrome:"
+{ $code "\"A man, a plan, a canal: Panama.\"" }
+"However, right now, the simplistic algorithm we use says this is not a palindrome:"
+{ $example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" }
+"We would like it to output " { $link t } " there. We can encode this requirement with a unit test that we add to " { $snippet "palindrome-tests.factor" } ":"
+{ $code "[ t ] [ \"A man, a plan, a canal: Panama.\" palindrome? ] unit-test" }
+"If you now run unit tests, you will see a unit test failure:"
+{ $code "\"palindrome\" test" }
+"The next step is to, of course, fix our code so that the unit test can pass."
+$nl
+"We begin by writing a word called " { $snippet "normalize" } " which removes blanks and non-alphabetical characters from a string, and then converts the string to lower case. We call this word " { $snippet "normalize" } ". To figure out how to write this word, we begin with some interactive experimentation in the listener."
+$nl
+"Start by pushing a character on the stack; notice that characters are really just integers:"
+{ $code "CHAR: a" }
+"Now, use the " { $link Letter? } " word to test if it is an alphabetical character, upper or lower case:"
+{ $example "Letter? ." "t" }
+"This gives the expected result."
+$nl
+"Now try with a non-alphabetical character:"
+{ $code "CHAR: #" }
+{ $example "Letter? ." "f" }
+"What we want to do is given a string, remove all characters which do not match the " { $link Letter? } " predicate. Let's push a string on the stack:"
+{ $code "\"A man, a plan, a canal: Panama.\"" }
+"Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:"
+{ $code "[ Letter? ]" }
+"Finally, pass the string and the quotation to the " { $link subset } " word:"
+{ $code "subset" }
+"Now the stack should contain the following string:"
+{ "\"AmanaplanacanalPanama\"" }
+"This is almost what we want; we just need to convert the string to lower case now. This can be done by calling " { $link >lower } "; the " { $snippet ">" } " prefix is a naming convention for conversion operations, and should be read as ``to'':"
+{ $code ">lower" }
+"Finally, let's print the top of the stack and discard it:"
+{ $code "." }
+"This will output " { $snippet "amanaplanacanalpanama" } ". This string is in the form that we want, and we evaluated the following code to get it into this form:"
+{ $code "[ Letter? ] subset >lower" }
+"This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":"
+{ $code ": normalize ( str -- newstr ) [ Letter? ] subset >lower ;" }
+"You will need to add " { $vocab-link "strings" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
+$nl
+"We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
+{ $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" }
+"Now if you press " { $command workspace "workflow" refresh-all } ", the source file should reload without any errors. You can run unit tests again, and this time, they will all pass:"
+{ $code "\"palindrome\" test" } ;
+
+ARTICLE: "first-program" "Your first program"
+"In this tutorial, we will write a simple Factor program which prompts the user to enter a word, and tests if it is a palindrome (that is, the word is spelled the same backwards and forwards)."
+$nl
+"In this tutorial, you will learn about basic Factor development tools, as well as application deployment."
+{ $subsection "first-program-start" }
+{ $subsection "first-program-logic" }
+{ $subsection "first-program-test" }
+{ $subsection "first-program-extend" } ;
+
+ABOUT: "first-program"
diff --git a/extra/tools/memory/memory-docs.factor b/extra/tools/memory/memory-docs.factor
index 3d746bbf9d..939dda0cfc 100644
--- a/extra/tools/memory/memory-docs.factor
+++ b/extra/tools/memory/memory-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax memory ;
+USING: help.markup help.syntax memory sequences ;
IN: tools.memory
ARTICLE: "tools.memory" "Object memory tools"
@@ -6,7 +6,18 @@ ARTICLE: "tools.memory" "Object memory tools"
{ $subsection room. }
{ $subsection heap-stats. }
{ $subsection heap-stats }
-{ $see-also "memory" } ;
+"You can query memory status:"
+{ $subsection data-room }
+{ $subsection code-room }
+"There are a pair of combinators, analogous to " { $link each } " and " { $link subset } ", which operate on the entire collection of objects in the object heap:"
+{ $subsection each-object }
+{ $subsection instances }
+"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 }
+{ $see-also "image" } ;
ABOUT: "tools.memory"
diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor
index 3fc5057c4c..48a1192282 100644
--- a/extra/tools/test/test-docs.factor
+++ b/extra/tools/test/test-docs.factor
@@ -1,12 +1,14 @@
USING: help.markup help.syntax kernel ;
IN: tools.test
-ARTICLE: "tools.test" "Unit testing modules"
+ARTICLE: "tools.test" "Unit testing"
"A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract."
$nl
"For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know."
$nl
-"Unit tests for a vocabulary are placed in test harness files ( "{ $link "vocabs.loader" } "). If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:"
+"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } " -tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details."
+$nl
+"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:"
{ $subsection unit-test }
{ $subsection unit-test-fails }
"The following words run test harness files; any test failures are collected and printed at the end:"
diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor
index 87ab7abf71..2a26c8639e 100755
--- a/extra/tools/test/test.factor
+++ b/extra/tools/test/test.factor
@@ -55,12 +55,17 @@ TUPLE: expected-error ;
[ nl failure. nl ] each ;
: run-tests ( seq -- )
- [ dup run-test ] { } map>assoc
- [ second empty? not ] subset
- dup empty? [ drop ] [
+ dup empty? [ drop "==== NOTHING TO TEST" print ] [
+ [ dup run-test ] { } map>assoc
+ [ second empty? not ] subset
nl
- "==== FAILING TESTS:" print
- [ nl failures. ] assoc-each
+ dup empty? [
+ drop
+ "==== ALL TESTS PASSED" print
+ ] [
+ "==== FAILING TESTS:" print
+ [ nl failures. ] assoc-each
+ ] if
] if ;
: run-vocab-tests ( vocabs -- )
diff --git a/extra/ui/tools/deploy/deploy-docs.factor b/extra/ui/tools/deploy/deploy-docs.factor
index 293a391279..e625d26c60 100755
--- a/extra/ui/tools/deploy/deploy-docs.factor
+++ b/extra/ui/tools/deploy/deploy-docs.factor
@@ -13,3 +13,5 @@ $nl
{ $subsection deploy-tool }
"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu."
{ $see-also "tools.deploy" } ;
+
+ABOUT: "ui.tools.deploy"
diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor
index 7b20c4591f..df87d57873 100755
--- a/extra/ui/tools/deploy/deploy.factor
+++ b/extra/ui/tools/deploy/deploy.factor
@@ -81,7 +81,7 @@ TUPLE: deploy-gadget vocab settings ;
close-window ;
: com-help ( -- )
- "ui-deploy" help-window ;
+ "ui.tools.deploy" help-window ;
\ com-help H{
{ +nullary+ t }
From ff1ee9e874e008e5bc48338eb94219aaa26d1624 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Fri, 11 Jan 2008 11:03:18 -1000
Subject: [PATCH 11/45] 2apply and -> both?
---
core/math/intervals/intervals.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 26efbef0df..ab45166f7e 100644
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -85,7 +85,7 @@ C: <interval> interval
: interval-integer-op ( i1 i2 quot -- i3 )
>r 2dup
- [ interval>points [ first integer? ] 2apply and ] 2apply and
+ [ interval>points [ first integer? ] both? ] both?
r> [ 2drop f ] if ; inline
: interval-shift ( i1 i2 -- i3 )
From 824c696e963c8c81a18402e30ac3825d21a0c954 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Fri, 11 Jan 2008 11:04:26 -1000
Subject: [PATCH 12/45] change over slip -> keep
---
extra/combinators/lib/lib.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 44edb0ef96..9356d6c9b5 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -190,4 +190,4 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
] { } assoc>map concat compose ;
: either ( object first second -- ? )
- >r over slip swap [ r> drop ] [ r> call ] ?if ; inline
+ >r keep swap [ r> drop ] [ r> call ] ?if ; inline
From 84891e259186584229c31a971579303730ee4a1d Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Fri, 11 Jan 2008 12:02:44 -1000
Subject: [PATCH 13/45] pick pick -> 2over minor cleanups
---
core/alien/alien.factor | 2 +-
core/assocs/assocs.factor | 4 ++--
core/cpu/x86/assembler/assembler.factor | 6 +++---
core/inference/class/class-tests.factor | 6 +++---
core/kernel/kernel-docs.factor | 2 ++
core/kernel/kernel.factor | 4 +++-
core/math/intervals/intervals.factor | 6 +++---
core/math/math.factor | 2 +-
core/optimizer/backend/backend.factor | 2 +-
core/sequences/sequences.factor | 12 ++++++------
core/slots/slots.factor | 4 ++--
extra/io/nonblocking/nonblocking.factor | 2 +-
extra/shuffle/shuffle.factor | 2 --
extra/ui/gadgets/panes/panes.factor | 4 ++--
14 files changed, 30 insertions(+), 28 deletions(-)
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 3dc1fbfb86..1c8163e2fa 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -93,4 +93,4 @@ TUPLE: alien-invoke library function return parameters ;
TUPLE: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
- pick pick \ alien-invoke-error construct-boa throw ;
+ 2over \ alien-invoke-error construct-boa throw ;
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index a940248198..5079420b54 100644
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -43,7 +43,7 @@ M: assoc assoc-find
inline
: assoc-push-if ( key value quot accum -- )
- >r pick pick 2slip r> roll
+ >r 2over 2slip r> roll
[ >r 2array r> push ] [ 3drop ] if ; inline
: assoc-pusher ( quot -- quot' accum )
@@ -122,7 +122,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
swap [ dupd at* [ nip ] [ drop ] if ] curry change-each ;
: cache ( key assoc quot -- value )
- pick pick at [
+ 2over at [
>r 3drop r>
] [
pick rot >r >r call dup r> r> set-at
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index 3163ce1b41..65bf29a9b0 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/core/cpu/x86/assembler/assembler.factor
@@ -232,14 +232,14 @@ UNION: operand register indirect ;
: rex-prefix ( reg r/m rex.w -- )
#! Compile an AMD64 REX prefix.
- pick pick rex.w? BIN: 01001000 BIN: 01000000 ?
+ 2over rex.w? BIN: 01001000 BIN: 01000000 ?
swap rex.r swap rex.b
dup BIN: 01000000 = [ drop ] [ , ] if ;
: 16-prefix ( reg r/m -- )
[ register-16? ] either? [ HEX: 66 , ] when ;
-: prefix ( reg r/m rex.w -- ) pick pick 16-prefix rex-prefix ;
+: prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
: prefix-1 ( reg rex.w -- ) f swap prefix ;
@@ -290,7 +290,7 @@ UNION: operand register indirect ;
: 2-operand ( dst src op -- )
#! Sets the opcode's direction bit. It is set if the
#! destination is a direct register operand.
- pick pick 16-prefix
+ 2over 16-prefix
direction-bit
operand-size-bit
(2-operand) ;
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 63c117ba6b..a9276bf7c8 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -50,7 +50,7 @@ M: object xyz ;
] unit-test
: (fx-repeat) ( i n quot -- )
- pick pick fixnum>= [
+ 2over fixnum>= [
3drop
] [
[ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
@@ -66,7 +66,7 @@ M: object xyz ;
] unit-test
: (i-repeat) ( i n quot -- )
- pick pick dup xyz drop >= [
+ 2over dup xyz drop >= [
3drop
] [
[ swap >r call 1+ r> ] keep (i-repeat)
@@ -214,7 +214,7 @@ GENERIC: annotate-entry-test-1 ( x -- )
M: fixnum annotate-entry-test-1 drop ;
: (annotate-entry-test-2) ( from to quot -- )
- pick pick >= [
+ 2over >= [
3drop
] [
[ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index aec42d1bde..8f0e4efbd9 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -19,6 +19,7 @@ $nl
{ $subsection 3dup }
{ $subsection dupd }
{ $subsection over }
+{ $subsection 2over }
{ $subsection pick }
{ $subsection tuck }
"Permuting stack elements:"
@@ -160,6 +161,7 @@ HELP: nip ( x y -- y ) $shuffle ;
HELP: 2nip ( x y z -- z ) $shuffle ;
HELP: tuck ( x y -- y x y ) $shuffle ;
HELP: over ( x y -- x y x ) $shuffle ;
+HELP: 2over $shuffle ;
HELP: pick ( x y z -- x y z x ) $shuffle ;
HELP: swap ( x y -- y x ) $shuffle ;
HELP: spin $shuffle ;
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 8ac1fc5fa0..7c4930f5a8 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -12,6 +12,8 @@ IN: kernel
: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline
+: 2over ( x y z -- x y z x y ) pick pick ; inline
+
: clear ( -- ) { } set-datastack ;
! Combinators
@@ -55,7 +57,7 @@ DEFER: if
: keep ( x quot -- x ) over slip ; inline
-: 2keep ( x y quot -- x y ) pick pick 2slip ; inline
+: 2keep ( x y quot -- x y ) 2over 2slip ; inline
: 3keep ( x y z quot -- x y z )
>r 3dup r> -roll 3slip ; inline
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index ab45166f7e..0b4378aa8a 100644
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -66,9 +66,9 @@ C: <interval> interval
[ endpoint-max ] reduce <interval> ;
: (interval-op) ( p1 p2 quot -- p3 )
- pick pick >r >r
- >r >r first r> first r> call
- r> second r> second and 2array ; inline
+ 2over >r >r
+ >r [ first ] 2apply r> call
+ r> r> [ second ] 2apply and 2array ; inline
: interval-op ( i1 i2 quot -- i3 )
pick interval-from pick interval-from pick (interval-op) >r
diff --git a/core/math/math.factor b/core/math/math.factor
index 54651f51d8..8b48e49f97 100755
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -119,7 +119,7 @@ M: float fp-nan?
: iterate-prep 0 -rot ; inline
-: if-iterate? >r >r pick pick < r> r> if ; inline
+: if-iterate? >r >r 2over < r> r> if ; inline
: iterate-step ( i n quot -- i n quot )
#! Apply quot to i, keep i and quot, hide n.
diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor
index 9da5679ea9..9332f31902 100644
--- a/core/optimizer/backend/backend.factor
+++ b/core/optimizer/backend/backend.factor
@@ -225,7 +225,7 @@ M: #dispatch optimize-node*
#! t indicates failure
{
{ [ dup t eq? ] [ 3drop t ] }
- { [ pick pick swap node-history member? ] [ 3drop t ] }
+ { [ 2over swap node-history member? ] [ 3drop t ] }
{ [ t ] [ (splice-method) ] }
} cond ;
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index d4b5633210..a0c909bf56 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -194,7 +194,7 @@ TUPLE: slice-error reason ;
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when
dup length pick < [ "end > sequence" slice-error ] when
- pick pick > [ "start > end" slice-error ] when ; inline
+ 2over > [ "start > end" slice-error ] when ; inline
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
@@ -445,7 +445,7 @@ PRIVATE>
[ = not ] with subset ;
: cache-nth ( i seq quot -- elt )
- pick pick ?nth dup [
+ 2over ?nth dup [
>r 3drop r>
] [
drop swap >r over >r call dup r> r> set-nth
@@ -465,7 +465,7 @@ M: sequence <=>
[ mismatch not ] [ 2drop f ] if ; inline
: move ( to from seq -- )
- pick pick number=
+ 2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
: (delete) ( elt store scan seq -- elt store scan seq )
@@ -499,15 +499,15 @@ M: sequence <=>
: pop* ( seq -- ) dup length 1- swap set-length ;
: move-backward ( shift from to seq -- )
- pick pick number= [
+ 2over number= [
2drop 2drop
] [
- [ >r pick pick + pick r> move >r 1+ r> ] keep
+ [ >r 2over + pick r> move >r 1+ r> ] keep
move-backward
] if ;
: move-forward ( shift from to seq -- )
- pick pick number= [
+ 2over number= [
2drop 2drop
] [
[ >r pick >r dup dup r> + swap r> move 1- ] keep
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 743929ebdb..4517ee4363 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -89,8 +89,8 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ;
: simple-slot ( class name # -- spec )
>r object bootstrap-word over r> f f <slot-spec>
- pick pick simple-reader-word over set-slot-spec-reader
- rot rot simple-writer-word over set-slot-spec-writer ;
+ 2over simple-reader-word over set-slot-spec-reader
+ -rot simple-writer-word over set-slot-spec-writer ;
: simple-slots ( class slots base -- specs )
over length [ + ] with map
diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor
index 8af2702c69..9ff21aa011 100755
--- a/extra/io/nonblocking/nonblocking.factor
+++ b/extra/io/nonblocking/nonblocking.factor
@@ -113,7 +113,7 @@ M: input-port stream-read
] if ;
: read-until-loop ( seps port sbuf -- separator/f )
- pick pick read-until-step over [
+ 2over read-until-step over [
>r over push-all r> dup [
>r 3drop r>
] [
diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor
index b0fdd952d5..f9f8b030a8 100644
--- a/extra/shuffle/shuffle.factor
+++ b/extra/shuffle/shuffle.factor
@@ -21,8 +21,6 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
-: 2over ( a b c -- a b c a b ) pick pick ; inline
-
: nipd ( a b c -- b c ) rot drop ; inline
: 3nip ( a b c d -- d ) 3 nnip ; inline
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 15547ce8db..016d02e527 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -105,7 +105,7 @@ C: <pane-stream> pane-stream
: pane-format ( style pane seq -- )
[ dup pane-nl ]
- [ pick pick pane-current stream-format ]
+ [ 2over pane-current stream-format ]
interleave 2drop ;
GENERIC: write-gadget ( gadget stream -- )
@@ -327,7 +327,7 @@ M: paragraph stream-format
] [
rot " " split
[ 2dup gadget-bl ]
- [ pick pick gadget-format ] interleave
+ [ 2over gadget-format ] interleave
2drop
] if ;
From c8d4846a0367ac27b188d2ddf609a41b2f7259e2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 04:25:16 -0500
Subject: [PATCH 14/45] Fix some compiled-usage issues
---
core/compiler/compiler.factor | 28 +++++++---------------
core/compiler/test/redefine.factor | 17 ++++++++++++-
core/graphs/graphs-tests.factor | 32 +++++++++++++++++++++++++
core/graphs/graphs.factor | 16 +++++++++++++
core/inference/backend/backend.factor | 8 +++++--
core/inference/state/state-tests.factor | 25 +++++++++++++++++++
core/inference/state/state.factor | 11 ++++++---
core/optimizer/backend/backend.factor | 20 +++++++++-------
8 files changed, 123 insertions(+), 34 deletions(-)
create mode 100644 core/inference/state/state-tests.factor
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index af0ac8ac89..784104d57f 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -13,33 +13,22 @@ compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
2dup "compiled-uses" set-word-prop
- compiled-crossref get add-vertex ;
+ compiled-crossref get add-vertex* ;
: compiled-unxref ( word -- )
dup "compiled-uses" word-prop
- compiled-crossref get remove-vertex ;
+ compiled-crossref get remove-vertex* ;
-: compiled-usage ( word -- seq )
- compiled-crossref get at keys ;
-
-: sensitive? ( word -- ? )
- dup "inline" word-prop
- over "infer" word-prop
- pick "specializer" word-prop
- roll generic?
- or or or ;
+: compiled-usage ( word -- assoc )
+ compiled-crossref get at ;
: compiled-usages ( words -- seq )
- compiled-crossref get [
- [
- over dup set
- over sensitive?
- [ at namespace swap update ] [ 2drop ] if
- ] curry each
- ] H{ } make-assoc keys ;
+ [ [ dup ] H{ } map>assoc dup ] keep [
+ compiled-usage [ nip +inlined+ eq? ] assoc-subset update
+ ] with each keys ;
: ripple-up ( word -- )
- compiled-usage [ queue-compile ] each ;
+ compiled-usage [ drop queue-compile ] assoc-each ;
: save-effect ( word effect -- )
over "compiled-uses" word-prop [
@@ -60,7 +49,6 @@ compiled-crossref global [ H{ } assoc-like ] change-at
] computing-dependencies ;
: compile-failed ( word error -- )
- ! dup inference-error? [ rethrow ] unless
f pick compiled get set-at
swap compiler-error ;
diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor
index d9ba349cc2..821daef203 100755
--- a/core/compiler/test/redefine.factor
+++ b/core/compiler/test/redefine.factor
@@ -92,7 +92,7 @@ DEFER: x-4
[ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test
-[ t ] [ \ x-3 "compiled-uses" word-prop [ interned? ] all? ] unit-test
+[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test
DEFER: g-test-1
@@ -190,3 +190,18 @@ DEFER: inline-then-not-inline-test-2
[ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test
[ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test
+
+DEFER: generic-then-not-generic-test-1
+DEFER: generic-then-not-generic-test-2
+
+[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test
+
+[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test
+
+[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test
+
+[ 9 ] [ generic-then-not-generic-test-2 ] unit-test
+
+[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
+
+[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
diff --git a/core/graphs/graphs-tests.factor b/core/graphs/graphs-tests.factor
index c68ecca3d9..90b0e93b7c 100644
--- a/core/graphs/graphs-tests.factor
+++ b/core/graphs/graphs-tests.factor
@@ -16,3 +16,35 @@ H{
[ { 2 3 4 5 } ] [
2 [ "g" get at ] closure keys natural-sort
] unit-test
+
+H{ } "g" set
+
+[ ] [
+ "mary"
+ H{ { "billy" "one" } { "joey" "two" } }
+ "g" get add-vertex*
+] unit-test
+
+[ H{ { "mary" "one" } } ] [
+ "billy" "g" get at
+] unit-test
+
+[ ] [
+ "liz"
+ H{ { "billy" "four" } { "fred" "three" } }
+ "g" get add-vertex*
+] unit-test
+
+[ H{ { "mary" "one" } { "liz" "four" } } ] [
+ "billy" "g" get at
+] unit-test
+
+[ ] [
+ "mary"
+ H{ { "billy" "one" } { "joey" "two" } }
+ "g" get remove-vertex*
+] unit-test
+
+[ H{ { "liz" "four" } } ] [
+ "billy" "g" get at
+] unit-test
diff --git a/core/graphs/graphs.factor b/core/graphs/graphs.factor
index 853589532d..973d49f1fa 100644
--- a/core/graphs/graphs.factor
+++ b/core/graphs/graphs.factor
@@ -16,9 +16,25 @@ SYMBOL: graph
: add-vertex ( vertex edges graph -- )
[ [ dupd nest set-at ] with each ] if-graph ; inline
+: (add-vertex) ( key value vertex -- )
+ rot nest set-at ;
+
+: add-vertex* ( vertex edges graph -- )
+ [
+ swap [ (add-vertex) ] curry assoc-each
+ ] if-graph ; inline
+
: remove-vertex ( vertex edges graph -- )
[ [ graph get at delete-at ] with each ] if-graph ; inline
+: (remove-vertex) ( key value vertex -- )
+ rot graph get at delete-at drop ;
+
+: remove-vertex* ( vertex edges graph -- )
+ [
+ swap [ (remove-vertex) ] curry assoc-each
+ ] if-graph ; inline
+
SYMBOL: previous
: (closure) ( obj quot -- )
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 3afbe3bc8e..cf2d021430 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -76,7 +76,8 @@ GENERIC: apply-object ( obj -- )
M: object apply-object apply-literal ;
-M: wrapper apply-object wrapped dup depends-on apply-literal ;
+M: wrapper apply-object
+ wrapped dup +called+ depends-on apply-literal ;
: terminate ( -- )
terminated? on #terminate node, ;
@@ -372,6 +373,7 @@ TUPLE: effect-error word effect ;
: custom-infer ( word -- )
#! Customized inference behavior
+ dup +inlined+ depends-on
"infer" word-prop call ;
: cached-infer ( word -- )
@@ -449,10 +451,12 @@ M: #call-label collect-recursion*
] if ;
M: word apply-object
- dup depends-on [
+ [
+ dup +inlined+ depends-on
dup inline-recursive-label
[ declared-infer ] [ inline-word ] if
] [
+ dup +called+ depends-on
dup recursive-label
[ declared-infer ] [ apply-word ] if
] if-inline ;
diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor
new file mode 100644
index 0000000000..e9c31171ed
--- /dev/null
+++ b/core/inference/state/state-tests.factor
@@ -0,0 +1,25 @@
+IN: temporary
+USING: tools.test inference.state ;
+
+SYMBOL: a
+SYMBOL: b
+
+[ ] [ a +called+ depends-on ] unit-test
+
+[ H{ { a +called+ } } ] [
+ [ a +called+ depends-on ] computing-dependencies
+] unit-test
+
+[ H{ { a +called+ } { b +inlined+ } } ] [
+ [
+ a +called+ depends-on b +inlined+ depends-on
+ ] computing-dependencies
+] unit-test
+
+[ H{ { a +inlined+ } { b +inlined+ } } ] [
+ [
+ a +inlined+ depends-on
+ a +called+ depends-on
+ b +inlined+ depends-on
+ ] computing-dependencies
+] unit-test
diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor
index f1b2bff316..cf11ffc88a 100755
--- a/core/inference/state/state.factor
+++ b/core/inference/state/state.factor
@@ -31,11 +31,16 @@ SYMBOL: current-node
! Words that the current dataflow IR depends on
SYMBOL: dependencies
-: depends-on ( word -- )
- dup dependencies get dup [ set-at ] [ 3drop ] if ;
+SYMBOL: +inlined+
+SYMBOL: +called+
+
+: depends-on ( word how -- )
+ swap dependencies get dup [
+ 2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
+ ] [ 3drop ] if ;
: computing-dependencies ( quot -- dependencies )
- H{ } clone [ dependencies rot with-variable ] keep keys ;
+ H{ } clone [ dependencies rot with-variable ] keep ;
inline
! Did the current control-flow path throw an error?
diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor
index 9332f31902..1122d83129 100644
--- a/core/optimizer/backend/backend.factor
+++ b/core/optimizer/backend/backend.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs inference inference.class
-inference.dataflow inference.backend io kernel math namespaces
-sequences vectors words quotations hashtables combinators
-classes generic.math continuations optimizer.def-use
+inference.dataflow inference.backend inference.state io kernel
+math namespaces sequences vectors words quotations hashtables
+combinators classes generic.math continuations optimizer.def-use
optimizer.pattern-match generic.standard ;
IN: optimizer.backend
@@ -173,8 +173,8 @@ M: node remember-method*
2drop ;
: remember-method ( method-spec node -- )
- swap dup
- [ [ swap remember-method* ] curry each-node ] [ 2drop ] if ;
+ swap dup second +inlined+ depends-on
+ [ swap remember-method* ] curry each-node ;
: (splice-method) ( #call method-spec quot -- node )
#! Must remember the method before splicing in, otherwise
@@ -184,7 +184,10 @@ M: node remember-method*
[ swap infer-classes/node ] 2keep
[ substitute-node ] keep ;
-: splice-quot ( #call quot -- node ) f swap (splice-method) ;
+: splice-quot ( #call quot -- node )
+ over node-in-d dataflow-with
+ [ swap infer-classes/node ] 2keep
+ [ substitute-node ] keep ;
: drop-inputs ( node -- #shuffle )
node-in-d clone \ #shuffle in-node ;
@@ -358,7 +361,8 @@ M: #dispatch optimize-node*
] if ;
: optimistic-inline ( #call -- node )
- dup node-param word-def splice-quot ;
+ dup node-param dup +inlined+ depends-on
+ word-def splice-quot ;
M: #call optimize-node*
{
From 64d47e50773ebabb66c5159c1894937ec435e1c3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 04:25:27 -0500
Subject: [PATCH 15/45] Get tuple-arrays to load
---
extra/tuple-arrays/tuple-arrays-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/tuple-arrays/tuple-arrays-docs.factor b/extra/tuple-arrays/tuple-arrays-docs.factor
index a90068ed57..d6949eaeac 100644
--- a/extra/tuple-arrays/tuple-arrays-docs.factor
+++ b/extra/tuple-arrays/tuple-arrays-docs.factor
@@ -1,4 +1,5 @@
-USING: help.syntax help.markup tuple-arrays splitting kernel ;
+USING: help.syntax help.markup splitting kernel ;
+IN: tuple-arrays
HELP: tuple-array
{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. Packed follows the sequence protocol and is implemented using the " { $link groups } " class." } ;
From 8b8ebaacc85a037a22bc1e15f53fdfabcc426b10 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 07:42:47 -1000
Subject: [PATCH 16/45] small cleanups from lint
---
core/io/files/files.factor | 10 +++++-----
core/math/intervals/intervals.factor | 2 +-
extra/combinators/cleave/cleave.factor | 4 ++--
extra/random/random.factor | 2 +-
4 files changed, 9 insertions(+), 9 deletions(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 7bd9599e4d..6e4648b590 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -35,7 +35,11 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
-: exists? ( path -- ? ) stat >r 3drop r> >boolean ;
+: file-length ( path -- n ) stat 4array third ;
+
+: file-modified ( path -- n ) stat >r 3drop r> ; inline
+
+: exists? ( path -- ? ) file-modified >boolean ;
: directory? ( path -- ? ) stat 3drop ;
@@ -52,10 +56,6 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;
-: file-length ( path -- n ) stat 4array third ;
-
-: file-modified ( path -- n ) stat >r 3drop r> ;
-
: last-path-separator ( path -- n ? )
[ length 2 [-] ] keep [ path-separator? ] find-last* ;
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 0b4378aa8a..b7eb5be8c9 100644
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -68,7 +68,7 @@ C: <interval> interval
: (interval-op) ( p1 p2 quot -- p3 )
2over >r >r
>r [ first ] 2apply r> call
- r> r> [ second ] 2apply and 2array ; inline
+ r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 )
pick interval-from pick interval-from pick (interval-op) >r
diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor
index 85381ec499..e1e3585813 100644
--- a/extra/combinators/cleave/cleave.factor
+++ b/extra/combinators/cleave/cleave.factor
@@ -7,7 +7,7 @@ IN: combinators.cleave
! The cleaver family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: bi ( obj quot quot -- val val ) >r over slip r> call ; inline
+: bi ( obj quot quot -- val val ) >r keep r> call ; inline
: tri ( obj quot quot quot -- val val val )
>r pick >r bi r> r> call ; inline
@@ -23,7 +23,7 @@ IN: combinators.cleave
! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: bi* ( obj obj quot quot -- val val ) >r swap >r call r> r> call ; inline
+: bi* ( obj obj quot quot -- val val ) >r swap slip r> call ; inline
: tri* ( obj obj obj quot quot quot -- val val val )
>r rot >r bi* r> r> call ; inline
diff --git a/extra/random/random.factor b/extra/random/random.factor
index 6045da72d8..db2aacd2b0 100755
--- a/extra/random/random.factor
+++ b/extra/random/random.factor
@@ -36,7 +36,7 @@ SYMBOL: mt
: set-mt-ith ( y i-get i-set -- )
>r mt-nth >r
- [ -1 shift ] keep odd? mt-a 0 ? r> bitxor bitxor r>
+ [ 2/ ] keep odd? mt-a 0 ? r> bitxor bitxor r>
mt-seq set-nth ; inline
: mt-y ( y1 y2 -- y )
From 3f7943fb085a90d0b67e02b7d6466305fadb7acd Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 09:09:49 -1000
Subject: [PATCH 17/45] more cleanups, lint fix
---
core/continuations/continuations.factor | 2 +-
extra/inverse/inverse.factor | 2 +-
extra/lint/lint.factor | 32 ++++++++++++++-----------
extra/visitor/visitor.factor | 2 +-
4 files changed, 21 insertions(+), 17 deletions(-)
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index 27ed277c6c..278264c17d 100755
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -128,7 +128,7 @@ PRIVATE>
: cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry
- >r (catch) r> ifcc r> call ; inline
+ recover r> call ; inline
: attempt-all ( seq quot -- obj )
[
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index 583ae610c0..cade645dde 100644
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -69,7 +69,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
} cond ;
: math-exp? ( n n word -- ? )
- { + - * / ^ } member? -rot [ number? ] 2apply and and ;
+ { + - * / ^ } member? -rot [ number? ] both? and ;
: (fold-constants) ( quot -- )
dup length 3 < [ % ] [
diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor
index 9299e6075e..37209182a0 100644
--- a/extra/lint/lint.factor
+++ b/extra/lint/lint.factor
@@ -83,7 +83,8 @@ def-hash get-global [
! Remove n m shift defs
[
drop dup length 3 = [
- dup first2 [ number? ] 2apply and swap third \ shift = and not
+ dup first2 [ number? ] both?
+ swap third \ shift = and not
] [ drop t ] if
] assoc-subset
@@ -132,22 +133,21 @@ M: word lint ( word -- seq )
GENERIC: run-lint ( obj -- obj )
+: (trim-self)
+ def-hash get-global at* [
+ dupd remove empty? not
+ ] [
+ drop f
+ ] if ;
+
: trim-self ( seq -- newseq )
- [
- first2 [
- def-hash get-global at* [
- dupd remove empty? not
- ] [
- drop f
- ] if
- ] subset 2array
- ] map ;
+ [ [ (trim-self) ] subset ] assoc-map ;
M: sequence run-lint ( seq -- seq )
[
global [ dup . flush ] bind
- dup lint 2array
- ] map
+ dup lint
+ ] { } map>assoc
trim-self
[ second empty? not ] subset ;
@@ -155,5 +155,9 @@ M: word run-lint ( word -- seq )
1array run-lint ;
: lint-all ( -- seq )
- all-words run-lint dup [ lint. ] each ;
-
+ all-words run-lint
+ [
+ nip first dup def-hash get at
+ [ first ] 2apply literalize = not
+ ] assoc-subset
+ dup [ lint. ] each ;
diff --git a/extra/visitor/visitor.factor b/extra/visitor/visitor.factor
index dd6bad7d97..10c9fb8717 100644
--- a/extra/visitor/visitor.factor
+++ b/extra/visitor/visitor.factor
@@ -43,7 +43,7 @@ IN: visitor
PREDICATE: standard-generic visitor "visitors" word-prop ;
PREDICATE: array triple length 3 = ;
PREDICATE: triple visitor-spec
- first3 visitor? >r [ class? ] 2apply and r> and ;
+ first3 visitor? >r [ class? ] both? r> and ;
M: visitor-spec definer drop \ V: \ ; ;
M: visitor definer drop \ VISITOR: f ;
From cafa8cf4a1a23b014ce2d704a7b298a7b348f894 Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Sat, 12 Jan 2008 23:05:02 +0100
Subject: [PATCH 18/45] Fix statistics-docs
---
extra/math/statistics/statistics-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/math/statistics/statistics-docs.factor b/extra/math/statistics/statistics-docs.factor
index bb92178e6d..620501c16e 100644
--- a/extra/math/statistics/statistics-docs.factor
+++ b/extra/math/statistics/statistics-docs.factor
@@ -1,4 +1,5 @@
-USING: math.statistics help.markup help.syntax debugger ;
+USING: help.markup help.syntax debugger ;
+IN: math.statistics
HELP: geometric-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
From b6b9e6cc05106ed8315b2080832e468c5c54b521 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 12:23:34 -1000
Subject: [PATCH 19/45] lint cleanups
---
extra/calendar/calendar.factor | 7 ++++---
extra/lazy-lists/lazy-lists.factor | 2 +-
extra/opengl/opengl.factor | 2 +-
extra/pack/pack.factor | 7 ++-----
extra/random-weighted/random-weighted.factor | 2 +-
extra/slides/slides.factor | 2 +-
extra/tar/tar.factor | 6 +++---
7 files changed, 13 insertions(+), 15 deletions(-)
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 9a54608126..4e473279fa 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -4,7 +4,7 @@
USING: arrays hashtables io io.streams.string kernel math
math.vectors math.functions math.parser namespaces sequences
strings tuples system debugger combinators vocabs.loader
-calendar.backend structs alien.c-types ;
+calendar.backend structs alien.c-types math.vectors ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
@@ -186,7 +186,8 @@ M: number +second ( timestamp n -- timestamp )
#! data
tuple-slots
{ 1 12 365.2425 8765.82 525949.2 31556952.0 }
- [ / ] 2map sum ;
+ v/ sum ;
+
: dt>months ( dt -- x ) dt>years 12 * ;
: dt>days ( dt -- x ) dt>years 365.2425 * ;
: dt>hours ( dt -- x ) dt>years 8765.82 * ;
@@ -235,7 +236,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
unix-1970 millis 1000 /f seconds +dt ;
: now ( -- timestamp ) gmt >local-time ;
-: before ( dt -- -dt ) tuple-slots [ neg ] map array>dt ;
+: before ( dt -- -dt ) tuple-slots vneg array>dt ;
: from-now ( dt -- timestamp ) now swap +dt ;
: ago ( dt -- timestamp ) before from-now ;
diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor
index a76e0e5f81..1979819dd1 100644
--- a/extra/lazy-lists/lazy-lists.factor
+++ b/extra/lazy-lists/lazy-lists.factor
@@ -319,7 +319,7 @@ TUPLE: lazy-from-by n quot ;
C: lfrom-by lazy-from-by ( n quot -- list )
: lfrom ( n -- list )
- [ 1 + ] lfrom-by ;
+ [ 1+ ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car )
lazy-from-by-n ;
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index aabdccd1fb..f611c97209 100644
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -27,7 +27,7 @@ IN: opengl
swap glBegin call glEnd ; inline
: do-enabled ( what quot -- )
- over glEnable swap slip glDisable ; inline
+ over glEnable dip glDisable ; inline
: do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep
diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor
index c9d05c19d7..b9b1f6f314 100644
--- a/extra/pack/pack.factor
+++ b/extra/pack/pack.factor
@@ -2,7 +2,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 threads vectors
-words macros ;
+words macros math.functions ;
IN: pack
SYMBOL: big-endian
@@ -10,9 +10,6 @@ SYMBOL: big-endian
: big-endian? ( -- ? )
1 <int> *char zero? ;
-: clear-bit ( m n -- o )
- 2^ bitnot bitand ;
-
: >endian ( obj n -- str )
big-endian get [ >be ] [ >le ] if ; inline
@@ -88,7 +85,7 @@ M: string b, ( n string -- ) heap-size b, ;
"\0" read-until [ drop f ] unless ;
: read-c-string* ( n -- str/f )
- read [ 0 = ] right-trim dup empty? [ drop f ] when ;
+ read [ zero? ] right-trim dup empty? [ drop f ] when ;
: (read-128-ber) ( n -- n )
1 read first
diff --git a/extra/random-weighted/random-weighted.factor b/extra/random-weighted/random-weighted.factor
index e3c71ec807..1e9e35d0bf 100644
--- a/extra/random-weighted/random-weighted.factor
+++ b/extra/random-weighted/random-weighted.factor
@@ -4,7 +4,7 @@ USING: kernel namespaces arrays quotations sequences assocs combinators
IN: random-weighted
-: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ;
+: probabilities ( weights -- probabilities ) dup sum v/n ;
: layers ( probabilities -- layers )
dup length 1+ [ head ] with map 1 tail [ sum ] map ;
diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor
index 70a08cdced..ba423699c3 100755
--- a/extra/slides/slides.factor
+++ b/extra/slides/slides.factor
@@ -85,7 +85,7 @@ TUPLE: slides ;
>r first3 r> head 3array ;
: strip-tease ( data -- seq )
- dup third length 1 - [
+ dup third length 1- [
2 + (strip-tease)
] with map ;
diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
index 01a50566b4..4a737f06c2 100644
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -35,7 +35,7 @@ linkname magic version uname gname devmajor devminor prefix ;
: header-checksum ( seq -- x )
148 cut-slice 8 tail-slice
- [ 0 [ + ] reduce ] 2apply + 256 + ;
+ [ sum ] 2apply + 256 + ;
TUPLE: checksum-error ;
TUPLE: malformed-block-error ;
@@ -164,7 +164,7 @@ TUPLE: unimplemented-typeflag header ;
! Long file name
: typeflag-L ( header -- )
<string-writer> [ read-data-blocks ] keep
- >string [ CHAR: \0 = ] right-trim filename set
+ >string [ zero? ] right-trim filename set
global [ "long filename: " write filename get . flush ] bind
filename get tar-path+ make-directories ;
@@ -196,7 +196,7 @@ TUPLE: unimplemented-typeflag header ;
! global [ dup tar-header-name [ print flush ] when* ] bind
dup tar-header-typeflag
{
- { CHAR: \0 [ typeflag-0 ] }
+ { 0 [ typeflag-0 ] }
{ CHAR: 0 [ typeflag-0 ] }
{ CHAR: 1 [ typeflag-1 ] }
{ CHAR: 2 [ typeflag-2 ] }
From 3f4c2aafcfd6c82ec2c2597d6757abf51b616ff7 Mon Sep 17 00:00:00 2001
From: Matt S Trout <mst@shadowcatsystems.co.uk>
Date: Thu, 10 Jan 2008 15:58:27 -0500
Subject: [PATCH 20/45] add Libraries needed for compilation section derived
from FAQ answer 'Which libraries do I need to get the UI working with X11 on
Linux?'
---
README.txt | 12 ++++++++++++
1 file changed, 12 insertions(+)
diff --git a/README.txt b/README.txt
index c5bae96b9c..e62d319c07 100644
--- a/README.txt
+++ b/README.txt
@@ -8,6 +8,7 @@ implementation. It is not an introduction to the language itself.
- Platform support
- Compiling the Factor VM
+- Libraries needed for compilation
- Bootstrapping the Factor image
- Running Factor on Unix with X11
- Running Factor on Mac OS X - Cocoa UI
@@ -59,6 +60,17 @@ for your platform.
Compilation will yield an executable named 'factor' on Unix,
'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
+* Libraries needed for compilation
+
+For X11 support, you need recent development libraries for libc, Freetype,
+X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu),
+you can use the line
+
+sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
+
+to grab everything (if you're on a non-debian-derived distro please tell us
+what the equivalent command is on there and it can be added :)
+
* Bootstrapping the Factor image
The boot images are no longer included with the Factor distribution
From 2165a728b171368c123b740f496fdeade6167eae Mon Sep 17 00:00:00 2001
From: Matt S Trout <mst@shadowcatsystems.co.uk>
Date: Thu, 10 Jan 2008 16:07:33 -0500
Subject: [PATCH 21/45] add a reference to the FAQ to the README.txt
---
README.txt | 5 +++++
1 file changed, 5 insertions(+)
diff --git a/README.txt b/README.txt
index e62d319c07..f92bfe25c7 100644
--- a/README.txt
+++ b/README.txt
@@ -15,6 +15,7 @@ implementation. It is not an introduction to the language itself.
- Running Factor on Mac OS X - X11 UI
- Running Factor on Windows
- Command line usage
+- The Factor FAQ
- Source organization
- Community
@@ -160,6 +161,10 @@ To run the listener in the command prompt:
factor-nt.exe -run=listener
+* The Factor FAQ
+
+The Factor FAQ lives online at http://factorcode.org/faq.fhtml
+
* Command line usage
The Factor VM supports a number of command line switches. To read
From 80d129191ecc8611bbf2bf8d18db69234e16beb3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 12:24:38 -1000
Subject: [PATCH 22/45] small cleanup of shuffle words
---
core/tuples/tuples.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor
index 6eff703cbd..c7deb17e9f 100644
--- a/core/tuples/tuples.factor
+++ b/core/tuples/tuples.factor
@@ -15,7 +15,7 @@ M: tuple class class-of-tuple ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
- over array-capacity over array-capacity dup -rot number= [
+ over array-capacity over array-capacity tuck number= [
-rot
[ >r over r> array-nth >r array-nth r> = ] 2curry
all-integers?
From 4373cb16307d98e95c88ed85fdebd021aa167e3e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 17:25:29 -0500
Subject: [PATCH 23/45] Fix performance prbolem
---
core/parser/parser.factor | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 8dcca00e3a..31a3ceac03 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -437,7 +437,7 @@ SYMBOL: bootstrap-syntax
smudged-usage forget-all
over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
-: finish-parsing ( contents quot -- )
+: finish-parsing ( lines quot -- )
file get
[ record-form ] keep
[ record-modified ] keep
@@ -447,8 +447,7 @@ SYMBOL: bootstrap-syntax
: parse-stream ( stream name -- quot )
[
[
- contents
- dup string-lines parse-fresh
+ lines dup parse-fresh
tuck finish-parsing
forget-smudged
] with-source-file
From cece726e54321ffdf4fc6695b137a9043eec319b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 17:34:26 -0500
Subject: [PATCH 24/45] Make alien.c-types reloadable
---
core/alien/c-types/c-types.factor | 215 +++++++++++++++---------------
1 file changed, 110 insertions(+), 105 deletions(-)
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index 91a2e6efaa..b665300bee 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -3,7 +3,7 @@
USING: byte-arrays arrays generator.registers assocs
kernel kernel.private libc math namespaces parser sequences
strings words assocs splitting math.parser cpu.architecture
-alien quotations system ;
+alien quotations system compiler.units ;
IN: alien.c-types
TUPLE: c-type
@@ -227,130 +227,135 @@ M: long-long-type box-return ( type -- )
define-out ;
: expand-constants ( c-type -- c-type' )
+ #! We use word-def call instead of execute to get around
+ #! staging violations
dup array? [
- unclip >r [ dup word? [ execute ] when ] map r> add*
+ unclip >r [ dup word? [ word-def call ] when ] map
+ r> add*
] when ;
-[ alien-cell ]
-[ set-alien-cell ]
-bootstrap-cell
-"box_alien"
-"alien_offset" <primitive-type>
-"void*" define-primitive-type
+[
+ [ alien-cell ]
+ [ set-alien-cell ]
+ bootstrap-cell
+ "box_alien"
+ "alien_offset" <primitive-type>
+ "void*" define-primitive-type
-[ alien-signed-8 ]
-[ set-alien-signed-8 ]
-8
-"box_signed_8"
-"to_signed_8" <primitive-type> <long-long-type>
-"longlong" define-primitive-type
+ [ alien-signed-8 ]
+ [ set-alien-signed-8 ]
+ 8
+ "box_signed_8"
+ "to_signed_8" <primitive-type> <long-long-type>
+ "longlong" define-primitive-type
-[ alien-unsigned-8 ]
-[ set-alien-unsigned-8 ]
-8
-"box_unsigned_8"
-"to_unsigned_8" <primitive-type> <long-long-type>
-"ulonglong" define-primitive-type
+ [ alien-unsigned-8 ]
+ [ set-alien-unsigned-8 ]
+ 8
+ "box_unsigned_8"
+ "to_unsigned_8" <primitive-type> <long-long-type>
+ "ulonglong" define-primitive-type
-[ alien-signed-cell ]
-[ set-alien-signed-cell ]
-bootstrap-cell
-"box_signed_cell"
-"to_fixnum" <primitive-type>
-"long" define-primitive-type
+ [ alien-signed-cell ]
+ [ set-alien-signed-cell ]
+ bootstrap-cell
+ "box_signed_cell"
+ "to_fixnum" <primitive-type>
+ "long" define-primitive-type
-[ alien-unsigned-cell ]
-[ set-alien-unsigned-cell ]
-bootstrap-cell
-"box_unsigned_cell"
-"to_cell" <primitive-type>
-"ulong" define-primitive-type
+ [ alien-unsigned-cell ]
+ [ set-alien-unsigned-cell ]
+ bootstrap-cell
+ "box_unsigned_cell"
+ "to_cell" <primitive-type>
+ "ulong" define-primitive-type
-[ alien-signed-4 ]
-[ set-alien-signed-4 ]
-4
-"box_signed_4"
-"to_fixnum" <primitive-type>
-"int" define-primitive-type
+ [ alien-signed-4 ]
+ [ set-alien-signed-4 ]
+ 4
+ "box_signed_4"
+ "to_fixnum" <primitive-type>
+ "int" define-primitive-type
-[ alien-unsigned-4 ]
-[ set-alien-unsigned-4 ]
-4
-"box_unsigned_4"
-"to_cell" <primitive-type>
-"uint" define-primitive-type
+ [ alien-unsigned-4 ]
+ [ set-alien-unsigned-4 ]
+ 4
+ "box_unsigned_4"
+ "to_cell" <primitive-type>
+ "uint" define-primitive-type
-[ alien-signed-2 ]
-[ set-alien-signed-2 ]
-2
-"box_signed_2"
-"to_fixnum" <primitive-type>
-"short" define-primitive-type
+ [ alien-signed-2 ]
+ [ set-alien-signed-2 ]
+ 2
+ "box_signed_2"
+ "to_fixnum" <primitive-type>
+ "short" define-primitive-type
-[ alien-unsigned-2 ]
-[ set-alien-unsigned-2 ]
-2
-"box_unsigned_2"
-"to_cell" <primitive-type>
-"ushort" define-primitive-type
+ [ alien-unsigned-2 ]
+ [ set-alien-unsigned-2 ]
+ 2
+ "box_unsigned_2"
+ "to_cell" <primitive-type>
+ "ushort" define-primitive-type
-[ alien-signed-1 ]
-[ set-alien-signed-1 ]
-1
-"box_signed_1"
-"to_fixnum" <primitive-type>
-"char" define-primitive-type
+ [ alien-signed-1 ]
+ [ set-alien-signed-1 ]
+ 1
+ "box_signed_1"
+ "to_fixnum" <primitive-type>
+ "char" define-primitive-type
-[ alien-unsigned-1 ]
-[ set-alien-unsigned-1 ]
-1
-"box_unsigned_1"
-"to_cell" <primitive-type>
-"uchar" define-primitive-type
+ [ alien-unsigned-1 ]
+ [ set-alien-unsigned-1 ]
+ 1
+ "box_unsigned_1"
+ "to_cell" <primitive-type>
+ "uchar" define-primitive-type
-[ alien-unsigned-4 zero? not ]
-[ 1 0 ? set-alien-unsigned-4 ]
-4
-"box_boolean"
-"to_boolean" <primitive-type>
-"bool" define-primitive-type
+ [ alien-unsigned-4 zero? not ]
+ [ 1 0 ? set-alien-unsigned-4 ]
+ 4
+ "box_boolean"
+ "to_boolean" <primitive-type>
+ "bool" define-primitive-type
-[ alien-float ]
-[ >r >r >float r> r> set-alien-float ]
-4
-"box_float"
-"to_float" <primitive-type>
-"float" define-primitive-type
+ [ alien-float ]
+ [ >r >r >float r> r> set-alien-float ]
+ 4
+ "box_float"
+ "to_float" <primitive-type>
+ "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
+ 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>
-"double" define-primitive-type
+ [ alien-double ]
+ [ >r >r >float r> r> set-alien-double ]
+ 8
+ "box_double"
+ "to_double" <primitive-type>
+ "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
+ 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>
-"char*" define-primitive-type
+ [ alien-cell alien>char-string ]
+ [ set-alien-cell ]
+ bootstrap-cell
+ "box_char_string"
+ "alien_offset" <primitive-type>
+ "char*" define-primitive-type
-"char*" "uchar*" typedef
+ "char*" "uchar*" typedef
-[ string>char-alien ] "char*" c-type set-c-type-prep
+ [ 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>
-"ushort*" define-primitive-type
+ [ alien-cell alien>u16-string ]
+ [ set-alien-cell ]
+ 4
+ "box_u16_string"
+ "alien_offset" <primitive-type>
+ "ushort*" define-primitive-type
-[ string>u16-alien ] "ushort*" c-type set-c-type-prep
+ [ string>u16-alien ] "ushort*" c-type set-c-type-prep
+] with-compilation-unit
From 1a43d30d54ead60ebdc836cf1c45e1423990be22 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 18:00:28 -0500
Subject: [PATCH 25/45] Fix tuple class redefinition not updating constructor
---
core/inference/transforms/transforms.factor | 11 ++++++++---
core/tuples/tuples.factor | 2 +-
2 files changed, 9 insertions(+), 4 deletions(-)
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index e36d703be8..62c3129f3a 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -61,6 +61,11 @@ M: pair (bitfield-quot) ( spec -- quot )
\ set-slots [ <reversed> [get-slots] ] 1 define-transform
-\ construct-boa [
- dup tuple-size [ <tuple-boa> ] 2curry
-] 1 define-transform
+: [construct] ( word quot -- newquot )
+ >r dup +inlined+ depends-on dup tuple-size r> 2curry ;
+
+\ construct-boa
+[ [ <tuple-boa> ] [construct] ] 1 define-transform
+
+\ construct-empty
+[ [ <tuple> ] [construct] ] 1 define-transform
diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor
index 6eff703cbd..476cf4fa38 100644
--- a/core/tuples/tuples.factor
+++ b/core/tuples/tuples.factor
@@ -59,7 +59,7 @@ M: tuple class class-of-tuple ;
] unless
] when 2drop ;
-GENERIC: tuple-size ( class -- size ) foldable
+GENERIC: tuple-size ( class -- size )
M: tuple-class tuple-size "slot-names" word-prop length 2 + ;
From 50e6aca63336cf6c42cdceae375979a36a40a4b5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 18:00:41 -0500
Subject: [PATCH 26/45] Unit test fix
---
core/parser/parser-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 8b308da57f..55d43ce8e0 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -301,7 +301,7 @@ IN: temporary
] unit-test
[ ] [
- "IN: temporary GENERIC: killer?"
+ "IN: temporary GENERIC: killer? ( a -- b )"
<string-reader> "removing-the-predicate" parse-stream drop
] unit-test
From 2d6d22175eeb125d66aefc083e449a585418f369 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 18:46:22 -0500
Subject: [PATCH 27/45] x86 backend work
---
core/cpu/x86/64/bootstrap.factor | 3 +--
core/cpu/x86/bootstrap.factor | 15 +++++++++------
2 files changed, 10 insertions(+), 8 deletions(-)
diff --git a/core/cpu/x86/64/bootstrap.factor b/core/cpu/x86/64/bootstrap.factor
index 9d3fa8849f..f2e84ca528 100644
--- a/core/cpu/x86/64/bootstrap.factor
+++ b/core/cpu/x86/64/bootstrap.factor
@@ -8,10 +8,9 @@ IN: bootstrap.x86
: arg0 RDI ;
: arg1 RSI ;
+: temp-reg RBX ;
: stack-reg RSP ;
: ds-reg R14 ;
-: scan-reg RBX ;
-: xt-reg RCX ;
: fixnum>slot@ ;
"resource:core/cpu/x86/bootstrap.factor" run-file
diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor
index 8fe5127ab0..275ffe6aab 100755
--- a/core/cpu/x86/bootstrap.factor
+++ b/core/cpu/x86/bootstrap.factor
@@ -13,7 +13,8 @@ big-endian off
[
! Load word
- temp-reg 0 [] MOV
+ temp-reg 0 MOV
+ temp-reg dup [] MOV
! Bump profiling counter
temp-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
@@ -22,7 +23,7 @@ big-endian off
temp-reg compiled-header-size ADD
! Jump to XT
temp-reg JMP
-] rc-absolute-cell rt-literal 2 jit-profiling jit-define
+] rc-absolute-cell rt-literal 1 jit-profiling jit-define
[
stack-frame-size PUSH ! save stack frame size
@@ -31,10 +32,11 @@ big-endian off
] rc-absolute-cell rt-label 6 jit-prolog jit-define
[
- arg0 0 [] MOV ! load literal
+ arg0 0 MOV ! load literal
+ arg0 dup [] MOV
ds-reg bootstrap-cell ADD ! increment datastack pointer
ds-reg [] arg0 MOV ! store literal on datastack
-] rc-absolute-cell rt-literal 2 jit-push-literal jit-define
+] rc-absolute-cell rt-literal 1 jit-push-literal jit-define
[
arg1 stack-reg MOV ! pass callstack pointer as arg 2
@@ -60,14 +62,15 @@ big-endian off
] rc-absolute-cell rt-literal 1 jit-if-jump jit-define
[
- arg1 0 [] MOV ! load dispatch table
+ arg1 0 MOV ! load dispatch table
+ arg1 dup [] MOV
arg0 ds-reg [] MOV ! load index
fixnum>slot@ ! turn it into an array offset
ds-reg bootstrap-cell SUB ! pop index
arg0 arg1 ADD ! compute quotation location
arg0 arg0 array-start [+] MOV ! load quotation
arg0 quot-xt@ [+] JMP ! execute branch
-] rc-absolute-cell rt-literal 2 jit-dispatch jit-define
+] rc-absolute-cell rt-literal 1 jit-dispatch jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
From bcaea26f320582868c74ede8f2d9ad6ee257af00 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 14:58:42 -1000
Subject: [PATCH 28/45] fix trivial duplication
---
core/cpu/x86/32/32.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index 1104915a9e..d3e33c46bd 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -46,7 +46,7 @@ M: float-regs push-return-reg
: FLD 4 = [ FLDS ] [ FLDL ] if ;
-: load/store-float-return reg-size >r stack-reg swap [+] r> ;
+: load/store-float-return reg-size >r stack@ r> ;
M: float-regs load-return-reg load/store-float-return FLD ;
M: float-regs store-return-reg load/store-float-return FSTP ;
From a2a43e99800c50c8104cae5484ee3bf60726367b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 21:13:40 -0500
Subject: [PATCH 29/45] New fixnum-shift primitive
---
core/bootstrap/primitives.factor | 1 +
vm/math.c | 6 ++++++
vm/math.h | 1 +
vm/primitives.c | 1 +
4 files changed, 9 insertions(+)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 9858ccb5ec..3e93a868ca 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -441,6 +441,7 @@ builtins get num-tags get tail f union-class define-class
{ "fixnum-bitxor" "math.private" }
{ "fixnum-bitnot" "math.private" }
{ "fixnum-shift" "math.private" }
+ { "fixnum-shift-fast" "math.private" }
{ "fixnum<" "math.private" }
{ "fixnum<=" "math.private" }
{ "fixnum>" "math.private" }
diff --git a/vm/math.c b/vm/math.c
index a8bc76c2b1..8c4e7d537a 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -166,6 +166,12 @@ DEFINE_PRIMITIVE(fixnum_shift)
fixnum_to_bignum(x),y)));
}
+DEFINE_PRIMITIVE(fixnum_shift_fast)
+{
+ POP_FIXNUMS(x,y)
+ dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
+}
+
DEFINE_PRIMITIVE(fixnum_less)
{
POP_FIXNUMS(x,y)
diff --git a/vm/math.h b/vm/math.h
index 7e427b4833..d82a373571 100644
--- a/vm/math.h
+++ b/vm/math.h
@@ -22,6 +22,7 @@ DECLARE_PRIMITIVE(fixnum_and);
DECLARE_PRIMITIVE(fixnum_or);
DECLARE_PRIMITIVE(fixnum_xor);
DECLARE_PRIMITIVE(fixnum_shift);
+DECLARE_PRIMITIVE(fixnum_shift_fast);
DECLARE_PRIMITIVE(fixnum_less);
DECLARE_PRIMITIVE(fixnum_lesseq);
DECLARE_PRIMITIVE(fixnum_greater);
diff --git a/vm/primitives.c b/vm/primitives.c
index 9bc1323eae..dd96ee1495 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -33,6 +33,7 @@ void *primitives[] = {
primitive_fixnum_xor,
primitive_fixnum_not,
primitive_fixnum_shift,
+ primitive_fixnum_shift_fast,
primitive_fixnum_less,
primitive_fixnum_lesseq,
primitive_fixnum_greater,
From e3416ec1707b67b52250082743314f27d30688de Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 21:37:44 -0500
Subject: [PATCH 30/45] Faster bit-arrays
---
core/bit-arrays/bit-arrays.factor | 16 +++----
core/cpu/ppc/assembler/assembler.factor | 4 ++
core/cpu/ppc/intrinsics/intrinsics.factor | 48 ++++++++++++++-----
core/inference/class/class-tests.factor | 25 ++++++++++
core/inference/known-words/known-words.factor | 3 ++
core/math/integers/integers-docs.factor | 5 ++
core/math/integers/integers.factor | 2 +-
core/optimizer/math/math.factor | 33 +++++++++++--
8 files changed, 111 insertions(+), 25 deletions(-)
diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor
index d5257e8493..3b847a0060 100755
--- a/core/bit-arrays/bit-arrays.factor
+++ b/core/bit-arrays/bit-arrays.factor
@@ -6,16 +6,14 @@ IN: bit-arrays
<PRIVATE
-: n>cell -5 shift 4 * ; inline
+: n>byte -3 shift ; inline
-: cell/bit ( n alien -- byte bit )
- over n>cell alien-unsigned-4 swap 31 bitand ; inline
+: byte/bit ( n alien -- byte bit )
+ over n>byte alien-unsigned-1 swap 7 bitand ; inline
: set-bit ( ? byte bit -- byte )
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
-: bits>bytes 7 + -3 shift ; inline
-
: bits>cells 31 + -5 shift ; inline
: (set-bits) ( bit-array n -- )
@@ -27,11 +25,13 @@ PRIVATE>
M: bit-array length array-capacity ;
-M: bit-array nth-unsafe cell/bit bit? ;
+M: bit-array nth-unsafe
+ >r >fixnum r> byte/bit bit? ;
M: bit-array set-nth-unsafe
- [ cell/bit set-bit ] 2keep
- swap n>cell set-alien-unsigned-4 ;
+ >r >fixnum r>
+ [ byte/bit set-bit ] 2keep
+ swap n>byte set-alien-unsigned-1 ;
: clear-bits ( bit-array -- ) 0 (set-bits) ;
diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor
index 9bd9e615c5..628022698f 100755
--- a/core/cpu/ppc/assembler/assembler.factor
+++ b/core/cpu/ppc/assembler/assembler.factor
@@ -126,6 +126,10 @@ words math.bitfields io.binary ;
: (XOR) 316 x-form 31 insn ;
: XOR 0 (XOR) ; : XOR. 1 (XOR) ;
+: (NEG) 0 -rot 104 xo-form 31 insn ;
+: NEG 0 0 (NEG) ; : NEG. 0 1 (NEG) ;
+: NEGO 1 0 (NEG) ; : NEGO. 1 1 (NEG) ;
+
: CMPI d-form 11 insn ;
: CMPLI d-form 10 insn ;
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 86db66a61f..d158e8a319 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -166,15 +166,42 @@ IN: cpu.ppc.intrinsics
}
} define-intrinsics
-\ fixnum-shift [
- "out" operand "x" operand "y" get neg SRAWI
- ! Mask off low bits
- "out" operand dup %untag
-] H{
- { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
- { +scratch+ { { f "out" } } }
- { +output+ { "out" } }
-} define-intrinsic
+: %untag-fixnums ( seq -- )
+ [ dup %untag-fixnum ] unique-operands ;
+
+\ fixnum-shift-fast {
+ {
+ [
+ "out" operand "x" operand "y" get neg SRAWI
+ ! Mask off low bits
+ "out" operand dup %untag
+ ] H{
+ { +input+ { { f "x" } { [ ] "y" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+ }
+ }
+ {
+ [
+ { "positive" "end" } [ define-label ] each
+ { "x" "y" } %untag-fixnums
+ 0 "y" operand 0 CMPI
+ "positive" get BGE
+ "y" operand dup NEG
+ "out" operand "x" operand "y" operand SRAW
+ "end" get B
+ "positive" resolve-label
+ "out" operand "x" operand "y" operand SLW
+ "end" resolve-label
+ ! Mask off low bits
+ "out" operand dup %tag-fixnum
+ ] H{
+ { +input+ { { f "x" } { f "y" } } }
+ { +scratch+ { { f "out" } } }
+ { +output+ { "out" } }
+ }
+ }
+} define-intrinsics
: generate-fixnum-mod
#! PowerPC doesn't have a MOD instruction; so we compute
@@ -222,9 +249,6 @@ IN: cpu.ppc.intrinsics
first2 define-fixnum-jump
] each
-: %untag-fixnums ( seq -- )
- [ dup %untag-fixnum ] unique-operands ;
-
: overflow-check ( insn1 insn2 -- )
[
>r 0 0 LI
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index a9276bf7c8..16d9fae36a 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -235,3 +235,28 @@ M: fixnum annotate-entry-test-1 drop ;
[ t ] [
[ 3 + = ] \ equal? inlined?
] unit-test
+
+[ t ] [
+ [ { fixnum fixnum } declare 7 bitand neg shift ]
+ \ shift inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum fixnum } declare 7 bitand neg shift ]
+ \ fixnum-shift inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
+ \ fixnum-shift inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+ \ shift inlined?
+] unit-test
+
+[ f ] [
+ [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+ \ fixnum-shift inlined?
+] unit-test
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 747eeed673..2223dd56b6 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -254,6 +254,9 @@ t over set-effect-terminated?
\ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
\ fixnum-shift make-foldable
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-shift-fast make-foldable
+
\ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
\ bignum= make-foldable
diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor
index b319e028fb..27bab404cd 100755
--- a/core/math/integers/integers-docs.factor
+++ b/core/math/integers/integers-docs.factor
@@ -120,6 +120,11 @@ HELP: fixnum-shift ( x y -- z )
{ $description "Primitive version of " { $link shift } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
+HELP: fixnum-shift-shift ( x y -- z )
+{ $values { "x" fixnum } { "y" fixnum } { "z" fixnum } }
+{ $description "Primitive version of " { $link shift } ". Unlike " { $link fixnum-shift } ", does not perform an overflow check, so the result may be incorrect." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
+
HELP: fixnum+fast ( x y -- z )
{ $values { "x" fixnum } { "y" fixnum } { "z" fixnum } }
{ $description "Primitive version of " { $link + } ". Unlike " { $link fixnum+ } ", does not perform an overflow check, so the result may be incorrect." }
diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor
index 4f03201c02..59a4dff8de 100755
--- a/core/math/integers/integers.factor
+++ b/core/math/integers/integers.factor
@@ -32,7 +32,7 @@ M: fixnum shift >fixnum fixnum-shift ;
M: fixnum bitnot fixnum-bitnot ;
-M: fixnum bit? 2^ bitand 0 > ;
+M: fixnum bit? neg shift 1 bitand 0 > ;
: (fixnum-log2) ( accum n -- accum )
dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;
diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor
index 31ced167a6..ec3c9c15da 100755
--- a/core/optimizer/math/math.factor
+++ b/core/optimizer/math/math.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.
IN: optimizer.math
USING: alien arrays generic hashtables kernel assocs math
@@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io
namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes
generic.math optimizer.pattern-match optimizer.backend
-optimizer.def-use generic.standard ;
+optimizer.def-use generic.standard system ;
{ + bignum+ float+ fixnum+fast } {
{ { number 0 } [ drop ] }
@@ -82,7 +82,7 @@ optimizer.def-use generic.standard ;
{ { @ @ } [ 2drop 0 ] }
} define-identities
-{ shift fixnum-shift bignum-shift } {
+{ shift fixnum-shift fixnum-shift-fast bignum-shift } {
{ { 0 number } [ drop ] }
{ { number 0 } [ drop ] }
} define-identities
@@ -196,7 +196,7 @@ optimizer.def-use generic.standard ;
] 2curry "output-classes" set-word-prop
] each
-{ fixnum-shift shift } [
+{ fixnum-shift fixnum-shift-fast shift } [
[
dup
node-in-d second value-interval*
@@ -439,3 +439,28 @@ most-negative-fixnum most-positive-fixnum [a,b]
[ splice-quot ] curry ,
] { } make 1array define-optimizers
] assoc-each
+
+: fixnum-shift-fast-pos? ( node -- ? )
+ #! Shifting 1 to the left won't overflow if the shift
+ #! count is small enough
+ dup dup node-in-d first node-literal 1 = [
+ dup node-in-d second node-interval
+ 0 cell-bits tag-bits get - 2 - [a,b] interval-subset?
+ ] [ drop f ] if ;
+
+: fixnum-shift-fast-neg? ( node -- ? )
+ #! Shifting any number to the right won't overflow if the
+ #! shift count is small enough
+ dup node-in-d second node-interval
+ cell-bits 1- neg 0 [a,b] interval-subset? ;
+
+: fixnum-shift-fast? ( node -- ? )
+ dup fixnum-shift-fast-pos?
+ [ drop t ] [ fixnum-shift-fast-neg? ] if ;
+
+\ fixnum-shift {
+ {
+ [ dup fixnum-shift-fast? ]
+ [ [ fixnum-shift-fast ] splice-quot ]
+ }
+} define-optimizers
From 2fd1899d84e572bfc599e211ddb1a1059b935741 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 21:38:22 -0500
Subject: [PATCH 31/45] Fix memory safety issue
---
extra/benchmark/nsieve-bits/nsieve-bits.factor | 4 ++--
extra/benchmark/nsieve/nsieve.factor | 2 +-
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/extra/benchmark/nsieve-bits/nsieve-bits.factor b/extra/benchmark/nsieve-bits/nsieve-bits.factor
index c2f8e02996..46ebc6595e 100644
--- a/extra/benchmark/nsieve-bits/nsieve-bits.factor
+++ b/extra/benchmark/nsieve-bits/nsieve-bits.factor
@@ -6,11 +6,11 @@ bit-arrays namespaces io ;
2dup length >= [
3drop
] [
- f pick pick set-nth-unsafe >r over + r> clear-flags
+ f 2over set-nth-unsafe >r over + r> clear-flags
] if ; inline
: (nsieve-bits) ( count i seq -- count )
- 2dup length <= [
+ 2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
rot 1+ -rot ! increment count
diff --git a/extra/benchmark/nsieve/nsieve.factor b/extra/benchmark/nsieve/nsieve.factor
index b9200fb2bb..c567aa8a8f 100644
--- a/extra/benchmark/nsieve/nsieve.factor
+++ b/extra/benchmark/nsieve/nsieve.factor
@@ -10,7 +10,7 @@ arrays namespaces io ;
] if ; inline
: (nsieve) ( count i seq -- count )
- 2dup length <= [
+ 2dup length < [
2dup nth-unsafe [
over dup 2 * pick clear-flags
rot 1+ -rot ! increment count
From ede5bb9243ad98f5156554889535e903ae21dac1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 21:38:57 -0500
Subject: [PATCH 32/45] Updating x86.64 port
---
core/cpu/x86/32/bootstrap.factor | 1 +
core/cpu/x86/64/bootstrap.factor | 1 +
core/cpu/x86/assembler/assembler.factor | 2 +-
core/cpu/x86/bootstrap.factor | 18 +++++++------
core/cpu/x86/intrinsics/intrinsics.factor | 32 +++++++++++++++++------
5 files changed, 37 insertions(+), 17 deletions(-)
diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor
index 423597eb01..4ce4b1684d 100755
--- a/core/cpu/x86/32/bootstrap.factor
+++ b/core/cpu/x86/32/bootstrap.factor
@@ -12,5 +12,6 @@ IN: bootstrap.x86
: stack-reg ESP ;
: ds-reg ESI ;
: fixnum>slot@ arg0 1 SAR ;
+: rex-length 0 ;
"resource:core/cpu/x86/bootstrap.factor" run-file
diff --git a/core/cpu/x86/64/bootstrap.factor b/core/cpu/x86/64/bootstrap.factor
index f2e84ca528..1227369ae8 100644
--- a/core/cpu/x86/64/bootstrap.factor
+++ b/core/cpu/x86/64/bootstrap.factor
@@ -12,5 +12,6 @@ IN: bootstrap.x86
: stack-reg RSP ;
: ds-reg R14 ;
: fixnum>slot@ ;
+: rex-length 1 ;
"resource:core/cpu/x86/bootstrap.factor" run-file
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index 65bf29a9b0..17aa6bbb54 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/core/cpu/x86/assembler/assembler.factor
@@ -81,7 +81,7 @@ SYMBOL: XMM15 \ XMM15 15 128 define-register
: n, >le % ; inline
: 4, 4 n, ; inline
: 2, 2 n, ; inline
-: cell, cell n, ; inline
+: cell, bootstrap-cell n, ; inline
#! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? )
diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor
index 275ffe6aab..ea4cadd51b 100755
--- a/core/cpu/x86/bootstrap.factor
+++ b/core/cpu/x86/bootstrap.factor
@@ -23,25 +23,27 @@ big-endian off
temp-reg compiled-header-size ADD
! Jump to XT
temp-reg JMP
-] rc-absolute-cell rt-literal 1 jit-profiling jit-define
+] rc-absolute-cell rt-literal 1 rex-length + jit-profiling jit-define
[
+ temp-reg 0 MOV ! load XT
stack-frame-size PUSH ! save stack frame size
- 0 PUSH ! push XT
+ temp-reg PUSH ! push XT
arg1 PUSH ! alignment
-] rc-absolute-cell rt-label 6 jit-prolog jit-define
+] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
[
arg0 0 MOV ! load literal
arg0 dup [] MOV
ds-reg bootstrap-cell ADD ! increment datastack pointer
ds-reg [] arg0 MOV ! store literal on datastack
-] rc-absolute-cell rt-literal 1 jit-push-literal jit-define
+] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define
[
+ arg0 0 MOV ! load XT
arg1 stack-reg MOV ! pass callstack pointer as arg 2
- (JMP) drop ! go
-] rc-relative rt-primitive 3 jit-primitive jit-define
+ arg0 JMP ! go
+] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
[
(JMP) drop
@@ -59,7 +61,7 @@ big-endian off
arg0 arg1 [] CMOVNE ! load true branch if not equal
arg0 arg1 bootstrap-cell [+] CMOVE ! load false branch if equal
arg0 quot-xt@ [+] JMP ! jump to quotation-xt
-] rc-absolute-cell rt-literal 1 jit-if-jump jit-define
+] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
[
arg1 0 MOV ! load dispatch table
@@ -70,7 +72,7 @@ big-endian off
arg0 arg1 ADD ! compute quotation location
arg0 arg0 array-start [+] MOV ! load quotation
arg0 quot-xt@ [+] JMP ! execute branch
-] rc-absolute-cell rt-literal 1 jit-dispatch jit-define
+] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index 9f6fb5d3b0..70de7a99ac 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -240,14 +240,30 @@ IN: cpu.x86.intrinsics
}
} define-intrinsics
-\ fixnum-shift [
- "x" operand "y" get neg SAR
- ! Mask off low bits
- "x" operand %untag
-] H{
- { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
- { +output+ { "x" } }
-} define-intrinsic
+\ fixnum-shift-fast {
+ {
+ [
+ "y" operand NEG
+ "y" operand %untag-fixnum
+ "x" operand "y" operand SAR
+ ! Mask off low bits
+ "x" operand %untag
+ ] H{
+ { +input+ { { f "x" } { f "y" } } }
+ { +output+ { "x" } }
+ { +clobber+ { "y" } }
+ }
+ } {
+ [
+ "x" operand "y" get neg SAR
+ ! Mask off low bits
+ "x" operand %untag
+ ] H{
+ { +input+ { { f "x" } { [ ] "y" } } }
+ { +output+ { "x" } }
+ }
+ }
+} define-intrinsics
: %untag-fixnums ( seq -- )
[ %untag-fixnum ] unique-operands ;
From beeb4a90a1bbfee17296632d8d05cf362fee15ac Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 21:39:22 -0500
Subject: [PATCH 33/45] Added unit tests
---
core/compiler/test/intrinsics.factor | 12 ++++++++++++
1 file changed, 12 insertions(+)
diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor
index b6c283ed4d..759258d684 100755
--- a/core/compiler/test/intrinsics.factor
+++ b/core/compiler/test/intrinsics.factor
@@ -441,3 +441,15 @@ cell 8 = [
] keep 2 fixnum+fast
] compile-call
] unit-test
+
+[ 1 ] [
+ 8 -3 [ fixnum-shift-fast ] compile-call
+] unit-test
+
+[ 2 ] [
+ 16 -3 [ fixnum-shift-fast ] compile-call
+] unit-test
+
+[ 8 ] [
+ 1 3 [ fixnum-shift-fast ] compile-call
+] unit-test
From d54fc8172d7a7a60d7d497cb7a6131306fbf0552 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 22:24:27 -0500
Subject: [PATCH 34/45] Assorted fixes
---
core/bootstrap/compiler/compiler.factor | 2 +-
core/compiler/test/intrinsics.factor | 8 ++++++++
core/cpu/ppc/intrinsics/intrinsics.factor | 4 +++-
core/math/integers/integers-docs.factor | 2 +-
4 files changed, 13 insertions(+), 3 deletions(-)
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 9da231ac96..ff9d5c5e1e 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -17,7 +17,7 @@ IN: bootstrap.compiler
"cpu." cpu append require
nl
-"Compiling some words to speed up bootstrap..." write
+"Compiling some words to speed up bootstrap..." write flush
! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically
diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor
index 759258d684..954e45cb66 100755
--- a/core/compiler/test/intrinsics.factor
+++ b/core/compiler/test/intrinsics.factor
@@ -450,6 +450,14 @@ cell 8 = [
16 -3 [ fixnum-shift-fast ] compile-call
] unit-test
+[ 2 ] [
+ 16 [ -3 fixnum-shift-fast ] compile-call
+] unit-test
+
[ 8 ] [
1 3 [ fixnum-shift-fast ] compile-call
] unit-test
+
+[ 8 ] [
+ 1 [ 3 fixnum-shift-fast ] compile-call
+] unit-test
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index d158e8a319..6a49e34d58 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -172,7 +172,8 @@ IN: cpu.ppc.intrinsics
\ fixnum-shift-fast {
{
[
- "out" operand "x" operand "y" get neg SRAWI
+ "out" operand "x" operand "y" get
+ dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
! Mask off low bits
"out" operand dup %untag
] H{
@@ -199,6 +200,7 @@ IN: cpu.ppc.intrinsics
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
+ { +clobber+ { "x" "y" } }
}
}
} define-intrinsics
diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor
index 27bab404cd..aa716c3197 100755
--- a/core/math/integers/integers-docs.factor
+++ b/core/math/integers/integers-docs.factor
@@ -120,7 +120,7 @@ HELP: fixnum-shift ( x y -- z )
{ $description "Primitive version of " { $link shift } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
-HELP: fixnum-shift-shift ( x y -- z )
+HELP: fixnum-shift-fast ( x y -- z )
{ $values { "x" fixnum } { "y" fixnum } { "z" fixnum } }
{ $description "Primitive version of " { $link shift } ". Unlike " { $link fixnum-shift } ", does not perform an overflow check, so the result may be incorrect." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
From 4fb83805780df8e2e2a34c781ca9b64e9dc5cf73 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 22:57:13 -0500
Subject: [PATCH 35/45] Tweaking fixnum-shift-fast
---
core/cpu/ppc/intrinsics/intrinsics.factor | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 6a49e34d58..f1a696b4e4 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -185,22 +185,21 @@ IN: cpu.ppc.intrinsics
{
[
{ "positive" "end" } [ define-label ] each
- { "x" "y" } %untag-fixnums
+ "y" operand "out" operand swap %untag-fixnum
0 "y" operand 0 CMPI
"positive" get BGE
"y" operand dup NEG
- "out" operand "x" operand "y" operand SRAW
+ "out" operand "x" operand "out" operand SRAW
"end" get B
"positive" resolve-label
- "out" operand "x" operand "y" operand SLW
+ "out" operand "x" operand "out" operand SLW
"end" resolve-label
! Mask off low bits
- "out" operand dup %tag-fixnum
+ "out" operand dup %untag
] H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
- { +clobber+ { "x" "y" } }
}
}
} define-intrinsics
From 36f31e784b665ba1a2b9b1dcb054f18085b482da Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 12 Jan 2008 20:50:22 -0800
Subject: [PATCH 36/45] Fixing x86.64 port
---
core/cpu/x86/64/64.factor | 6 ++--
core/cpu/x86/intrinsics/intrinsics.factor | 37 +++++++----------------
2 files changed, 13 insertions(+), 30 deletions(-)
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index 08952792f6..745b6efd2d 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -173,8 +173,8 @@ USE: cpu.x86.intrinsics
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
+<< "void*" c-type clone "__stack_value" define-primitive-type
+T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
@@ -200,5 +200,3 @@ M: struct-type flatten-value-type ( type -- seq )
"void*" "double" ? c-type ,
] each
] if ;
-
-12 profiler-prologue set-global
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index 70de7a99ac..0e9d66498d 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2006 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays cpu.x86.assembler cpu.x86.allot
cpu.x86.architecture cpu.architecture kernel kernel.private math
@@ -240,34 +240,19 @@ IN: cpu.x86.intrinsics
}
} define-intrinsics
-\ fixnum-shift-fast {
- {
- [
- "y" operand NEG
- "y" operand %untag-fixnum
- "x" operand "y" operand SAR
- ! Mask off low bits
- "x" operand %untag
- ] H{
- { +input+ { { f "x" } { f "y" } } }
- { +output+ { "x" } }
- { +clobber+ { "y" } }
- }
- } {
- [
- "x" operand "y" get neg SAR
- ! Mask off low bits
- "x" operand %untag
- ] H{
- { +input+ { { f "x" } { [ ] "y" } } }
- { +output+ { "x" } }
- }
- }
-} define-intrinsics
-
: %untag-fixnums ( seq -- )
[ %untag-fixnum ] unique-operands ;
+\ fixnum-shift-fast [
+ "x" operand "y" get
+ dup 0 < [ neg SAR ] [ SHL ] if
+ ! Mask off low bits
+ "x" operand %untag
+] H{
+ { +input+ { { f "x" } { [ ] "y" } } }
+ { +output+ { "x" } }
+} define-intrinsic
+
: overflow-check ( word -- )
"end" define-label
"z" operand "x" operand MOV
From bdb160dd6c430df3068032e9317c6366d8bf8eb2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 19:49:36 -1000
Subject: [PATCH 37/45] compile-1 -> compile-call
---
extra/random-tester/random-tester.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor
index f8aa0f29b5..c3a1ecbec4 100644
--- a/extra/random-tester/random-tester.factor
+++ b/extra/random-tester/random-tester.factor
@@ -22,7 +22,7 @@ TUPLE: random-tester-error ;
datastack clone after set
clear
before get [ ] each
- quot get [ compile-1 ] [ errored on ] recover ;
+ quot get [ compile-call ] [ errored on ] recover ;
: do-test ! ( data... quot -- )
.s flush test-compiler
From 3fd394d06e69d18dba24c1237f21706ed943f199 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 13 Jan 2008 00:56:31 -0500
Subject: [PATCH 38/45] Add fixnum>float intrinsic for PowerPC; speeds up
spectral norm
---
core/cpu/ppc/intrinsics/intrinsics.factor | 22 ++++++++++++++++++++--
1 file changed, 20 insertions(+), 2 deletions(-)
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index f1a696b4e4..34197fdef3 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -360,9 +360,10 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: define-float-op ( word op -- )
- [ "x" operand "x" operand "y" operand ] swap add H{
+ [ "z" operand "x" operand "y" operand ] swap add H{
{ +input+ { { float "x" } { float "y" } } }
- { +output+ { "x" } }
+ { +scratch+ { { float "z" } } }
+ { +output+ { "z" } }
} define-intrinsic ;
{
@@ -399,6 +400,23 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } }
} define-intrinsic
+\ fixnum>float [
+ HEX: 4330 "scratch" operand LIS
+ "scratch" operand 1 0 param@ STW
+ "scratch" operand "in" operand %untag-fixnum
+ "scratch" operand dup HEX: 8000 XORIS
+ "scratch" operand 1 cell param@ STW
+ "f1" operand 1 0 param@ LFD
+ 4503601774854144.0 "scratch" operand load-indirect
+ "f2" operand "scratch" operand float-offset LFD
+ "f1" operand "f1" operand "f2" operand FSUB
+] H{
+ { +input+ { { f "in" } } }
+ { +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } }
+ { +output+ { "f1" } }
+} define-intrinsic
+
+
\ tag [
"out" operand "in" operand tag-mask get ANDI
"out" operand dup %tag-fixnum
From 304aa98fe714d4bbacc9f990e57a26f5ff6aafbf Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 20:07:49 -1000
Subject: [PATCH 39/45] start cleanup of miller-rabin
---
extra/math/miller-rabin/miller-rabin.factor | 44 +++++++++------------
1 file changed, 19 insertions(+), 25 deletions(-)
diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor
index cd20216ff9..661d0fb29a 100644
--- a/extra/math/miller-rabin/miller-rabin.factor
+++ b/extra/math/miller-rabin/miller-rabin.factor
@@ -18,9 +18,7 @@ SYMBOL: trials
: next-odd ( m -- n )
dup even? [ 1+ ] [ 2 + ] if ;
-: random-bits ( m -- n )
- #! Top bit is always set
- 2^ [ random ] keep -1 shift bitor ; foldable
+: random-bits ( m -- n ) 2^ random ; foldable
: (factor-2s) ( s n -- s n )
dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
@@ -32,29 +30,24 @@ SYMBOL: trials
] unless 0 swap (factor-2s) ;
:: (miller-rabin) | n prime?! |
- n dup 1 = over even? or [
- drop f
- ] [
- 1- factor-2s s set r set
- trials get [
- n 1- [1,b] random a set
- a get s get n ^mod 1 = [
- 0 count set
- r get [
- 2^ s get * a get swap n ^mod n - -1 = [
- count [ 1+ ] change
- r get +
- ] when
- ] each
- count get zero? [
- f prime?!
- trials get +
+ n 1- factor-2s s set r set
+ trials get [
+ n 1- [1,b] random a set
+ a get s get n ^mod 1 = [
+ 0 count set
+ r get [
+ 2^ s get * a get swap n ^mod n - -1 = [
+ count [ 1+ ] change
+ r get +
] when
- ] unless
- drop
- ] each
- prime?
- ] if ;
+ ] each
+ count get zero? [
+ f prime?!
+ trials get +
+ ] when
+ ] unless
+ drop
+ ] each prime? ;
TUPLE: miller-rabin-bounds ;
@@ -62,6 +55,7 @@ TUPLE: miller-rabin-bounds ;
over {
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
+ { [ dup even? ] [ 3drop f ] }
{ [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] }
} cond ;
From 11dcb41546c6aaba1d04c03d9e97e6fce23b48bb Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 20:30:43 -1000
Subject: [PATCH 40/45] refactor lint, add lint-vocab/lint-word
---
extra/lint/lint.factor | 27 +++++++++++++++++++--------
1 file changed, 19 insertions(+), 8 deletions(-)
diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor
index 37209182a0..44b234b254 100644
--- a/extra/lint/lint.factor
+++ b/extra/lint/lint.factor
@@ -121,7 +121,7 @@ M: word lint ( word -- seq )
: word-path. ( word -- )
[ word-vocabulary ":" ] keep unparse 3append write nl ;
-: lint. ( array -- )
+: (lint.) ( pair -- )
first2 >r word-path. r> [
bl bl bl bl
dup .
@@ -129,6 +129,9 @@ M: word lint ( word -- seq )
def-hash get at [ bl bl bl bl word-path. ] each
nl
] each nl nl ;
+
+: lint. ( alist -- )
+ [ (lint.) ] each ;
GENERIC: run-lint ( obj -- obj )
@@ -143,21 +146,29 @@ GENERIC: run-lint ( obj -- obj )
: trim-self ( seq -- newseq )
[ [ (trim-self) ] subset ] assoc-map ;
+: filter-symbols ( alist -- alist )
+ [
+ nip first dup def-hash get at
+ [ first ] 2apply literalize = not
+ ] assoc-subset ;
+
M: sequence run-lint ( seq -- seq )
[
global [ dup . flush ] bind
dup lint
] { } map>assoc
trim-self
- [ second empty? not ] subset ;
+ [ second empty? not ] subset
+ filter-symbols ;
M: word run-lint ( word -- seq )
1array run-lint ;
: lint-all ( -- seq )
- all-words run-lint
- [
- nip first dup def-hash get at
- [ first ] 2apply literalize = not
- ] assoc-subset
- dup [ lint. ] each ;
+ all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq )
+ words run-lint dup lint. ;
+
+: lint-word ( word -- seq )
+ 1array run-lint dup lint. ;
From 37544fe24e1397a0adbbecea127723e14924ebc9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 20:43:58 -1000
Subject: [PATCH 41/45] remove blank line
---
extra/math/miller-rabin/miller-rabin.factor | 1 -
1 file changed, 1 deletion(-)
diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor
index 661d0fb29a..824bb88cb9 100644
--- a/extra/math/miller-rabin/miller-rabin.factor
+++ b/extra/math/miller-rabin/miller-rabin.factor
@@ -81,4 +81,3 @@ TUPLE: miller-rabin-bounds ;
#! generate two primes
over 5 < [ "not enough primes below 5 bits" throw ] when
[ [ drop random-prime ] with map ] [ all-unique? ] generate ;
-
From f8a0d7403d5e0657b4c384b3fd688a45413ec15c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 21:46:53 -1000
Subject: [PATCH 42/45] small cleanup in miller-rabin
---
extra/math/miller-rabin/miller-rabin.factor | 9 ++-------
1 file changed, 2 insertions(+), 7 deletions(-)
diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor
index 824bb88cb9..da8da8b7c3 100644
--- a/extra/math/miller-rabin/miller-rabin.factor
+++ b/extra/math/miller-rabin/miller-rabin.factor
@@ -20,17 +20,12 @@ SYMBOL: trials
: random-bits ( m -- n ) 2^ random ; foldable
-: (factor-2s) ( s n -- s n )
- dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
-
: factor-2s ( n -- r s )
#! factor an even number into 2 ^ s * m
- dup even? over 0 > and [
- "input must be positive and even" throw
- ] unless 0 swap (factor-2s) ;
+ dup even? [ -1 shift >r 1+ r> factor-2s ] when ;
:: (miller-rabin) | n prime?! |
- n 1- factor-2s s set r set
+ 0 n 1- factor-2s s set r set
trials get [
n 1- [1,b] random a set
a get s get n ^mod 1 = [
From b14a0e54e4b41aab34af91021fddeb8f58b38c22 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sat, 12 Jan 2008 21:49:47 -1000
Subject: [PATCH 43/45] fix typo
---
extra/math/miller-rabin/miller-rabin.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor
index da8da8b7c3..66d5793f93 100644
--- a/extra/math/miller-rabin/miller-rabin.factor
+++ b/extra/math/miller-rabin/miller-rabin.factor
@@ -20,7 +20,7 @@ SYMBOL: trials
: random-bits ( m -- n ) 2^ random ; foldable
-: factor-2s ( n -- r s )
+: factor-2s ( zero n -- r s )
#! factor an even number into 2 ^ s * m
dup even? [ -1 shift >r 1+ r> factor-2s ] when ;
From ba0ecf3ce1a894941ba570d5b4127f45364dca1a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 13 Jan 2008 04:07:04 -0500
Subject: [PATCH 44/45] Remove extra/visitor now that we have
extra/multi-methods
---
extra/visitor/authors.txt | 1 -
extra/visitor/summary.txt | 1 -
extra/visitor/tags.txt | 1 -
extra/visitor/visitor-tests.factor | 18 ---------
extra/visitor/visitor.factor | 63 ------------------------------
5 files changed, 84 deletions(-)
delete mode 100644 extra/visitor/authors.txt
delete mode 100644 extra/visitor/summary.txt
delete mode 100644 extra/visitor/tags.txt
delete mode 100644 extra/visitor/visitor-tests.factor
delete mode 100644 extra/visitor/visitor.factor
diff --git a/extra/visitor/authors.txt b/extra/visitor/authors.txt
deleted file mode 100644
index f990dd0ed2..0000000000
--- a/extra/visitor/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Daniel Ehrenberg
diff --git a/extra/visitor/summary.txt b/extra/visitor/summary.txt
deleted file mode 100644
index 3093ae9a9c..0000000000
--- a/extra/visitor/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Double-dispatch generic words
diff --git a/extra/visitor/tags.txt b/extra/visitor/tags.txt
deleted file mode 100644
index f4274299b1..0000000000
--- a/extra/visitor/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-extensions
diff --git a/extra/visitor/visitor-tests.factor b/extra/visitor/visitor-tests.factor
deleted file mode 100644
index 8248affaf7..0000000000
--- a/extra/visitor/visitor-tests.factor
+++ /dev/null
@@ -1,18 +0,0 @@
-USING: visitor math sequences math.parser strings tools.test kernel ;
-
-VISITOR: ++ ( object object -- object )
-! acts like +, coercing string arguments to a number, unless both arguments are strings, in which case it appends them
-
-V: number string ++
- string>number + ;
-V: string number ++
- >r string>number r> + ;
-V: number number ++
- + ;
-V: string string ++
- append ;
-
-[ 3 ] [ 1 2 ++ ] unit-test
-[ 3 ] [ "1" 2 ++ ] unit-test
-[ 3 ] [ 1 "2" ++ ] unit-test
-[ "12" ] [ "1" "2" ++ ] unit-test
diff --git a/extra/visitor/visitor.factor b/extra/visitor/visitor.factor
deleted file mode 100644
index 10c9fb8717..0000000000
--- a/extra/visitor/visitor.factor
+++ /dev/null
@@ -1,63 +0,0 @@
-USING: kernel generic.standard syntax words parser assocs
-generic quotations sequences effects arrays classes definitions
-prettyprint sorting prettyprint.backend shuffle ;
-IN: visitor
-
-: define-visitor ( word -- )
- dup dup reset-word define-simple-generic
- dup H{ } clone "visitor-methods" set-word-prop
- H{ } clone "visitors" set-word-prop ;
-
-: VISITOR:
- CREATE define-visitor ; parsing
-
-: record-visitor ( top-class generic method-word -- )
- swap "visitors" word-prop swapd set-at ;
-
-: define-1generic ( word -- )
- 1 <standard-combination> define-generic ;
-
-: copy-effect ( from to -- )
- swap stack-effect "declared-effect" set-word-prop ;
-
-: new-vmethod ( method bottom-class top-class generic -- )
- gensym dup define-1generic
- 2dup copy-effect
- 3dup 1quotation -rot define-method
- [ record-visitor ] keep
- define-method ;
-
-: define-visitor-method ( method bottom-class top-class generic -- )
- 4dup >r 2array r> "visitor-methods" word-prop set-at
- 2dup "visitors" word-prop at
- [ nip define-method ] [ new-vmethod ] ?if ;
-
-: V:
- ! syntax: V: bottom-class top-class generic body... ;
- f set-word scan-word scan-word scan-word
- parse-definition -roll define-visitor-method ; parsing
-
-! see instance:
-! see must be redone because "methods" doesn't show methods
-
-PREDICATE: standard-generic visitor "visitors" word-prop ;
-PREDICATE: array triple length 3 = ;
-PREDICATE: triple visitor-spec
- first3 visitor? >r [ class? ] both? r> and ;
-
-M: visitor-spec definer drop \ V: \ ; ;
-M: visitor definer drop \ VISITOR: f ;
-
-M: visitor-spec synopsis*
- ! same as method-spec#synopsis*
- dup definer drop pprint-word
- [ pprint-word ] each ;
-
-M: visitor-spec definition
- first3 >r 2array r> "visitor-methods" word-prop at ;
-
-M: visitor see
- dup (see)
- dup see-class
- dup "visitor-methods" word-prop keys natural-sort swap
- [ >r first2 r> 3array ] curry map see-all ;
From 240217f39e127977f6acc33e8a24100705bd47a2 Mon Sep 17 00:00:00 2001
From: Chris Double <Chris@Bethia.(none)>
Date: Sun, 13 Jan 2008 22:31:31 +1300
Subject: [PATCH 45/45] Fix peg issues with recent factor changes
---
extra/peg/ebnf/ebnf.factor | 366 ++++++++++++++++++-------------------
extra/peg/peg-docs.factor | 283 ++++++++++++++--------------
2 files changed, 325 insertions(+), 324 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index e55ee9d852..5343bb513b 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -1,184 +1,184 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel parser words arrays strings math.parser sequences
- quotations vectors namespaces math assocs continuations peg ;
-IN: peg.ebnf
-
-TUPLE: ebnf-non-terminal symbol ;
-TUPLE: ebnf-terminal symbol ;
-TUPLE: ebnf-choice options ;
-TUPLE: ebnf-sequence elements ;
-TUPLE: ebnf-repeat0 group ;
-TUPLE: ebnf-optional elements ;
-TUPLE: ebnf-rule symbol elements ;
-TUPLE: ebnf-action word ;
-TUPLE: ebnf rules ;
-
-C: <ebnf-non-terminal> ebnf-non-terminal
-C: <ebnf-terminal> ebnf-terminal
-C: <ebnf-choice> ebnf-choice
-C: <ebnf-sequence> ebnf-sequence
-C: <ebnf-repeat0> ebnf-repeat0
-C: <ebnf-optional> ebnf-optional
-C: <ebnf-rule> ebnf-rule
-C: <ebnf-action> ebnf-action
-C: <ebnf> ebnf
-
-SYMBOL: parsers
-SYMBOL: non-terminals
-SYMBOL: last-parser
-
-: reset-parser-generation ( -- )
- V{ } clone parsers set
- H{ } clone non-terminals set
- f last-parser set ;
-
-: store-parser ( parser -- number )
- parsers get [ push ] keep length 1- ;
-
-: get-parser ( index -- parser )
- parsers get nth ;
-
-: non-terminal-index ( name -- number )
- dup non-terminals get at [
- nip
- ] [
- f store-parser [ swap non-terminals get set-at ] keep
- ] if* ;
-
-GENERIC: (generate-parser) ( ast -- id )
-
-: generate-parser ( ast -- id )
- (generate-parser) dup last-parser set ;
-
-M: ebnf-terminal (generate-parser) ( ast -- id )
- ebnf-terminal-symbol token sp store-parser ;
-
-M: ebnf-non-terminal (generate-parser) ( ast -- id )
- [
- ebnf-non-terminal-symbol dup non-terminal-index ,
- parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
- ] [ ] make delay sp store-parser ;
-
-M: ebnf-choice (generate-parser) ( ast -- id )
- ebnf-choice-options [
- generate-parser get-parser
- ] map choice store-parser ;
-
-M: ebnf-sequence (generate-parser) ( ast -- id )
- ebnf-sequence-elements [
- generate-parser get-parser
- ] map seq store-parser ;
-
-M: ebnf-repeat0 (generate-parser) ( ast -- id )
- ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
-
-M: ebnf-optional (generate-parser) ( ast -- id )
- ebnf-optional-elements generate-parser get-parser optional store-parser ;
-
-M: ebnf-rule (generate-parser) ( ast -- id )
- dup ebnf-rule-symbol non-terminal-index swap
- ebnf-rule-elements generate-parser get-parser ! nt-id body
- swap [ parsers get set-nth ] keep ;
-
-M: ebnf-action (generate-parser) ( ast -- id )
- ebnf-action-word search 1quotation
- last-parser get get-parser swap action store-parser ;
-
-M: vector (generate-parser) ( ast -- id )
- [ generate-parser ] map peek ;
-
-M: f (generate-parser) ( ast -- id )
- drop last-parser get ;
-
-M: ebnf (generate-parser) ( ast -- id )
- ebnf-rules [
- generate-parser
- ] map peek ;
-
-DEFER: 'rhs'
-
-: 'non-terminal' ( -- parser )
- CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
-
-: 'terminal' ( -- parser )
- "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
-
-: 'element' ( -- parser )
- 'non-terminal' 'terminal' 2array choice ;
-
-DEFER: 'choice'
-
-: 'group' ( -- parser )
- "(" token sp hide
- [ 'choice' sp ] delay
- ")" token sp hide
- 3array seq [ first ] action ;
-
-: 'repeat0' ( -- parser )
- "{" token sp hide
- [ 'choice' sp ] delay
- "}" token sp hide
- 3array seq [ first <ebnf-repeat0> ] action ;
-
-: 'optional' ( -- parser )
- "[" token sp hide
- [ 'choice' sp ] delay
- "]" token sp hide
- 3array seq [ first <ebnf-optional> ] action ;
-
-: 'sequence' ( -- parser )
- [
- 'element' sp ,
- 'group' sp ,
- 'repeat0' sp ,
- 'optional' sp ,
- ] { } make choice
- repeat1 [
- dup length 1 = [ first ] [ <ebnf-sequence> ] if
- ] action ;
-
-: 'choice' ( -- parser )
- 'sequence' sp "|" token sp list-of [
- dup length 1 = [ first ] [ <ebnf-choice> ] if
- ] action ;
-
-: 'action' ( -- parser )
- "=>" token hide
- [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
- 2array seq [ first <ebnf-action> ] action ;
-
-: 'rhs' ( -- parser )
- 'choice' 'action' sp optional 2array seq ;
-
-: 'rule' ( -- parser )
- 'non-terminal' [ ebnf-non-terminal-symbol ] action
- "=" token sp hide
- 'rhs'
- 3array seq [ first2 <ebnf-rule> ] action ;
-
-: 'ebnf' ( -- parser )
- 'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
-
-: ebnf>quot ( string -- quot )
- 'ebnf' parse [
- parse-result-ast [
- reset-parser-generation
- generate-parser drop
- [
- non-terminals get
- [
- get-parser [
- swap , \ in , \ get , \ create ,
- 1quotation , \ define-compound ,
- ] [
- drop
- ] if*
- ] assoc-each
- ] [ ] make
- ] with-scope
- ] [
- f
- ] if* ;
-
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel parser words arrays strings math.parser sequences
+ quotations vectors namespaces math assocs continuations peg ;
+IN: peg.ebnf
+
+TUPLE: ebnf-non-terminal symbol ;
+TUPLE: ebnf-terminal symbol ;
+TUPLE: ebnf-choice options ;
+TUPLE: ebnf-sequence elements ;
+TUPLE: ebnf-repeat0 group ;
+TUPLE: ebnf-optional elements ;
+TUPLE: ebnf-rule symbol elements ;
+TUPLE: ebnf-action word ;
+TUPLE: ebnf rules ;
+
+C: <ebnf-non-terminal> ebnf-non-terminal
+C: <ebnf-terminal> ebnf-terminal
+C: <ebnf-choice> ebnf-choice
+C: <ebnf-sequence> ebnf-sequence
+C: <ebnf-repeat0> ebnf-repeat0
+C: <ebnf-optional> ebnf-optional
+C: <ebnf-rule> ebnf-rule
+C: <ebnf-action> ebnf-action
+C: <ebnf> ebnf
+
+SYMBOL: parsers
+SYMBOL: non-terminals
+SYMBOL: last-parser
+
+: reset-parser-generation ( -- )
+ V{ } clone parsers set
+ H{ } clone non-terminals set
+ f last-parser set ;
+
+: store-parser ( parser -- number )
+ parsers get [ push ] keep length 1- ;
+
+: get-parser ( index -- parser )
+ parsers get nth ;
+
+: non-terminal-index ( name -- number )
+ dup non-terminals get at [
+ nip
+ ] [
+ f store-parser [ swap non-terminals get set-at ] keep
+ ] if* ;
+
+GENERIC: (generate-parser) ( ast -- id )
+
+: generate-parser ( ast -- id )
+ (generate-parser) dup last-parser set ;
+
+M: ebnf-terminal (generate-parser) ( ast -- id )
+ ebnf-terminal-symbol token sp store-parser ;
+
+M: ebnf-non-terminal (generate-parser) ( ast -- id )
+ [
+ ebnf-non-terminal-symbol dup non-terminal-index ,
+ parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
+ ] [ ] make delay sp store-parser ;
+
+M: ebnf-choice (generate-parser) ( ast -- id )
+ ebnf-choice-options [
+ generate-parser get-parser
+ ] map choice store-parser ;
+
+M: ebnf-sequence (generate-parser) ( ast -- id )
+ ebnf-sequence-elements [
+ generate-parser get-parser
+ ] map seq store-parser ;
+
+M: ebnf-repeat0 (generate-parser) ( ast -- id )
+ ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
+
+M: ebnf-optional (generate-parser) ( ast -- id )
+ ebnf-optional-elements generate-parser get-parser optional store-parser ;
+
+M: ebnf-rule (generate-parser) ( ast -- id )
+ dup ebnf-rule-symbol non-terminal-index swap
+ ebnf-rule-elements generate-parser get-parser ! nt-id body
+ swap [ parsers get set-nth ] keep ;
+
+M: ebnf-action (generate-parser) ( ast -- id )
+ ebnf-action-word search 1quotation
+ last-parser get get-parser swap action store-parser ;
+
+M: vector (generate-parser) ( ast -- id )
+ [ generate-parser ] map peek ;
+
+M: f (generate-parser) ( ast -- id )
+ drop last-parser get ;
+
+M: ebnf (generate-parser) ( ast -- id )
+ ebnf-rules [
+ generate-parser
+ ] map peek ;
+
+DEFER: 'rhs'
+
+: 'non-terminal' ( -- parser )
+ CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
+
+: 'terminal' ( -- parser )
+ "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
+
+: 'element' ( -- parser )
+ 'non-terminal' 'terminal' 2array choice ;
+
+DEFER: 'choice'
+
+: 'group' ( -- parser )
+ "(" token sp hide
+ [ 'choice' sp ] delay
+ ")" token sp hide
+ 3array seq [ first ] action ;
+
+: 'repeat0' ( -- parser )
+ "{" token sp hide
+ [ 'choice' sp ] delay
+ "}" token sp hide
+ 3array seq [ first <ebnf-repeat0> ] action ;
+
+: 'optional' ( -- parser )
+ "[" token sp hide
+ [ 'choice' sp ] delay
+ "]" token sp hide
+ 3array seq [ first <ebnf-optional> ] action ;
+
+: 'sequence' ( -- parser )
+ [
+ 'element' sp ,
+ 'group' sp ,
+ 'repeat0' sp ,
+ 'optional' sp ,
+ ] { } make choice
+ repeat1 [
+ dup length 1 = [ first ] [ <ebnf-sequence> ] if
+ ] action ;
+
+: 'choice' ( -- parser )
+ 'sequence' sp "|" token sp list-of [
+ dup length 1 = [ first ] [ <ebnf-choice> ] if
+ ] action ;
+
+: 'action' ( -- parser )
+ "=>" token hide
+ [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
+ 2array seq [ first <ebnf-action> ] action ;
+
+: 'rhs' ( -- parser )
+ 'choice' 'action' sp optional 2array seq ;
+
+: 'rule' ( -- parser )
+ 'non-terminal' [ ebnf-non-terminal-symbol ] action
+ "=" token sp hide
+ 'rhs'
+ 3array seq [ first2 <ebnf-rule> ] action ;
+
+: 'ebnf' ( -- parser )
+ 'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
+
+: ebnf>quot ( string -- quot )
+ 'ebnf' parse [
+ parse-result-ast [
+ reset-parser-generation
+ generate-parser drop
+ [
+ non-terminals get
+ [
+ get-parser [
+ swap , \ in , \ get , \ create ,
+ 1quotation , \ define ,
+ ] [
+ drop
+ ] if*
+ ] assoc-each
+ ] [ ] make
+ ] with-scope
+ ] [
+ f
+ ] if* ;
+
: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing
\ No newline at end of file
diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor
index 41463d85a0..6dff95c829 100644
--- a/extra/peg/peg-docs.factor
+++ b/extra/peg/peg-docs.factor
@@ -1,142 +1,143 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax peg ;
-
-HELP: parse
-{ $values
- { "input" "a string" }
- { "parser" "a parser" }
- { "result" "a parse-result or f" }
-}
-{ $description
- "Given the input string, parse it using the given parser. The result is a <parse-result> object if "
- "the parse was successful, otherwise it is f." } ;
-
-HELP: token
-{ $values
- { "string" "a string" }
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that matches the given string." } ;
-
-HELP: satisfy
-{ $values
- { "quot" "a quotation" }
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that calls the quotation on the first character of the input string, "
- "succeeding if that quotation returns true. The AST is the character from the string." } ;
-
-HELP: range
-{ $values
- { "min" "a character" }
- { "max" "a character" }
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that matches a single character that lies within the range of characters given, inclusive." }
-{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ;
-
-HELP: seq
-{ $values
- { "seq" "a sequence of parsers" }
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if "
- "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
- "the individual parsers." } ;
-
-HELP: choice
-{ $values
- { "seq" "a sequence of parsers" }
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. "
- "The resulting AST is that produced by the successful parser." } ;
-
-HELP: repeat0
-{ $values
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
- "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
- "parsed." } ;
-
-HELP: repeat1
-{ $values
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is "
- "an array of the AST produced by the 'p1' parser." } ;
-
-HELP: optional
-{ $values
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
- "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
-
-HELP: ensure
-{ $values
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
- "AST and does not move the location in the input string. This can be used for lookahead and "
- "disambiguation, along with the " { $link ensure-not } " word." }
-{ $examples { $code "\"0\" token ensure octal-parser" } } ;
-
-HELP: ensure-not
-{ $values
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
- "AST and does not move the location in the input string. This can be used for lookahead and "
- "disambiguation, along with the " { $link ensure } " word." }
-{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
-
-HELP: action
-{ $values
- { "parser" "a parser" }
- { "quot" "a quotation with stack effect ( ast -- ast )" }
-}
-{ $description
- "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
- "from that parse. The result of the quotation is then used as the final AST. This can be used "
- "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
- "the default AST." }
-{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
-
-HELP: sp
-{ $values
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that calls the original parser 'p1' after stripping any whitespace "
- " from the left of the input string." } ;
-
-HELP: hide
-{ $values
- { "parser" "a parser" }
-}
-{ $description
- "Returns a parser that succeeds if the original parser succeeds, but does not "
- "put any result in the AST. Useful for ignoring 'syntax' in the AST." }
-{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;
-
-HELP: delay
-{ $values
- { "parser" "a parser" }
-}
-{ $description
- "Delays the construction of a parser until it is actually required to parse. This "
- "allows for calling a parser that results in a recursive call to itself. The quotation "
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: peg
+
+HELP: parse
+{ $values
+ { "input" "a string" }
+ { "parser" "a parser" }
+ { "result" "a parse-result or f" }
+}
+{ $description
+ "Given the input string, parse it using the given parser. The result is a <parse-result> object if "
+ "the parse was successful, otherwise it is f." } ;
+
+HELP: token
+{ $values
+ { "string" "a string" }
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that matches the given string." } ;
+
+HELP: satisfy
+{ $values
+ { "quot" "a quotation" }
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that calls the quotation on the first character of the input string, "
+ "succeeding if that quotation returns true. The AST is the character from the string." } ;
+
+HELP: range
+{ $values
+ { "min" "a character" }
+ { "max" "a character" }
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that matches a single character that lies within the range of characters given, inclusive." }
+{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ;
+
+HELP: seq
+{ $values
+ { "seq" "a sequence of parsers" }
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if "
+ "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
+ "the individual parsers." } ;
+
+HELP: choice
+{ $values
+ { "seq" "a sequence of parsers" }
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. "
+ "The resulting AST is that produced by the successful parser." } ;
+
+HELP: repeat0
+{ $values
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
+ "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
+ "parsed." } ;
+
+HELP: repeat1
+{ $values
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is "
+ "an array of the AST produced by the 'p1' parser." } ;
+
+HELP: optional
+{ $values
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
+ "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
+
+HELP: ensure
+{ $values
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
+ "AST and does not move the location in the input string. This can be used for lookahead and "
+ "disambiguation, along with the " { $link ensure-not } " word." }
+{ $examples { $code "\"0\" token ensure octal-parser" } } ;
+
+HELP: ensure-not
+{ $values
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
+ "AST and does not move the location in the input string. This can be used for lookahead and "
+ "disambiguation, along with the " { $link ensure } " word." }
+{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
+
+HELP: action
+{ $values
+ { "parser" "a parser" }
+ { "quot" "a quotation with stack effect ( ast -- ast )" }
+}
+{ $description
+ "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
+ "from that parse. The result of the quotation is then used as the final AST. This can be used "
+ "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
+ "the default AST." }
+{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
+
+HELP: sp
+{ $values
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that calls the original parser 'p1' after stripping any whitespace "
+ " from the left of the input string." } ;
+
+HELP: hide
+{ $values
+ { "parser" "a parser" }
+}
+{ $description
+ "Returns a parser that succeeds if the original parser succeeds, but does not "
+ "put any result in the AST. Useful for ignoring 'syntax' in the AST." }
+{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;
+
+HELP: delay
+{ $values
+ { "parser" "a parser" }
+}
+{ $description
+ "Delays the construction of a parser until it is actually required to parse. This "
+ "allows for calling a parser that results in a recursive call to itself. The quotation "
"should return the constructed parser." } ;
\ No newline at end of file