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 make-n>e \ n>e-table set-value +ascii 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 parse-ducet \ ducet set-value +ascii 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 [ [ 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. + + + : 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