Fix bug with values and deployment, add new to: sugar

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

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
+        run-temp-image
-        "-i=" "test.image" temp-file append
-        2array try-process
     ] curry unit-test
 ] each
 
@@ -88,9 +91,12 @@ M: quit-responder call-responder*
 
 [ ] [
     "tools.deploy.test.5" shake-and-bake
-    vm
+    run-temp-image
-    "-i=" "test.image" temp-file append
-    2array try-process
 ] unit-test
 
 [ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test
+
+[ ] [
+    "tools.deploy.test.6" shake-and-bake
+    run-temp-image
+] unit-test

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

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 }
+}

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
-

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 -- )

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 ]
+    [ process-names to: name-map ]
-    [ 13 swap process-data \ simple-lower set-value ]
+    [ 13 swap process-data to: simple-lower ]
-    [ 12 swap process-data \ simple-upper set-value ]
+    [ 12 swap process-data to: simple-upper ]
-    [ 14 swap process-data
+    [ 14 swap process-data simple-upper assoc-union to: simple-title ]
-        simple-upper assoc-union \ simple-title set-value ]
+    [ process-combining to: class-map ]
-    [ process-combining \ class-map set-value ]
+    [ process-canonical to: canonical-map to: combine-map ]
-    [ process-canonical \ canonical-map set-value
+    [ process-compatibility to: compatibility-map ]
-        \ combine-map set-value ]
+    [ process-category to: category-map ]
-    [ process-compatibility \ compatibility-map set-value ]
-    [ process-category \ category-map set-value ]
 } cleave
 
-load-special-casing \ special-casing set-value
+load-special-casing to: special-casing
 
-load-properties \ properties set-value
+load-properties to: properties

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 ( -- )

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." } ;

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

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