From 853f1ef5a62e7ddb60687fc279244b315f76cbb6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 28 Sep 2008 00:40:41 -0500
Subject: [PATCH] Fix bug with values and deployment, add new to: sugar
---
basis/io/encodings/iana/iana.factor | 2 +-
basis/tools/deploy/deploy-tests.factor | 18 ++++++++----
basis/tools/deploy/test/6/6.factor | 13 +++++++++
basis/tools/deploy/test/6/deploy.factor | 15 ++++++++++
basis/unicode/breaks/breaks.factor | 3 +-
basis/unicode/collation/collation.factor | 2 +-
basis/unicode/data/data.factor | 22 +++++++-------
basis/unicode/script/script.factor | 2 +-
basis/values/values-docs.factor | 16 ++++++++--
basis/values/values-tests.factor | 2 +-
basis/values/values.factor | 37 ++++++++++++++++++++----
11 files changed, 101 insertions(+), 31 deletions(-)
create mode 100644 basis/tools/deploy/test/6/6.factor
create mode 100644 basis/tools/deploy/test/6/deploy.factor
diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor
index dcd806d9a0..19b887cd75 100755
--- a/basis/io/encodings/iana/iana.factor
+++ b/basis/io/encodings/iana/iana.factor
@@ -59,4 +59,4 @@ PRIVATE>
PRIVATE>
"resource:basis/io/encodings/iana/character-sets"
-ascii <file-reader> make-n>e \ n>e-table set-value
+ascii <file-reader> make-n>e to: n>e-table
diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor
index acee098b8f..1d5b59bf0c 100755
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/basis/tools/deploy/deploy-tests.factor
@@ -43,6 +43,11 @@ namespaces continuations layouts accessors ;
[ t ] [ 2500000 small-enough? ] unit-test
+: run-temp-image ( -- )
+ vm
+ "-i=" "test.image" temp-file append
+ 2array try-process ;
+
{
"tools.deploy.test.1"
"tools.deploy.test.2"
@@ -51,9 +56,7 @@ namespaces continuations layouts accessors ;
} [
[ ] swap [
shake-and-bake
- vm
- "-i=" "test.image" temp-file append
- 2array try-process
+ run-temp-image
] curry unit-test
] each
@@ -88,9 +91,12 @@ M: quit-responder call-responder*
[ ] [
"tools.deploy.test.5" shake-and-bake
- vm
- "-i=" "test.image" temp-file append
- 2array try-process
+ run-temp-image
] unit-test
[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test
+
+[ ] [
+ "tools.deploy.test.6" shake-and-bake
+ run-temp-image
+] unit-test
diff --git a/basis/tools/deploy/test/6/6.factor b/basis/tools/deploy/test/6/6.factor
new file mode 100644
index 0000000000..da64bb646c
--- /dev/null
+++ b/basis/tools/deploy/test/6/6.factor
@@ -0,0 +1,13 @@
+IN: tools.deploy.test.6
+USING: values math kernel ;
+
+VALUE: x
+
+VALUE: y
+
+: deploy-test-6 ( -- )
+ 1 to: x
+ 2 to: y
+ x y + 3 assert= ;
+
+MAIN: deploy-test-6
diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor
new file mode 100644
index 0000000000..410bb770be
--- /dev/null
+++ b/basis/tools/deploy/test/6/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+ { deploy-threads? f }
+ { deploy-ui? f }
+ { deploy-io 1 }
+ { deploy-c-types? f }
+ { deploy-name "tools.deploy.test.6" }
+ { deploy-compiler? t }
+ { deploy-reflection 1 }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-random? f }
+ { deploy-math? f }
+}
diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor
index 88381ca7d7..6aa3e60647 100755
--- a/basis/unicode/breaks/breaks.factor
+++ b/basis/unicode/breaks/breaks.factor
@@ -98,5 +98,4 @@ VALUE: grapheme-table
init-grapheme-table table
[ make-grapheme-table finish-table ] with-variable
-\ grapheme-table set-value
-
+to: grapheme-table
diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor
index 3ebb474a81..8e9e2963a8 100755
--- a/basis/unicode/collation/collation.factor
+++ b/basis/unicode/collation/collation.factor
@@ -27,7 +27,7 @@ TUPLE: weight primary secondary tertiary ignorable? ;
[ parse-line ] H{ } map>assoc ;
"resource:basis/unicode/collation/allkeys.txt"
-ascii <file-reader> parse-ducet \ ducet set-value
+ascii <file-reader> parse-ducet to: ducet
! Fix up table for long contractions
: help-one ( assoc key -- )
diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor
index 6d6ed276a8..cd54b93f2a 100755
--- a/basis/unicode/data/data.factor
+++ b/basis/unicode/data/data.factor
@@ -164,18 +164,16 @@ C: <code-point> code-point
[ [ set-code-point ] each ] H{ } make-assoc ;
load-data {
- [ process-names \ name-map set-value ]
- [ 13 swap process-data \ simple-lower set-value ]
- [ 12 swap process-data \ simple-upper set-value ]
- [ 14 swap process-data
- simple-upper assoc-union \ simple-title set-value ]
- [ process-combining \ class-map set-value ]
- [ process-canonical \ canonical-map set-value
- \ combine-map set-value ]
- [ process-compatibility \ compatibility-map set-value ]
- [ process-category \ category-map set-value ]
+ [ process-names to: name-map ]
+ [ 13 swap process-data to: simple-lower ]
+ [ 12 swap process-data to: simple-upper ]
+ [ 14 swap process-data simple-upper assoc-union to: simple-title ]
+ [ process-combining to: class-map ]
+ [ process-canonical to: canonical-map to: combine-map ]
+ [ process-compatibility to: compatibility-map ]
+ [ process-category to: category-map ]
} cleave
-load-special-casing \ special-casing set-value
+load-special-casing to: special-casing
-load-properties \ properties set-value
+load-properties to: properties
diff --git a/basis/unicode/script/script.factor b/basis/unicode/script/script.factor
index aa9ca843bd..103beb4d2a 100755
--- a/basis/unicode/script/script.factor
+++ b/basis/unicode/script/script.factor
@@ -32,7 +32,7 @@ SYMBOL: interned
: process-script ( ranges -- )
dup values prune >symbols interned [
- expand-ranges \ script-table set-value
+ expand-ranges to: script-table
] with-variable ;
: load-script ( -- )
diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor
index 4984b03f03..c96ea0f8cf 100755
--- a/basis/values/values-docs.factor
+++ b/basis/values/values-docs.factor
@@ -7,6 +7,7 @@ ARTICLE: "values" "Global values"
"To get the value, just call the word. The following words manipulate values:"
{ $subsection get-value }
{ $subsection set-value }
+{ $subsection POSTPONE: to: }
{ $subsection change-value } ;
HELP: VALUE:
@@ -20,8 +21,19 @@ HELP: get-value
HELP: set-value
{ $values { "value" "a new value" } { "word" "a value word" } }
-{ $description "Sets the value word." } ;
+{ $description "Sets a value word." } ;
+
+HELP: to:
+{ $syntax "... to: value" }
+{ $values { "word" "a value word" } }
+{ $description "Sets a value word." }
+{ $notes
+ "Note that"
+ { $code "foo to: value" }
+ "is just sugar for"
+ { $code "foo \\ value set-value" }
+} ;
HELP: change-value
-{ $values { "word" "a value word" } { "quot" "a quotation ( oldvalue -- newvalue )" } }
+{ $values { "word" "a value word" } { "quot" "a quotation with stack effect " { $snippet "( oldvalue -- newvalue )" } } }
{ $description "Changes the value using the given quotation." } ;
diff --git a/basis/values/values-tests.factor b/basis/values/values-tests.factor
index 31b44be99e..6ad5e7dee6 100755
--- a/basis/values/values-tests.factor
+++ b/basis/values/values-tests.factor
@@ -3,7 +3,7 @@ IN: values.tests
VALUE: foo
[ f ] [ foo ] unit-test
-[ ] [ 3 \ foo set-value ] unit-test
+[ ] [ 3 to: foo ] unit-test
[ 3 ] [ foo ] unit-test
[ ] [ \ foo [ 1+ ] change-value ] unit-test
[ 4 ] [ foo ] unit-test
diff --git a/basis/values/values.factor b/basis/values/values.factor
index 7f19898b18..0dd1058370 100755
--- a/basis/values/values.factor
+++ b/basis/values/values.factor
@@ -1,15 +1,42 @@
-USING: accessors kernel parser sequences words effects ;
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel parser words sequences quotations ;
IN: values
+! Mutating literals in word definitions is not really allowed,
+! and the deploy tool takes advantage of this fact to perform
+! some aggressive stripping and compression. However, this
+! breaks a naive implementation of values. We need to do two
+! things:
+! 1) Store the value in a subclass of identity-tuple, so that
+! two quotations from different value words are never equal.
+! This avoids bogus merging of values.
+! 2) Set the "no-def-strip" word-prop, so that the shaker leaves
+! the def>> slot alone, allowing us to introspect it. Otherwise,
+! it will get set to [ ] and we would lose access to the
+! value-holder.
+
+<PRIVATE
+
+TUPLE: value-holder < identity-tuple obj ;
+
+PRIVATE>
+
: VALUE:
- CREATE-WORD { f } clone [ first ] curry
+ CREATE-WORD
+ dup t "no-def-strip" set-word-prop
+ T{ value-holder } clone [ obj>> ] curry
(( -- value )) define-declared ; parsing
: set-value ( value word -- )
- def>> first set-first ;
+ def>> first (>>obj) ;
+
+: to:
+ scan-word literalize parsed
+ \ set-value parsed ; parsing
: get-value ( word -- value )
- def>> first first ;
+ def>> first obj>> ;
: change-value ( word quot -- )
- over >r >r get-value r> call r> set-value ; inline
+ [ [ get-value ] dip call ] [ drop ] 2bi set-value ; inline