From 06eeedcb4cc624d418f47689766feb3b8622800f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 31 Jul 2009 21:48:17 -0500 Subject: [PATCH] change-tracking-tuple class. subclasses will have a "changed?" slot that gets set to true when any slot is modified --- core/classes/classes-docs.factor | 17 ++++++++++- core/classes/classes.factor | 3 ++ core/slots/slots.factor | 28 +++++++++++++------ .../classes/tuple/change-tracking/authors.txt | 1 + .../change-tracking-tests.factor | 10 +++++++ .../change-tracking/change-tracking.factor | 23 +++++++++++++++ .../classes/tuple/change-tracking/summary.txt | 1 + 7 files changed, 74 insertions(+), 9 deletions(-) create mode 100644 extra/classes/tuple/change-tracking/authors.txt create mode 100644 extra/classes/tuple/change-tracking/change-tracking-tests.factor create mode 100644 extra/classes/tuple/change-tracking/change-tracking.factor create mode 100644 extra/classes/tuple/change-tracking/summary.txt diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 109a3b8089..32bf483f72 100644 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -35,6 +35,7 @@ $nl "You can ask a class for its superclass:" { $subsection superclass } { $subsection superclasses } +{ $subsection subclass-of? } "Class predicates can be used to test instances directly:" { $subsection "class-predicates" } "There is a universal class which all objects are an instance of, and an empty class with no instances:" @@ -102,7 +103,21 @@ HELP: superclasses } } ; -{ superclass superclasses } related-words +HELP: subclass-of? +{ $values + { "class" class } + { "superclass" class } + { "?" boolean } +} +{ $description "Outputs a boolean value indicating whether " { $snippet "class" } " is at any level a subclass of " { $snippet "superclass" } "." } +{ $examples + { $example "USING: classes classes.tuple prettyprint words ;" + "tuple-class \\ class subclass-of? ." + "t" + } +} ; + +{ superclass superclasses subclass-of? } related-words HELP: members { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } } diff --git a/core/classes/classes.factor b/core/classes/classes.factor index dfaec95f76..f009368420 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -59,6 +59,9 @@ M: predicate reset-word : superclasses ( class -- supers ) [ superclass ] follow reverse ; +: subclass-of? ( class superclass -- ? ) + swap superclasses member? ; + : members ( class -- seq ) #! Output f for non-classes to work with algebra code dup class? [ "members" word-prop ] [ drop f ] if ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 304ded0adb..9215857018 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -26,8 +26,10 @@ PREDICATE: writer-method < method-body "writing" word-prop ; [ drop define ] 3bi ; -: reader-quot ( slot-spec -- quot ) - [ +GENERIC# reader-quot 1 ( class slot-spec -- quot ) + +M: object reader-quot + nip [ dup offset>> , \ slot , dup class>> object bootstrap-word eq? @@ -51,8 +53,12 @@ PREDICATE: writer-method < method-body "writing" word-prop ; : define-reader ( class slot-spec -- ) [ nip name>> define-reader-generic ] [ - [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri - define-typecheck + { + [ drop ] + [ nip name>> reader-word ] + [ reader-quot ] + [ nip reader-props ] + } 2cleave define-typecheck ] 2bi ; : writer-word ( name -- word ) @@ -83,8 +89,10 @@ ERROR: bad-slot-value value class ; : writer-quot/fixnum ( slot-spec -- ) [ [ >fixnum ] dip ] % writer-quot/check ; -: writer-quot ( slot-spec -- quot ) - [ +GENERIC# writer-quot 1 ( class slot-spec -- quot ) + +M: object writer-quot + nip [ { { [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] } { [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] } @@ -101,8 +109,12 @@ ERROR: bad-slot-value value class ; : define-writer ( class slot-spec -- ) [ nip name>> define-writer-generic ] [ - [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri - define-typecheck + { + [ drop ] + [ nip name>> writer-word ] + [ writer-quot ] + [ nip writer-props ] + } 2cleave define-typecheck ] 2bi ; : setter-word ( name -- word ) diff --git a/extra/classes/tuple/change-tracking/authors.txt b/extra/classes/tuple/change-tracking/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/classes/tuple/change-tracking/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/classes/tuple/change-tracking/change-tracking-tests.factor b/extra/classes/tuple/change-tracking/change-tracking-tests.factor new file mode 100644 index 0000000000..e0289500bc --- /dev/null +++ b/extra/classes/tuple/change-tracking/change-tracking-tests.factor @@ -0,0 +1,10 @@ +USING: classes.tuple.change-tracking tools.test ; +IN: classes.tuple.change-tracking.tests + +TUPLE: resource < change-tracking-tuple + { pathname string } ; + +: ( pathname -- resource ) f swap resource boa ; + +[ t ] [ "foo" "bar" >>pathname changed?>> ] unit-test +[ f ] [ "foo" [ 123 >>pathname ] [ drop ] recover changed?>> ] unit-test diff --git a/extra/classes/tuple/change-tracking/change-tracking.factor b/extra/classes/tuple/change-tracking/change-tracking.factor new file mode 100644 index 0000000000..3e210922b5 --- /dev/null +++ b/extra/classes/tuple/change-tracking/change-tracking.factor @@ -0,0 +1,23 @@ +! (c)2009 Joe Groff bsd license +USING: accessors classes classes.tuple fry kernel sequences slots ; +IN: classes.tuple.change-tracking + +TUPLE: change-tracking-tuple + { changed? boolean } ; + +PREDICATE: change-tracking-tuple-class < tuple-class + change-tracking-tuple subclass-of? ; + +: changed? ( tuple -- changed? ) changed?>> ; inline +: clear-changed ( tuple -- tuple ) f >>changed? ; inline + +: filter-changed ( sequence -- sequence' ) [ changed? ] filter ; inline + +> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ; + +PRIVATE> + diff --git a/extra/classes/tuple/change-tracking/summary.txt b/extra/classes/tuple/change-tracking/summary.txt new file mode 100644 index 0000000000..3545c4b258 --- /dev/null +++ b/extra/classes/tuple/change-tracking/summary.txt @@ -0,0 +1 @@ +Tuple classes that keep track of when they've been modified