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
\r
[ t ] [ 2500000 small-enough? ] unit-test\r
\r
+: run-temp-image ( -- )\r
+ vm\r
+ "-i=" "test.image" temp-file append\r
+ 2array try-process ;\r
+\r
{\r
"tools.deploy.test.1"\r
"tools.deploy.test.2"\r
} [\r
[ ] swap [\r
shake-and-bake\r
- vm\r
- "-i=" "test.image" temp-file append\r
- 2array try-process\r
+ run-temp-image\r
] curry unit-test\r
] each\r
\r
\r
[ ] [\r
"tools.deploy.test.5" shake-and-bake\r
- vm\r
- "-i=" "test.image" temp-file append\r
- 2array try-process\r
+ run-temp-image\r
] unit-test\r
\r
[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test\r
+\r
+[ ] [\r
+ "tools.deploy.test.6" shake-and-bake\r
+ run-temp-image\r
+] unit-test\r
--- /dev/null
+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
--- /dev/null
+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 }
+}
init-grapheme-table table
[ make-grapheme-table finish-table ] with-variable
-\ grapheme-table set-value
-
+to: grapheme-table
[ parse-line ] H{ } map>assoc ;\r
\r
"resource:basis/unicode/collation/allkeys.txt"\r
-ascii <file-reader> parse-ducet \ ducet set-value\r
+ascii <file-reader> parse-ducet to: ducet\r
\r
! Fix up table for long contractions\r
: help-one ( assoc key -- )\r
[ [ 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
: process-script ( ranges -- )
dup values prune >symbols interned [
- expand-ranges \ script-table set-value
+ expand-ranges to: script-table
] with-variable ;
: load-script ( -- )
"To get the value, just call the word. The following words manipulate values:"\r
{ $subsection get-value }\r
{ $subsection set-value }\r
+{ $subsection POSTPONE: to: }\r
{ $subsection change-value } ;\r
\r
HELP: VALUE:\r
\r
HELP: set-value\r
{ $values { "value" "a new value" } { "word" "a value word" } }\r
-{ $description "Sets the value word." } ;\r
+{ $description "Sets a value word." } ;\r
+\r
+HELP: to:\r
+{ $syntax "... to: value" }\r
+{ $values { "word" "a value word" } }\r
+{ $description "Sets a value word." }\r
+{ $notes\r
+ "Note that"\r
+ { $code "foo to: value" }\r
+ "is just sugar for"\r
+ { $code "foo \\ value set-value" }\r
+} ;\r
\r
HELP: change-value\r
-{ $values { "word" "a value word" } { "quot" "a quotation ( oldvalue -- newvalue )" } }\r
+{ $values { "word" "a value word" } { "quot" "a quotation with stack effect " { $snippet "( oldvalue -- newvalue )" } } }\r
{ $description "Changes the value using the given quotation." } ;\r
\r
VALUE: foo\r
[ f ] [ foo ] unit-test\r
-[ ] [ 3 \ foo set-value ] unit-test\r
+[ ] [ 3 to: foo ] unit-test\r
[ 3 ] [ foo ] unit-test\r
[ ] [ \ foo [ 1+ ] change-value ] unit-test\r
[ 4 ] [ foo ] unit-test\r
-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
projects / factor.git / commitdiff