Slava Pestov
+Alex Chapman
-! Copyright (C) 2007 Slava Pestov
+! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
+USING: boxes help.markup help.syntax kernel math namespaces ;
IN: refs
-ARTICLE: "refs" "References to assoc entries"
-"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary."
+ARTICLE: "refs" "References"
+"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "."
{ $subsection get-ref }
{ $subsection set-ref }
+{ $subsection set-ref* }
{ $subsection delete-ref }
-"References to keys:"
+"References to objects:"
+{ $subsection obj-ref }
+{ $subsection <obj-ref> }
+"References to assoc keys:"
{ $subsection key-ref }
{ $subsection <key-ref> }
-"References to values:"
+"References to assoc values:"
{ $subsection value-ref }
{ $subsection <value-ref> }
+"References to variables:"
+{ $subsection var-ref }
+{ $subsection <var-ref> }
+{ $subsection global-var-ref }
+{ $subsection <global-var-ref> }
+"References to tuple slots:"
+{ $subsection slot-ref }
+{ $subsection <slot-ref> }
+"Using boxes as references:"
+{ $subsection "box-refs" }
"References are used by the UI inspector." ;
ABOUT: "refs"
+ARTICLE: "refs-protocol" "Reference Protocol"
+"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
+{ $subsection get-ref }
+{ $subsection set-ref }
+"References may also implement:"
+{ $subsection delete-ref } ;
+
+ARTICLE: "box-refs" "Using Boxes as References"
+"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
+
HELP: ref
-{ $class-description "A class whose instances identify a key or value location in an associative structure. Instances of this clas are never used directly; only instances of " { $link key-ref } " and " { $link value-ref } " should be created." } ;
+{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
HELP: delete-ref
{ $values { "ref" ref } }
-{ $description "Deletes the association entry pointed at by this reference." } ;
+{ $description "Deletes the value pointed to by this reference. In most references this simply sets the value to f, but in some cases it is more destructive, such as in " { $link value-ref } " and " { $link key-ref } ", where it actually deletes the entry from the underlying assoc." } ;
HELP: get-ref
{ $values { "ref" ref } { "obj" object } }
-{ $description "Outputs the key or the value pointed at by this reference." } ;
+{ $description "Outputs the value pointed at by this reference." } ;
HELP: set-ref
{ $values { "obj" object } { "ref" ref } }
-{ $description "Stores a new key or value at by this reference." } ;
+{ $description "Stores a new value at this reference." } ;
+
+HELP: obj-ref
+{ $class-description "Instances of this class contain a value which can be changed using the " { $link "refs-protocol" } ". New object references are created by calling " { $link <obj-ref> } "." } ;
+
+HELP: <obj-ref>
+{ $values { "obj" object } { "obj-ref" obj-ref } }
+{ $description "Creates a reference which contains the value it references." } ;
+HELP: var-ref
+{ $class-description "Instances of this class reference a variable as defined by the " { $vocab-link "namespaces" } " vocabulary. New variable references are created by calling " { $link <var-ref> } "." } ;
+
+HELP: <var-ref>
+{ $values { "var" object } { "var-ref" var-ref } }
+{ $description "Creates a reference to the given variable. Note that this reference behaves just like any variable when it comes to dynamic scope. For example, if you use " { $link set-ref } " in an inner scope and then leave that scope, then calling " { $link get-ref } " may not return the expected value. If this is not what you want, try using an " { $link obj-ref } " instead." } ;
+
+HELP: global-var-ref
+{ $class-description "Instances of this class reference a global variable. New global references are created by calling " { $link <global-var-ref> } "." } ;
+
+HELP: <global-var-ref>
+{ $values { "var" object } { "global-var-ref" global-var-ref } }
+{ $description "Creates a reference to a global variable." } ;
+
+HELP: slot-ref
+{ $class-description "Instances of this class identify a particular slot of a particular instance of a tuple. New slot references are created by calling " { $link <slot-ref> } "." } ;
+
+HELP: <slot-ref>
+{ $values { "tuple" tuple } { "slot" integer } { "slot-ref" slot-ref } }
+{ $description "Creates a reference to the value in a particular slot of the given tuple. The slot must be given as an integer, where the first user-defined slot is number 2. This is mostly just a proof of concept until we have a way of generating this slot number from a slot name." } ;
+
HELP: key-ref
{ $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
{ $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
-{ get-ref set-ref delete-ref } related-words
+{ get-ref set-ref delete-ref set-ref* } related-words
+
+{ <obj-ref> <var-ref> <global-var-ref> <slot-ref> <key-ref> <value-ref> } related-words
-{ <key-ref> <value-ref> } related-words
+HELP: set-ref*
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ;
+
+HELP: ref-on
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to t." } ;
+
+HELP: ref-off
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to f." } ;
+
+HELP: ref-inc
+{ $values { "ref" ref } }
+{ $description "Increment the value of the ref by 1." } ;
+
+HELP: ref-dec
+{ $values { "ref" ref } }
+{ $description "Decrement the value of the ref by 1." } ;
+
+HELP: take
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Retrieve the value of the ref and then delete it, returning the value." } ;
+
+{ ref-on ref-off ref-inc ref-dec take } related-words
+{ take delete-ref } related-words
+{ on ref-on } related-words
+{ off ref-off } related-words
+{ inc ref-inc } related-words
+{ dec ref-dec } related-words
-USING: refs tools.test kernel ;
+USING: boxes kernel namespaces refs tools.test ;
+IN: refs.tests
+! assoc-refs
[ 3 ] [
H{ { "a" 3 } } "a" <value-ref> get-ref
] unit-test
set-ref
] keep
] unit-test
+
+SYMBOLS: lion giraffe elephant rabbit ;
+
+! obj-refs
+[ rabbit ] [ rabbit <obj-ref> get-ref ] unit-test
+[ rabbit ] [ f <obj-ref> rabbit set-ref* get-ref ] unit-test
+[ rabbit ] [ rabbit <obj-ref> take ] unit-test
+[ rabbit f ] [ rabbit <obj-ref> [ take ] keep get-ref ] unit-test
+[ lion ] [ rabbit <obj-ref> dup [ drop lion ] change-ref get-ref ] unit-test
+
+! var-refs
+[ giraffe ] [ [ giraffe rabbit set rabbit <var-ref> get-ref ] with-scope ] unit-test
+
+[ rabbit ]
+[
+ [
+ lion rabbit set [
+ rabbit rabbit set rabbit <var-ref> get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <var-ref>
+ [
+ lion rabbit set [
+ rabbit rabbit set get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <var-ref>
+ [
+ elephant rabbit set [
+ rabbit rabbit set
+ ] with-scope
+ get-ref
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <var-ref>
+ [
+ elephant set-ref* [
+ rabbit set-ref* get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <var-ref>
+ [
+ elephant set-ref* [
+ rabbit set-ref*
+ ] with-scope
+ get-ref
+ ] with-scope
+] unit-test
+
+! Top Hats
+[ lion ] [ lion rabbit set-global rabbit <global-var-ref> get-ref ] unit-test
+[ giraffe ] [ rabbit <global-var-ref> giraffe set-ref* get-ref ] unit-test
+
+! Tuple refs
+TUPLE: foo bar ;
+C: <foo> foo
+
+: test-tuple ( -- tuple )
+ rabbit <foo> ;
+
+: test-slot-ref ( -- slot-ref )
+ test-tuple 2 <slot-ref> ; ! hack!
+
+[ rabbit ] [ test-slot-ref get-ref ] unit-test
+[ lion ] [ test-slot-ref lion set-ref* get-ref ] unit-test
+
+! Boxes as refs
+[ rabbit ] [ <box> rabbit set-ref* get-ref ] unit-test
+[ <box> rabbit set-ref* lion set-ref* ] must-fail
+[ <box> get-ref ] must-fail
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2008 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.tuple kernel assocs accessors ;
+USING: kernel assocs accessors boxes math namespaces ;
IN: refs
-TUPLE: ref assoc key ;
+MIXIN: ref
-: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
-
-: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
GENERIC: set-ref ( obj ref -- )
+GENERIC: delete-ref ( ref -- )
+
+! works like >>slot words
+: set-ref* ( ref obj -- ref ) over set-ref ;
+
+! very similar to change, on, off, +@, inc, and dec from namespaces
+: change-ref ( ref quot -- )
+ [ [ get-ref ] keep ] dip dip set-ref ; inline
+: ref-on ( ref -- ) t swap set-ref ;
+: ref-off ( ref -- ) f swap set-ref ;
+: ref-+@ ( n ref -- ) [ 0 or + ] change-ref ;
+: ref-inc ( ref -- ) 1 swap ref-+@ ;
+: ref-dec ( ref -- ) -1 swap ref-+@ ;
+
+: take ( ref -- obj )
+ dup get-ref swap delete-ref ;
+
+! delete-ref defaults to setting ref to f
+M: ref delete-ref ref-off ;
+
+TUPLE: obj-ref obj ;
+C: <obj-ref> obj-ref
+M: obj-ref get-ref obj>> ;
+M: obj-ref set-ref (>>obj) ;
+INSTANCE: obj-ref ref
+
+TUPLE: var-ref var ;
+C: <var-ref> var-ref
+M: var-ref get-ref var>> get ;
+M: var-ref set-ref var>> set ;
+INSTANCE: var-ref ref
+
+TUPLE: global-var-ref var ;
+C: <global-var-ref> global-var-ref
+M: global-var-ref get-ref var>> get-global ;
+M: global-var-ref set-ref var>> set-global ;
+INSTANCE: global-var-ref ref
+
+USE: slots.private
+TUPLE: slot-ref tuple slot ;
+C: <slot-ref> slot-ref
+: >slot-ref< ( slot-ref -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
+M: slot-ref get-ref >slot-ref< slot ;
+M: slot-ref set-ref >slot-ref< set-slot ;
+INSTANCE: slot-ref ref
+
+M: box get-ref box> ;
+M: box set-ref >box ;
+M: box delete-ref box> drop ;
+INSTANCE: box ref
+
+TUPLE: assoc-ref assoc key ;
+
+: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
+
+M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ;
-TUPLE: key-ref < ref ;
+TUPLE: key-ref < assoc-ref ;
C: <key-ref> key-ref
M: key-ref get-ref key>> ;
-M: key-ref set-ref >ref< rename-at ;
+M: key-ref set-ref >assoc-ref< rename-at ;
+INSTANCE: key-ref ref
-TUPLE: value-ref < ref ;
+TUPLE: value-ref < assoc-ref ;
C: <value-ref> value-ref
-M: value-ref get-ref >ref< at ;
-M: value-ref set-ref >ref< set-at ;
+M: value-ref get-ref >assoc-ref< at ;
+M: value-ref set-ref >assoc-ref< set-at ;
+INSTANCE: value-ref ref
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: boxes hats kernel namespaces symbols tools.test ;
-IN: hats.tests
-
-SYMBOLS: lion giraffe elephant rabbit ;
-
-! caps
-[ rabbit ] [ rabbit <cap> out ] unit-test
-[ rabbit ] [ f <cap> rabbit in out ] unit-test
-[ rabbit ] [ rabbit <cap> take ] unit-test
-[ f ] [ rabbit <cap> empty-hat out ] unit-test
-[ rabbit f ] [ rabbit <cap> [ take ] keep out ] unit-test
-[ rabbit t ] [ rabbit <cap> [ take ] keep empty-hat? ] unit-test
-[ lion ] [ rabbit <cap> [ drop lion ] change-hat out ] unit-test
-
-! bowlers
-[ giraffe ] [ [ giraffe rabbit set rabbit <bowler> out ] with-scope ] unit-test
-
-[ rabbit ]
-[
- [
- lion rabbit set [
- rabbit rabbit set rabbit <bowler> out
- ] with-scope
- ] with-scope
-] unit-test
-
-[ rabbit ] [
- rabbit <bowler>
- [
- lion rabbit set [
- rabbit rabbit set out
- ] with-scope
- ] with-scope
-] unit-test
-
-[ elephant ] [
- rabbit <bowler>
- [
- elephant rabbit set [
- rabbit rabbit set
- ] with-scope
- out
- ] with-scope
-] unit-test
-
-[ rabbit ] [
- rabbit <bowler>
- [
- elephant in [
- rabbit in out
- ] with-scope
- ] with-scope
-] unit-test
-
-[ elephant ] [
- rabbit <bowler>
- [
- elephant in [
- rabbit in
- ] with-scope
- out
- ] with-scope
-] unit-test
-
-! Top Hats
-[ lion ] [ lion rabbit set-global rabbit <top-hat> out ] unit-test
-[ giraffe ] [ rabbit <top-hat> giraffe in out ] unit-test
-
-! Tuple hats
-TUPLE: foo bar ;
-C: <foo> foo
-
-: test-tuple ( -- tuple )
- rabbit <foo> ;
-
-: test-slot-hat ( -- slot-hat )
- test-tuple 2 <slot-hat> ; ! hack!
-
-[ rabbit ] [ test-slot-hat out ] unit-test
-[ lion ] [ test-slot-hat lion in out ] unit-test
-
-! Boxes as hats
-[ rabbit ] [ <box> rabbit in out ] unit-test
-[ <box> rabbit in lion in ] must-fail
-[ <box> out ] must-fail
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors boxes kernel namespaces ;
-IN: hats
-
-! Bullwinkle: Hey Rocky, watch me pull a rabbit out of my hat!
-! Rocky: But that trick never works!
-! Bullwinkle: This time for sure!
-
-! hat protocol
-MIXIN: hat
-
-GENERIC: out ( hat -- object )
-GENERIC: (in) ( object hat -- )
-
-: in ( hat object -- hat ) over (in) ; inline
-: empty-hat? ( hat -- ? ) out not ; inline
-: empty-hat ( hat -- hat ) f in ; inline
-: take ( hat -- object ) dup out f rot (in) ; inline
-: change-hat ( hat quot -- hat )
- over >r >r out r> call r> swap in ; inline
-
-! caps (the simplest of hats)
-TUPLE: cap object ;
-C: <cap> cap
-M: cap out ( cap -- object ) object>> ;
-M: cap (in) ( object cap -- ) (>>object) ;
-INSTANCE: cap hat
-
-! bowlers (dynamic variable hats)
-TUPLE: bowler variable ;
-C: <bowler> bowler
-M: bowler out ( bowler -- object ) variable>> get ;
-M: bowler (in) ( object bowler -- ) variable>> set ;
-INSTANCE: bowler hat
-
-! Top Hats (global variable hats)
-TUPLE: top-hat variable ;
-C: <top-hat> top-hat
-M: top-hat out ( top-hat -- object ) variable>> get-global ;
-M: top-hat (in) ( object top-hat -- ) variable>> set-global ;
-INSTANCE: top-hat hat
-
-USE: slots.private
-! Slot hats
-TUPLE: slot-hat tuple slot ;
-C: <slot-hat> slot-hat
-: >slot-hat< ( slot-hat -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
-M: slot-hat out ( slot-hat -- object ) >slot-hat< slot ;
-M: slot-hat (in) ( object slot-hat -- ) >slot-hat< set-slot ;
-INSTANCE: slot-hat hat
-
-! Put a box on your head
-M: box out ( box -- object ) box> ;
-M: box (in) ( object box -- ) >box ;
-INSTANCE: box hat
-
+++ /dev/null
-A protocol for getting and setting
projects / factor.git / commitdiff