steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-09-28 00:40:41 -05:00
parent b1d82c6c74
commit 853f1ef5a6
11 changed files with 101 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/io/encodings/iana/iana.factor
View File

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

18
basis/tools/deploy/deploy-tests.factor
View File

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

13
basis/tools/deploy/test/6/6.factor Normal file
View File

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

15
basis/tools/deploy/test/6/deploy.factor Normal file
View File

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

3
basis/unicode/breaks/breaks.factor
View File

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

2
basis/unicode/collation/collation.factor
View File

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

22
basis/unicode/data/data.factor
View File

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

2
basis/unicode/script/script.factor
View File

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

16
basis/values/values-docs.factor
View File

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

2
basis/values/values-tests.factor
View File

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

37
basis/values/values.factor
View File

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