! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system
-kernel.private tuples bit-arrays byte-arrays float-arrays
-arrays ;
+kernel.private bit-arrays byte-arrays float-arrays arrays ;
IN: alien
! Some predicate classes used by the compiler for optimization
! See http://factorcode.org/license.txt for BSD license.
USING: compiler cpu.architecture vocabs.loader system sequences
namespaces parser kernel kernel.private classes classes.private
-arrays hashtables vectors tuples sbufs inference.dataflow
-hashtables.private sequences.private math tuples.private
+arrays hashtables vectors classes.tuple sbufs inference.dataflow
+hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words generator command-line
vocabs io prettyprint libc compiler.units ;
IN: bootstrap.compiler
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
-splitting growable classes tuples tuples.private words.private
-io.binary io.files vocabs vocabs.loader source-files
-definitions debugger float-arrays quotations.private
-sequences.private combinators io.encodings.binary ;
+splitting growable classes classes.tuple classes.tuple.private
+words.private io.binary io.files vocabs vocabs.loader
+source-files definitions debugger float-arrays
+quotations.private sequences.private combinators
+io.encodings.binary ;
IN: bootstrap.image
: my-arch ( -- arch )
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
-float-arrays quotations assocs layouts tuples tuples.private ;
+float-arrays quotations assocs layouts classes.tuple.private ;
BIN: 111 tag-mask set
8 num-tags set
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
-strings vectors words quotations assocs layouts classes tuples
-tuples.private kernel.private vocabs vocabs.loader source-files
-definitions slots.deprecated classes.union compiler.units
-bootstrap.image.private io.files ;
+strings vectors words quotations assocs layouts classes
+classes.tuple classes.tuple.private kernel.private vocabs
+vocabs.loader source-files definitions slots.deprecated
+classes.union compiler.units bootstrap.image.private io.files ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
"byte-arrays"
"byte-vectors"
"classes.private"
+ "classes.tuple"
+ "classes.tuple.private"
"compiler.units"
"continuations.private"
"float-arrays"
"system.private"
"threads.private"
"tools.profiler.private"
- "tuples"
- "tuples.private"
"words"
"words.private"
"vectors"
"callstack" "kernel" create { } define-builtin
-"tuple-layout" "tuples.private" create {
+"tuple-layout" "classes.tuple.private" create {
{
{ "fixnum" "math" }
"hashcode"
- { "layout-hashcode" "tuples.private" }
+ { "layout-hashcode" "classes.tuple.private" }
f
}
{
{ "word" "words" }
"class"
- { "layout-class" "tuples.private" }
+ { "layout-class" "classes.tuple.private" }
f
}
{
{ "fixnum" "math" }
"size"
- { "layout-size" "tuples.private" }
+ { "layout-size" "classes.tuple.private" }
f
}
{
{ "array" "arrays" }
"superclasses"
- { "layout-superclasses" "tuples.private" }
+ { "layout-superclasses" "classes.tuple.private" }
f
}
{
{ "fixnum" "math" }
"echelon"
- { "layout-echelon" "tuples.private" }
+ { "layout-echelon" "classes.tuple.private" }
f
}
} define-builtin
{ "<string>" "strings" }
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
- { "<tuple>" "tuples.private" }
- { "<tuple-layout>" "tuples.private" }
+ { "<tuple>" "classes.tuple.private" }
+ { "<tuple-layout>" "classes.tuple.private" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
- { "<tuple-boa>" "tuples.private" }
+ { "<tuple-boa>" "classes.tuple.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
--- /dev/null
+Slava Pestov
--- /dev/null
+Object system implementation
--- /dev/null
+USING: generic help.markup help.syntax kernel
+classes.tuple.private classes slots quotations words arrays
+generic.standard sequences definitions compiler.units ;
+IN: classes.tuple
+
+ARTICLE: "tuple-constructors" "Constructors"
+"Tuples are created by calling one of two words:"
+{ $subsection construct-empty }
+{ $subsection construct-boa }
+"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
+$nl
+"A shortcut for defining BOA constructors:"
+{ $subsection POSTPONE: C: }
+"Examples of constructors:"
+{ $code
+ "TUPLE: color red green blue alpha ;"
+ ""
+ "C: <rgba> rgba"
+ ": <rgba> color construct-boa ; ! identical to above"
+ ""
+ ": <rgb> f <rgba> ;"
+ ""
+ ": <color> construct-empty ;"
+ ": <color> f f f f <rgba> ; ! identical to above"
+} ;
+
+ARTICLE: "tuple-delegation" "Tuple delegation"
+"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
+{ $subsection delegate }
+{ $subsection set-delegate }
+"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution."
+$nl
+"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object."
+$nl
+"A pair of words examine delegation chains:"
+{ $subsection delegates }
+{ $subsection is? }
+"An example:"
+{ $example
+ "TUPLE: ellipse center radius ;"
+ "TUPLE: colored color ;"
+ "{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
+ "{ 1 0 0 } <colored> \"my-shape\" set"
+ "\"my-ellipse\" get \"my-shape\" get set-delegate"
+ "\"my-shape\" get dup color>> swap center>> .s"
+ "{ 0 0 }\n{ 1 0 0 }"
+} ;
+
+ARTICLE: "tuple-introspection" "Tuple introspection"
+"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
+{ $subsection >tuple }
+{ $subsection tuple>array }
+{ $subsection tuple-slots }
+"Tuple classes can also be defined at run time:"
+{ $subsection define-tuple-class }
+{ $see-also "slots" "mirrors" } ;
+
+ARTICLE: "tuple-examples" "Tuple examples"
+"An example:"
+{ $code "TUPLE: employee name salary position ;" }
+"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
+{ $table
+ { "Reader" "Writer" "Setter" "Changer" }
+ { { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } }
+ { { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } }
+ { { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } }
+}
+"We can define a constructor which makes an empty employee:"
+{ $code ": <employee> ( -- employee )"
+ " employee construct-empty ;" }
+"Or we may wish the default constructor to always give employees a starting salary:"
+{ $code
+ ": <employee> ( -- employee )"
+ " employee construct-empty"
+ " 40000 >>salary ;"
+}
+"We can define more refined constructors:"
+{ $code
+ ": <manager> ( -- manager )"
+ " <employee> \"project manager\" >>position ;" }
+"An alternative strategy is to define the most general BOA constructor first:"
+{ $code
+ ": <employee> ( name position -- person )"
+ " 40000 employee construct-boa ;"
+}
+"Now we can define more specific constructors:"
+{ $code
+ ": <manager> ( name -- person )"
+ " \"manager\" <person> ;" }
+"An example using reader words:"
+{ $code
+ "TUPLE: check to amount number ;"
+ ""
+ "SYMBOL: checks"
+ ""
+ ": <check> ( to amount -- check )"
+ " checks counter check construct-boa ;"
+ ""
+ ": biweekly-paycheck ( employee -- check )"
+ " dup name>> swap salary>> 26 / <check> ;"
+}
+"An example of using a changer:"
+{ $code
+ ": positions"
+ " {"
+ " \"junior programmer\""
+ " \"senior programmer\""
+ " \"project manager\""
+ " \"department manager\""
+ " \"executive\""
+ " \"CTO\""
+ " \"CEO\""
+ " \"enterprise Java world dictator\""
+ " } ;"
+ ""
+ ": next-position ( role -- newrole )"
+ " positions [ index 1+ ] keep nth ;"
+ ""
+ ": promote ( person -- person )"
+ " [ 1.2 * ] change-salary"
+ " [ next-position ] change-position ;"
+} ;
+
+ARTICLE: "tuples" "Tuples"
+"Tuples are user-defined classes composed of named slots."
+{ $subsection "tuple-examples" }
+"A parsing word defines tuple classes:"
+{ $subsection POSTPONE: TUPLE: }
+"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
+$nl
+"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
+{ $subsection "accessors" }
+"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
+{ $subsection "tuple-constructors" }
+"Further topics:"
+{ $subsection "tuple-delegation" }
+{ $subsection "tuple-introspection" }
+"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
+
+ABOUT: "tuples"
+
+HELP: delegate
+{ $values { "obj" object } { "delegate" object } }
+{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." }
+{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ;
+
+HELP: set-delegate
+{ $values { "delegate" object } { "tuple" tuple } }
+{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ;
+
+HELP: tuple=
+{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
+{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
+{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
+
+HELP: permutation
+{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
+{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
+
+HELP: reshape-tuple
+{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } }
+{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ;
+
+HELP: reshape-tuples
+{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
+{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
+
+HELP: removed-slots
+{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
+{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
+
+HELP: forget-slots
+{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
+{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
+
+HELP: tuple
+{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
+$nl
+"Tuple classes have additional word properties:"
+{ $list
+ { { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
+ { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
+ { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
+ { { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
+ { { $snippet "\"tuple-size\"" } " - the number of slots" }
+} } ;
+
+HELP: define-tuple-predicate
+{ $values { "class" tuple-class } }
+{ $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." }
+$low-level-note ;
+
+HELP: redefine-tuple-class
+{ $values { "class" class } { "superclass" class } { "slots" "a sequence of strings" } }
+{ $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
+$nl
+"If the class is not a tuple class word, this word does nothing." }
+$low-level-note ;
+
+HELP: tuple-slots
+{ $values { "tuple" tuple } { "seq" sequence } }
+{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ;
+
+{ tuple-slots tuple>array } related-words
+
+HELP: define-tuple-slots
+{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
+{ $description "Defines slot accessor and mutator words for the tuple." }
+$low-level-note ;
+
+HELP: check-tuple
+{ $values { "class" class } }
+{ $description "Throws a " { $link check-tuple } " error if " { $snippet "word" } " is not a tuple class word." }
+{ $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ;
+
+HELP: define-tuple-class
+{ $values { "class" word } { "superclass" class } { "slots" "a sequence of strings" } }
+{ $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
+{ $side-effects "class" } ;
+
+{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
+
+HELP: delegates
+{ $values { "obj" object } { "seq" sequence } }
+{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
+
+HELP: is?
+{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
+{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
+$nl
+"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
+
+HELP: >tuple
+{ $values { "seq" sequence } { "tuple" tuple } }
+{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots."
+$nl
+"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
+{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
+
+HELP: tuple>array ( tuple -- array )
+{ $values { "tuple" tuple } { "array" array } }
+{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
+
+HELP: <tuple> ( layout -- tuple )
+{ $values { "layout" tuple-layout } { "tuple" tuple } }
+{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
+
+HELP: <tuple-boa> ( ... layout -- tuple )
+{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
+{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
+
+HELP: construct-empty
+{ $values { "class" tuple-class } { "tuple" tuple } }
+{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
+{ $examples
+ { $example
+ "USING: kernel prettyprint ;"
+ "TUPLE: employee number name department ;"
+ "employee construct-empty ."
+ "T{ employee f f f f }"
+ }
+} ;
+
+HELP: construct
+{ $values { "..." "slot values" } { "slots" "a sequence of setter words" } { "class" tuple-class } { "tuple" tuple } }
+{ $description "Creates a new instance of " { $snippet "class" } ", storing consecutive stack values into the slots of the new tuple using setter words in " { $snippet "slots" } ". The top-most stack element is stored in the right-most slot." }
+{ $examples
+ "We can define a class:"
+ { $code "TUPLE: color red green blue alpha ;" }
+ "Together with two constructors:"
+ { $code
+ ": <rgb> ( r g b -- color )"
+ " { set-color-red set-color-green set-color-blue }"
+ " color construct ;"
+ ""
+ ": <rgba> ( r g b a -- color )"
+ " { set-color-red set-color-green set-color-blue set-color-alpha }"
+ " color construct ;"
+ }
+ "The last definition is actually equivalent to the following:"
+ { $code ": <rgba> ( r g b a -- color ) rgba construct-boa ;" }
+ "Which can be abbreviated further:"
+ { $code "C: <rgba> color" }
+} ;
+
+HELP: construct-boa
+{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
+{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
+{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
--- /dev/null
+USING: definitions generic kernel kernel.private math
+math.constants parser sequences tools.test words assocs
+namespaces quotations sequences.private classes continuations
+generic.standard effects classes.tuple classes.tuple.private
+arrays vectors strings compiler.units accessors classes.algebra
+calendar prettyprint io.streams.string splitting ;
+IN: classes.tuple.tests
+
+TUPLE: rect x y w h ;
+: <rect> rect construct-boa ;
+
+: move ( x rect -- rect )
+ [ + ] change-x ;
+
+[ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
+
+[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
+
+GENERIC: delegation-test
+M: object delegation-test drop 3 ;
+TUPLE: quux-tuple ;
+: <quux-tuple> quux-tuple construct-empty ;
+M: quux-tuple delegation-test drop 4 ;
+TUPLE: quuux-tuple ;
+: <quuux-tuple> { set-delegate } quuux-tuple construct ;
+
+[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
+
+GENERIC: delegation-test-2
+TUPLE: quux-tuple-2 ;
+: <quux-tuple-2> quux-tuple-2 construct-empty ;
+M: quux-tuple-2 delegation-test-2 drop 4 ;
+TUPLE: quuux-tuple-2 ;
+: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
+
+[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
+
+! Make sure we handle tuple class redefinition
+TUPLE: redefinition-test ;
+
+C: <redefinition-test> redefinition-test
+
+<redefinition-test> "redefinition-test" set
+
+[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
+
+"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval
+
+[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
+
+! Make sure we handle changing shapes!
+TUPLE: point x y ;
+
+C: <point> point
+
+[ ] [ 100 200 <point> "p" set ] unit-test
+
+! Use eval to sequence parsing explicitly
+[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test
+
+[ 100 ] [ "p" get x>> ] unit-test
+[ 200 ] [ "p" get y>> ] unit-test
+[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
+
+"p" get 300 ">>z" "accessors" lookup execute drop
+
+[ 4 ] [ "p" get tuple-size ] unit-test
+
+[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
+
+"IN: classes.tuple.tests TUPLE: point z y ;" eval
+
+[ 3 ] [ "p" get tuple-size ] unit-test
+
+[ "p" get x>> ] must-fail
+[ 200 ] [ "p" get y>> ] unit-test
+[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
+
+TUPLE: predicate-test ;
+
+C: <predicate-test> predicate-test
+
+: predicate-test drop f ;
+
+[ t ] [ <predicate-test> predicate-test? ] unit-test
+
+PREDICATE: silly-pred < tuple
+ class \ rect = ;
+
+GENERIC: area
+M: silly-pred area dup w>> swap h>> * ;
+
+TUPLE: circle radius ;
+M: circle area radius>> sq pi * ;
+
+[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
+
+! Hashcode breakage
+TUPLE: empty ;
+
+C: <empty> empty
+
+[ t ] [ <empty> hashcode fixnum? ] unit-test
+
+TUPLE: delegate-clone ;
+
+[ T{ delegate-clone T{ empty f } } ]
+[ T{ delegate-clone T{ empty f } } clone ] unit-test
+
+! Compiler regression
+[ t length ] [ object>> t eq? ] must-fail-with
+
+[ "<constructor-test>" ]
+[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
+
+TUPLE: size-test a b c d ;
+
+[ t ] [
+ T{ size-test } tuple-size
+ size-test tuple-size =
+] unit-test
+
+GENERIC: <yo-momma>
+
+TUPLE: yo-momma ;
+
+"IN: classes.tuple.tests C: <yo-momma> yo-momma" eval
+
+[ f ] [ \ <yo-momma> generic? ] unit-test
+
+! Test forget
+[
+ [ t ] [ \ yo-momma class? ] unit-test
+ [ ] [ \ yo-momma forget ] unit-test
+ [ f ] [ \ yo-momma update-map get values memq? ] unit-test
+
+ [ f ] [ \ yo-momma crossref get at ] unit-test
+] with-compilation-unit
+
+TUPLE: loc-recording ;
+
+[ f ] [ \ loc-recording where not ] unit-test
+
+! 'forget' wasn't robust enough
+
+TUPLE: forget-robustness ;
+
+GENERIC: forget-robustness-generic
+
+M: forget-robustness forget-robustness-generic ;
+
+M: integer forget-robustness-generic ;
+
+[
+ [ ] [ \ forget-robustness-generic forget ] unit-test
+ [ ] [ \ forget-robustness forget ] unit-test
+ [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test
+] with-compilation-unit
+
+! rapido found this one
+GENERIC# m1 0 ( s n -- n )
+GENERIC# m2 1 ( s n -- v )
+
+TUPLE: t1 ;
+
+M: t1 m1 drop ;
+M: t1 m2 nip ;
+
+TUPLE: t2 ;
+
+M: t2 m1 drop ;
+M: t2 m2 nip ;
+
+TUPLE: t3 ;
+
+M: t3 m1 drop ;
+M: t3 m2 nip ;
+
+TUPLE: t4 ;
+
+M: t4 m1 drop ;
+M: t4 m2 nip ;
+
+C: <t4> t4
+
+[ 1 ] [ 1 <t4> m1 ] unit-test
+[ 1 ] [ <t4> 1 m2 ] unit-test
+
+! another combination issue
+GENERIC: silly
+
+UNION: my-union slice repetition column array vector reversed ;
+
+M: my-union silly "x" ;
+
+M: array silly "y" ;
+
+M: column silly "fdsfds" ;
+
+M: repetition silly "zzz" ;
+
+M: reversed silly "zz" ;
+
+M: slice silly "tt" ;
+
+M: string silly "t" ;
+
+M: vector silly "z" ;
+
+[ "zz" ] [ 123 <reversed> silly nip ] unit-test
+
+! Typo
+SYMBOL: not-a-tuple-class
+
+[
+ "IN: classes.tuple.tests C: <not-a-tuple-class> not-a-tuple-class"
+ eval
+] must-fail
+
+[ t ] [
+ "not-a-tuple-class" "classes.tuple.tests" lookup symbol?
+] unit-test
+
+! Missing check
+[ not-a-tuple-class construct-boa ] must-fail
+[ not-a-tuple-class construct-empty ] must-fail
+
+TUPLE: erg's-reshape-problem a b c d ;
+
+C: <erg's-reshape-problem> erg's-reshape-problem
+
+! We want to make sure constructors are recompiled when
+! tuples are reshaped
+: cons-test-1 \ erg's-reshape-problem construct-empty ;
+: cons-test-2 \ erg's-reshape-problem construct-boa ;
+
+"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
+
+[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
+
+[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
+
+[
+ "IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
+] [ [ no-tuple-class? ] is? ] must-fail-with
+
+! Inheritance
+TUPLE: computer cpu ram ;
+C: <computer> computer
+
+[ "TUPLE: computer cpu ram ;" ] [
+ [ \ computer see ] with-string-writer string-lines second
+] unit-test
+
+TUPLE: laptop < computer battery ;
+C: <laptop> laptop
+
+[ t ] [ laptop tuple-class? ] unit-test
+[ t ] [ laptop tuple class< ] unit-test
+[ t ] [ laptop computer class< ] unit-test
+[ t ] [ laptop computer classes-intersect? ] unit-test
+
+[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
+[ t ] [ "laptop" get laptop? ] unit-test
+[ t ] [ "laptop" get computer? ] unit-test
+[ t ] [ "laptop" get tuple? ] unit-test
+
+[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
+[ 128 ] [ "laptop" get ram>> ] unit-test
+[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
+
+[ laptop ] [
+ "laptop" get tuple-layout
+ dup layout-echelon swap
+ layout-superclasses nth
+] unit-test
+
+[ "TUPLE: laptop < computer battery ;" ] [
+ [ \ laptop see ] with-string-writer string-lines second
+] unit-test
+
+[ { tuple computer laptop } ] [ laptop superclasses ] unit-test
+
+TUPLE: server < computer rackmount ;
+C: <server> server
+
+[ t ] [ server tuple-class? ] unit-test
+[ t ] [ server tuple class< ] unit-test
+[ t ] [ server computer class< ] unit-test
+[ t ] [ server computer classes-intersect? ] unit-test
+
+[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
+[ t ] [ "server" get server? ] unit-test
+[ t ] [ "server" get computer? ] unit-test
+[ t ] [ "server" get tuple? ] unit-test
+
+[ "PowerPC" ] [ "server" get cpu>> ] unit-test
+[ 64 ] [ "server" get ram>> ] unit-test
+[ "1U" ] [ "server" get rackmount>> ] unit-test
+
+[ f ] [ "server" get laptop? ] unit-test
+[ f ] [ "laptop" get server? ] unit-test
+
+[ f ] [ server laptop class< ] unit-test
+[ f ] [ laptop server class< ] unit-test
+[ f ] [ laptop server classes-intersect? ] unit-test
+
+[ f ] [ 1 2 <computer> laptop? ] unit-test
+[ f ] [ \ + server? ] unit-test
+
+[ "TUPLE: server < computer rackmount ;" ] [
+ [ \ server see ] with-string-writer string-lines second
+] unit-test
+
+[
+ "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
+] must-fail
+
+! Reshaping with inheritance
+TUPLE: electronic-device ;
+
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test
+
+[ f ] [ electronic-device laptop class< ] unit-test
+[ t ] [ server electronic-device class< ] unit-test
+[ t ] [ laptop server class-or electronic-device class< ] unit-test
+
+[ t ] [ "laptop" get electronic-device? ] unit-test
+[ t ] [ "laptop" get computer? ] unit-test
+[ t ] [ "laptop" get laptop? ] unit-test
+[ f ] [ "laptop" get server? ] unit-test
+
+[ t ] [ "server" get electronic-device? ] unit-test
+[ t ] [ "server" get computer? ] unit-test
+[ f ] [ "server" get laptop? ] unit-test
+[ t ] [ "server" get server? ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test
+
+[ f ] [ "laptop" get electronic-device? ] unit-test
+[ t ] [ "laptop" get computer? ] unit-test
+
+! Hardcore unit tests
+USE: threads
+
+\ thread slot-names "slot-names" set
+
+[ ] [
+ [
+ \ thread tuple { "xxx" } "slot-names" get append
+ define-tuple-class
+ ] with-compilation-unit
+
+ [ 1337 sleep ] "Test" spawn drop
+
+ [
+ \ thread tuple "slot-names" get
+ define-tuple-class
+ ] with-compilation-unit
+] unit-test
+
+USE: vocabs
+
+\ vocab slot-names "slot-names" set
+
+[ ] [
+ [
+ \ vocab tuple { "xxx" } "slot-names" get append
+ define-tuple-class
+ ] with-compilation-unit
+
+ all-words drop
+
+ [
+ \ vocab tuple "slot-names" get
+ define-tuple-class
+ ] with-compilation-unit
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays definitions hashtables kernel
+kernel.private math namespaces sequences sequences.private
+strings vectors words quotations memory combinators generic
+classes classes.private slots.deprecated slots.private slots
+compiler.units math.private accessors assocs ;
+IN: classes.tuple
+
+M: tuple delegate 2 slot ;
+
+M: tuple set-delegate 2 set-slot ;
+
+M: tuple class 1 slot 2 slot { word } declare ;
+
+ERROR: no-tuple-class class ;
+
+<PRIVATE
+
+GENERIC: tuple-layout ( object -- layout )
+
+M: class tuple-layout "layout" word-prop ;
+
+M: tuple tuple-layout 1 slot ;
+
+: tuple-size tuple-layout layout-size ; inline
+
+PRIVATE>
+
+: check-tuple ( class -- )
+ dup tuple-class?
+ [ drop ] [ no-tuple-class ] if ;
+
+: tuple>array ( tuple -- array )
+ dup tuple-layout
+ [ layout-size swap [ array-nth ] curry map ] keep
+ layout-class add* ;
+
+: >tuple ( seq -- tuple )
+ dup first tuple-layout <tuple> [
+ >r 1 tail-slice dup length r>
+ [ tuple-size min ] keep
+ [ set-array-nth ] curry
+ 2each
+ ] keep ;
+
+: slot-names ( class -- seq )
+ "slots" word-prop [ name>> ] map ;
+
+<PRIVATE
+
+: tuple= ( tuple1 tuple2 -- ? )
+ over tuple-layout over tuple-layout eq? [
+ dup tuple-size -rot
+ [ >r over r> array-nth >r array-nth r> = ] 2curry
+ all-integers?
+ ] [
+ 2drop f
+ ] if ;
+
+! Predicate generation. We optimize at the expense of simplicity
+
+: (tuple-predicate-quot) ( class -- quot )
+ #! 4 slot == layout-superclasses
+ #! 5 slot == layout-echelon
+ [
+ [ 1 slot dup 5 slot ] %
+ dup tuple-layout layout-echelon ,
+ [ fixnum>= ] %
+ [
+ dup tuple-layout layout-echelon ,
+ [ swap 4 slot array-nth ] %
+ literalize ,
+ [ eq? ] %
+ ] [ ] make ,
+ [ drop f ] ,
+ \ if ,
+ ] [ ] make ;
+
+: tuple-predicate-quot ( class -- quot )
+ [
+ [ dup tuple? ] %
+ (tuple-predicate-quot) ,
+ [ drop f ] ,
+ \ if ,
+ ] [ ] make ;
+
+: define-tuple-predicate ( class -- )
+ dup tuple-predicate-quot define-predicate ;
+
+: superclass-size ( class -- n )
+ superclasses 1 head-slice*
+ [ slot-names length ] map sum ;
+
+: generate-tuple-slots ( class slots -- slots )
+ over superclass-size 2 + simple-slots ;
+
+: define-tuple-slots ( class slots -- )
+ dupd generate-tuple-slots
+ [ "slots" set-word-prop ]
+ [ define-accessors ]
+ [ define-slots ] 2tri ;
+
+: make-tuple-layout ( class -- layout )
+ [ ]
+ [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
+ [ superclasses dup length 1- ] tri
+ <tuple-layout> ;
+
+: define-tuple-layout ( class -- )
+ dup make-tuple-layout "layout" set-word-prop ;
+
+: removed-slots ( class newslots -- seq )
+ swap slot-names seq-diff ;
+
+: forget-slots ( class slots -- )
+ dupd removed-slots [
+ [ reader-word forget-method ]
+ [ writer-word forget-method ] 2bi
+ ] with each ;
+
+: permutation ( seq1 seq2 -- permutation )
+ swap [ index ] curry map ;
+
+: reshape-tuple ( oldtuple permutation -- newtuple )
+ >r tuple>array 2 cut r>
+ [ [ swap ?nth ] [ drop f ] if* ] with map
+ append >tuple ;
+
+: reshape-tuples ( class superclass newslots -- )
+ nip
+ >r dup slot-names r> permutation
+ [
+ >r "predicate" word-prop instances dup
+ r> [ reshape-tuple ] curry map
+ become
+ ] 2curry after-compilation ;
+
+: define-new-tuple-class ( class superclass slots -- )
+ [ drop f tuple-class define-class ]
+ [ nip define-tuple-slots ] [
+ 2drop
+ class-usages [
+ drop
+ [ define-tuple-layout ]
+ [ define-tuple-predicate ]
+ bi
+ ] assoc-each
+ ] 3tri ;
+
+: redefine-tuple-class ( class superclass slots -- )
+ [ reshape-tuples ]
+ [
+ nip
+ [ forget-slots ]
+ [ drop changed-word ]
+ [ drop redefined ]
+ 2tri
+ ]
+ [ define-new-tuple-class ]
+ 3tri ;
+
+: tuple-class-unchanged? ( class superclass slots -- ? )
+ rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
+
+PRIVATE>
+
+GENERIC# define-tuple-class 2 ( class superclass slots -- )
+
+M: word define-tuple-class
+ define-new-tuple-class ;
+
+M: tuple-class define-tuple-class
+ 3dup tuple-class-unchanged?
+ [ 3dup redefine-tuple-class ] unless
+ 3drop ;
+
+: define-error-class ( class superclass slots -- )
+ pick >r define-tuple-class r>
+ dup [ construct-boa throw ] curry define ;
+
+M: tuple clone
+ (clone) dup delegate clone over set-delegate ;
+
+M: tuple equal?
+ over tuple? [ tuple= ] [ 2drop f ] if ;
+
+: delegates ( obj -- seq )
+ [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
+
+: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
+
+M: tuple hashcode*
+ [
+ dup tuple-size -rot 0 -rot [
+ swapd array-nth hashcode* bitxor
+ ] 2curry reduce
+ ] recursive-hashcode ;
+
+: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
+
+! Definition protocol
+M: tuple-class reset-class
+ { "metaclass" "superclass" "slots" "layout" } reset-props ;
+
+M: object get-slots ( obj slots -- ... )
+ [ execute ] with each ;
+
+M: object set-slots ( ... obj slots -- )
+ <reversed> get-slots ;
+
+M: object construct-empty ( class -- tuple )
+ tuple-layout <tuple> ;
+
+M: object construct ( ... slots class -- tuple )
+ construct-empty [ swap set-slots ] keep ;
+
+M: object construct-boa ( ... class -- tuple )
+ tuple-layout <tuple-boa> ;
math.private namespaces sequences words
quotations byte-arrays hashtables.private hashtables generator
generator.registers generator.fixup sequences.private sbufs
-sbufs.private vectors vectors.private system tuples.private
-layouts strings.private slots.private ;
+sbufs.private vectors vectors.private system
+classes.tuple.private layouts strings.private slots.private ;
IN: cpu.arm.intrinsics
: %slot-literal-known-tag
generic quotations byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private
sbufs vectors system layouts math.floats.private
-classes tuples tuples.private sbufs.private vectors.private
-strings.private slots.private combinators bit-arrays
-float-arrays compiler.constants ;
+classes classes.tuple classes.tuple.private sbufs.private
+vectors.private strings.private slots.private combinators
+bit-arrays float-arrays compiler.constants ;
IN: cpu.ppc.intrinsics
: %slot-literal-known-tag
words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system
-tuples.private strings.private slots.private compiler.constants
-;
+classes.tuple.private strings.private slots.private
+compiler.constants ;
IN: cpu.x86.intrinsics
! Type checks
USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser
-tuples continuations continuations.private combinators
+classes.tuple continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units
generic.standard vocabs threads threads.private init
kernel.private libc io.encodings ;
math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
-prettyprint io inspector tuples classes.union classes.predicate
-debugger threads.private io.streams.string io.timeouts
-io.thread sequences.private ;
+prettyprint io inspector classes.tuple classes.union
+classes.predicate debugger threads.private io.streams.string
+io.timeouts io.thread sequences.private ;
IN: inference.tests
{ 0 2 } [ 2 "Hello" ] must-infer-as
namespaces.private parser prettyprint quotations
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
-threads.private tuples tuples.private vectors vectors.private
-words words.private assocs inspector compiler.units
-system.private ;
+threads.private classes.tuple classes.tuple.private vectors
+vectors.private words words.private assocs inspector
+compiler.units system.private ;
IN: inference.known-words
! Shuffle words
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
-inference.dataflow inference.state tuples.private effects
+inference.dataflow inference.state classes.tuple.private effects
inspector hashtables ;
IN: inference.transforms
>r { set-delegate } r> construct ; inline
! Quotation building
-USE: tuples.private
-
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators
-tuples continuations debugger definitions compiler.units ;
+continuations debugger definitions compiler.units ;
IN: listener
SYMBOL: quit-flag
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
-arrays classes slots slots.private tuples math vectors
+arrays classes slots slots.private classes.tuple math vectors
quotations sorting prettyprint ;
IN: mirrors
sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals
-math.floats.private tuples tuples.private classes
+math.floats.private classes.tuple classes.tuple.private classes
classes.algebra optimizer.def-use optimizer.backend
optimizer.pattern-match optimizer.inlining float-arrays
sequences.private combinators ;
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes classes.algebra inference.dataflow
-tuples.private continuations growable optimizer.inlining
+classes.tuple.private continuations growable optimizer.inlining
namespaces hints ;
IN: optimizer.tests
USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
-sorting tuples compiler.units debugger vocabs vocabs.loader ;
+sorting classes.tuple compiler.units debugger vocabs
+vocabs.loader ;
IN: parser.tests
[
generic hashtables io assocs kernel math namespaces sequences
strings sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
-tuples tuples.private classes float-arrays float-vectors ;
+classes.tuple classes.tuple.private classes float-arrays
+float-vectors ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: prettyprint
USING: alien arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
-definitions effects tuples io.files classes continuations
+definitions effects classes.tuple io.files classes continuations
hashtables classes.mixin classes.union classes.predicate
combinators quotations ;
-! Copyright (C) 2007 Slava Pestov
+! Copyright (C) 2007, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: tuples kernel assocs ;
+USING: classes.tuple kernel assocs accessors ;
IN: refs
TUPLE: ref assoc key ;
: <ref> ( assoc key class -- tuple )
>r ref construct-boa r> construct-delegate ; inline
-: >ref< ( ref -- key assoc ) dup ref-key swap ref-assoc ;
+: >ref< ( ref -- key assoc ) [ key>> ] [ assoc>> ] bi ;
: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
-effects generic.standard tuples slots.private classes
+effects generic.standard classes.tuple slots.private classes
strings math ;
IN: slots
USING: generic help.syntax help.markup kernel math parser words
-effects classes generic.standard tuples generic.math arrays
-io.files vocabs.loader io sequences assocs ;
+effects classes generic.standard classes.tuple generic.math
+arrays io.files vocabs.loader io sequences assocs ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
USING: alien arrays bit-arrays bit-vectors byte-arrays
byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
-quotations io assocs splitting tuples generic.standard
+quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units
combinators debugger ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Object system implementation
+++ /dev/null
-USING: generic help.markup help.syntax kernel
-tuples.private classes slots quotations words arrays
-generic.standard sequences definitions compiler.units ;
-IN: tuples
-
-ARTICLE: "tuple-constructors" "Constructors"
-"Tuples are created by calling one of two words:"
-{ $subsection construct-empty }
-{ $subsection construct-boa }
-"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
-$nl
-"A shortcut for defining BOA constructors:"
-{ $subsection POSTPONE: C: }
-"Examples of constructors:"
-{ $code
- "TUPLE: color red green blue alpha ;"
- ""
- "C: <rgba> rgba"
- ": <rgba> color construct-boa ; ! identical to above"
- ""
- ": <rgb> f <rgba> ;"
- ""
- ": <color> construct-empty ;"
- ": <color> f f f f <rgba> ; ! identical to above"
-} ;
-
-ARTICLE: "tuple-delegation" "Tuple delegation"
-"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
-{ $subsection delegate }
-{ $subsection set-delegate }
-"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution."
-$nl
-"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object."
-$nl
-"A pair of words examine delegation chains:"
-{ $subsection delegates }
-{ $subsection is? }
-"An example:"
-{ $example
- "TUPLE: ellipse center radius ;"
- "TUPLE: colored color ;"
- "{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
- "{ 1 0 0 } <colored> \"my-shape\" set"
- "\"my-ellipse\" get \"my-shape\" get set-delegate"
- "\"my-shape\" get dup color>> swap center>> .s"
- "{ 0 0 }\n{ 1 0 0 }"
-} ;
-
-ARTICLE: "tuple-introspection" "Tuple introspection"
-"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
-{ $subsection >tuple }
-{ $subsection tuple>array }
-{ $subsection tuple-slots }
-"Tuple classes can also be defined at run time:"
-{ $subsection define-tuple-class }
-{ $see-also "slots" "mirrors" } ;
-
-ARTICLE: "tuple-examples" "Tuple examples"
-"An example:"
-{ $code "TUPLE: employee name salary position ;" }
-"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
-{ $table
- { "Reader" "Writer" "Setter" "Changer" }
- { { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } }
- { { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } }
- { { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } }
-}
-"We can define a constructor which makes an empty employee:"
-{ $code ": <employee> ( -- employee )"
- " employee construct-empty ;" }
-"Or we may wish the default constructor to always give employees a starting salary:"
-{ $code
- ": <employee> ( -- employee )"
- " employee construct-empty"
- " 40000 >>salary ;"
-}
-"We can define more refined constructors:"
-{ $code
- ": <manager> ( -- manager )"
- " <employee> \"project manager\" >>position ;" }
-"An alternative strategy is to define the most general BOA constructor first:"
-{ $code
- ": <employee> ( name position -- person )"
- " 40000 employee construct-boa ;"
-}
-"Now we can define more specific constructors:"
-{ $code
- ": <manager> ( name -- person )"
- " \"manager\" <person> ;" }
-"An example using reader words:"
-{ $code
- "TUPLE: check to amount number ;"
- ""
- "SYMBOL: checks"
- ""
- ": <check> ( to amount -- check )"
- " checks counter check construct-boa ;"
- ""
- ": biweekly-paycheck ( employee -- check )"
- " dup name>> swap salary>> 26 / <check> ;"
-}
-"An example of using a changer:"
-{ $code
- ": positions"
- " {"
- " \"junior programmer\""
- " \"senior programmer\""
- " \"project manager\""
- " \"department manager\""
- " \"executive\""
- " \"CTO\""
- " \"CEO\""
- " \"enterprise Java world dictator\""
- " } ;"
- ""
- ": next-position ( role -- newrole )"
- " positions [ index 1+ ] keep nth ;"
- ""
- ": promote ( person -- person )"
- " [ 1.2 * ] change-salary"
- " [ next-position ] change-position ;"
-} ;
-
-ARTICLE: "tuples" "Tuples"
-"Tuples are user-defined classes composed of named slots."
-{ $subsection "tuple-examples" }
-"A parsing word defines tuple classes:"
-{ $subsection POSTPONE: TUPLE: }
-"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
-$nl
-"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
-{ $subsection "accessors" }
-"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
-{ $subsection "tuple-constructors" }
-"Further topics:"
-{ $subsection "tuple-delegation" }
-{ $subsection "tuple-introspection" }
-"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
-
-ABOUT: "tuples"
-
-HELP: delegate
-{ $values { "obj" object } { "delegate" object } }
-{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." }
-{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ;
-
-HELP: set-delegate
-{ $values { "delegate" object } { "tuple" tuple } }
-{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ;
-
-HELP: tuple=
-{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
-{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
-{ $warning "This word is in the " { $vocab-link "tuples.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
-
-HELP: permutation
-{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
-{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
-
-HELP: reshape-tuple
-{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } }
-{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ;
-
-HELP: reshape-tuples
-{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
-{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
-
-HELP: removed-slots
-{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
-{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
-
-HELP: forget-slots
-{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
-{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
-
-HELP: tuple
-{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
-$nl
-"Tuple classes have additional word properties:"
-{ $list
- { { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
- { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
- { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
- { { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
- { { $snippet "\"tuple-size\"" } " - the number of slots" }
-} } ;
-
-HELP: define-tuple-predicate
-{ $values { "class" tuple-class } }
-{ $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." }
-$low-level-note ;
-
-HELP: redefine-tuple-class
-{ $values { "class" class } { "superclass" class } { "slots" "a sequence of strings" } }
-{ $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
-$nl
-"If the class is not a tuple class word, this word does nothing." }
-$low-level-note ;
-
-HELP: tuple-slots
-{ $values { "tuple" tuple } { "seq" sequence } }
-{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ;
-
-{ tuple-slots tuple>array } related-words
-
-HELP: define-tuple-slots
-{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
-{ $description "Defines slot accessor and mutator words for the tuple." }
-$low-level-note ;
-
-HELP: check-tuple
-{ $values { "class" class } }
-{ $description "Throws a " { $link check-tuple } " error if " { $snippet "word" } " is not a tuple class word." }
-{ $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ;
-
-HELP: define-tuple-class
-{ $values { "class" word } { "superclass" class } { "slots" "a sequence of strings" } }
-{ $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
-{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
-{ $side-effects "class" } ;
-
-{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
-
-HELP: delegates
-{ $values { "obj" object } { "seq" sequence } }
-{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
-
-HELP: is?
-{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
-$nl
-"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
-
-HELP: >tuple
-{ $values { "seq" sequence } { "tuple" tuple } }
-{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots."
-$nl
-"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
-{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
-
-HELP: tuple>array ( tuple -- array )
-{ $values { "tuple" tuple } { "array" array } }
-{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
-
-HELP: <tuple> ( layout -- tuple )
-{ $values { "layout" tuple-layout } { "tuple" tuple } }
-{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
-
-HELP: <tuple-boa> ( ... layout -- tuple )
-{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
-{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
-
-HELP: construct-empty
-{ $values { "class" tuple-class } { "tuple" tuple } }
-{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
-{ $examples
- { $example
- "USING: kernel prettyprint ;"
- "TUPLE: employee number name department ;"
- "employee construct-empty ."
- "T{ employee f f f f }"
- }
-} ;
-
-HELP: construct
-{ $values { "..." "slot values" } { "slots" "a sequence of setter words" } { "class" tuple-class } { "tuple" tuple } }
-{ $description "Creates a new instance of " { $snippet "class" } ", storing consecutive stack values into the slots of the new tuple using setter words in " { $snippet "slots" } ". The top-most stack element is stored in the right-most slot." }
-{ $examples
- "We can define a class:"
- { $code "TUPLE: color red green blue alpha ;" }
- "Together with two constructors:"
- { $code
- ": <rgb> ( r g b -- color )"
- " { set-color-red set-color-green set-color-blue }"
- " color construct ;"
- ""
- ": <rgba> ( r g b a -- color )"
- " { set-color-red set-color-green set-color-blue set-color-alpha }"
- " color construct ;"
- }
- "The last definition is actually equivalent to the following:"
- { $code ": <rgba> ( r g b a -- color ) rgba construct-boa ;" }
- "Which can be abbreviated further:"
- { $code "C: <rgba> color" }
-} ;
-
-HELP: construct-boa
-{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
-{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
-{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
+++ /dev/null
-USING: definitions generic kernel kernel.private math
-math.constants parser sequences tools.test words assocs
-namespaces quotations sequences.private classes continuations
-generic.standard effects tuples tuples.private arrays vectors
-strings compiler.units accessors classes.algebra calendar
-prettyprint io.streams.string splitting ;
-IN: tuples.tests
-
-TUPLE: rect x y w h ;
-: <rect> rect construct-boa ;
-
-: move ( x rect -- rect )
- [ + ] change-x ;
-
-[ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
-
-[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
-
-GENERIC: delegation-test
-M: object delegation-test drop 3 ;
-TUPLE: quux-tuple ;
-: <quux-tuple> quux-tuple construct-empty ;
-M: quux-tuple delegation-test drop 4 ;
-TUPLE: quuux-tuple ;
-: <quuux-tuple> { set-delegate } quuux-tuple construct ;
-
-[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
-
-GENERIC: delegation-test-2
-TUPLE: quux-tuple-2 ;
-: <quux-tuple-2> quux-tuple-2 construct-empty ;
-M: quux-tuple-2 delegation-test-2 drop 4 ;
-TUPLE: quuux-tuple-2 ;
-: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
-
-[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
-
-! Make sure we handle tuple class redefinition
-TUPLE: redefinition-test ;
-
-C: <redefinition-test> redefinition-test
-
-<redefinition-test> "redefinition-test" set
-
-[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
-
-"IN: tuples.tests TUPLE: redefinition-test ;" eval
-
-[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
-
-! Make sure we handle changing shapes!
-TUPLE: point x y ;
-
-C: <point> point
-
-[ ] [ 100 200 <point> "p" set ] unit-test
-
-! Use eval to sequence parsing explicitly
-[ ] [ "IN: tuples.tests TUPLE: point x y z ;" eval ] unit-test
-
-[ 100 ] [ "p" get x>> ] unit-test
-[ 200 ] [ "p" get y>> ] unit-test
-[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
-
-"p" get 300 ">>z" "accessors" lookup execute drop
-
-[ 4 ] [ "p" get tuple-size ] unit-test
-
-[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
-
-"IN: tuples.tests TUPLE: point z y ;" eval
-
-[ 3 ] [ "p" get tuple-size ] unit-test
-
-[ "p" get x>> ] must-fail
-[ 200 ] [ "p" get y>> ] unit-test
-[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
-
-TUPLE: predicate-test ;
-
-C: <predicate-test> predicate-test
-
-: predicate-test drop f ;
-
-[ t ] [ <predicate-test> predicate-test? ] unit-test
-
-PREDICATE: silly-pred < tuple
- class \ rect = ;
-
-GENERIC: area
-M: silly-pred area dup w>> swap h>> * ;
-
-TUPLE: circle radius ;
-M: circle area radius>> sq pi * ;
-
-[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
-
-! Hashcode breakage
-TUPLE: empty ;
-
-C: <empty> empty
-
-[ t ] [ <empty> hashcode fixnum? ] unit-test
-
-TUPLE: delegate-clone ;
-
-[ T{ delegate-clone T{ empty f } } ]
-[ T{ delegate-clone T{ empty f } } clone ] unit-test
-
-! Compiler regression
-[ t length ] [ object>> t eq? ] must-fail-with
-
-[ "<constructor-test>" ]
-[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
-
-TUPLE: size-test a b c d ;
-
-[ t ] [
- T{ size-test } tuple-size
- size-test tuple-size =
-] unit-test
-
-GENERIC: <yo-momma>
-
-TUPLE: yo-momma ;
-
-"IN: tuples.tests C: <yo-momma> yo-momma" eval
-
-[ f ] [ \ <yo-momma> generic? ] unit-test
-
-! Test forget
-[
- [ t ] [ \ yo-momma class? ] unit-test
- [ ] [ \ yo-momma forget ] unit-test
- [ f ] [ \ yo-momma update-map get values memq? ] unit-test
-
- [ f ] [ \ yo-momma crossref get at ] unit-test
-] with-compilation-unit
-
-TUPLE: loc-recording ;
-
-[ f ] [ \ loc-recording where not ] unit-test
-
-! 'forget' wasn't robust enough
-
-TUPLE: forget-robustness ;
-
-GENERIC: forget-robustness-generic
-
-M: forget-robustness forget-robustness-generic ;
-
-M: integer forget-robustness-generic ;
-
-[
- [ ] [ \ forget-robustness-generic forget ] unit-test
- [ ] [ \ forget-robustness forget ] unit-test
- [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test
-] with-compilation-unit
-
-! rapido found this one
-GENERIC# m1 0 ( s n -- n )
-GENERIC# m2 1 ( s n -- v )
-
-TUPLE: t1 ;
-
-M: t1 m1 drop ;
-M: t1 m2 nip ;
-
-TUPLE: t2 ;
-
-M: t2 m1 drop ;
-M: t2 m2 nip ;
-
-TUPLE: t3 ;
-
-M: t3 m1 drop ;
-M: t3 m2 nip ;
-
-TUPLE: t4 ;
-
-M: t4 m1 drop ;
-M: t4 m2 nip ;
-
-C: <t4> t4
-
-[ 1 ] [ 1 <t4> m1 ] unit-test
-[ 1 ] [ <t4> 1 m2 ] unit-test
-
-! another combination issue
-GENERIC: silly
-
-UNION: my-union slice repetition column array vector reversed ;
-
-M: my-union silly "x" ;
-
-M: array silly "y" ;
-
-M: column silly "fdsfds" ;
-
-M: repetition silly "zzz" ;
-
-M: reversed silly "zz" ;
-
-M: slice silly "tt" ;
-
-M: string silly "t" ;
-
-M: vector silly "z" ;
-
-[ "zz" ] [ 123 <reversed> silly nip ] unit-test
-
-! Typo
-SYMBOL: not-a-tuple-class
-
-[
- "IN: tuples.tests C: <not-a-tuple-class> not-a-tuple-class"
- eval
-] must-fail
-
-[ t ] [
- "not-a-tuple-class" "tuples.tests" lookup symbol?
-] unit-test
-
-! Missing check
-[ not-a-tuple-class construct-boa ] must-fail
-[ not-a-tuple-class construct-empty ] must-fail
-
-TUPLE: erg's-reshape-problem a b c d ;
-
-C: <erg's-reshape-problem> erg's-reshape-problem
-
-! We want to make sure constructors are recompiled when
-! tuples are reshaped
-: cons-test-1 \ erg's-reshape-problem construct-empty ;
-: cons-test-2 \ erg's-reshape-problem construct-boa ;
-
-"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
-
-[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
-
-[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
-
-[
- "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ [ no-tuple-class? ] is? ] must-fail-with
-
-! Inheritance
-TUPLE: computer cpu ram ;
-C: <computer> computer
-
-[ "TUPLE: computer cpu ram ;" ] [
- [ \ computer see ] with-string-writer string-lines second
-] unit-test
-
-TUPLE: laptop < computer battery ;
-C: <laptop> laptop
-
-[ t ] [ laptop tuple-class? ] unit-test
-[ t ] [ laptop tuple class< ] unit-test
-[ t ] [ laptop computer class< ] unit-test
-[ t ] [ laptop computer classes-intersect? ] unit-test
-
-[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
-[ t ] [ "laptop" get laptop? ] unit-test
-[ t ] [ "laptop" get computer? ] unit-test
-[ t ] [ "laptop" get tuple? ] unit-test
-
-[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
-[ 128 ] [ "laptop" get ram>> ] unit-test
-[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
-
-[ laptop ] [
- "laptop" get tuple-layout
- dup layout-echelon swap
- layout-superclasses nth
-] unit-test
-
-[ "TUPLE: laptop < computer battery ;" ] [
- [ \ laptop see ] with-string-writer string-lines second
-] unit-test
-
-[ { tuple computer laptop } ] [ laptop superclasses ] unit-test
-
-TUPLE: server < computer rackmount ;
-C: <server> server
-
-[ t ] [ server tuple-class? ] unit-test
-[ t ] [ server tuple class< ] unit-test
-[ t ] [ server computer class< ] unit-test
-[ t ] [ server computer classes-intersect? ] unit-test
-
-[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
-[ t ] [ "server" get server? ] unit-test
-[ t ] [ "server" get computer? ] unit-test
-[ t ] [ "server" get tuple? ] unit-test
-
-[ "PowerPC" ] [ "server" get cpu>> ] unit-test
-[ 64 ] [ "server" get ram>> ] unit-test
-[ "1U" ] [ "server" get rackmount>> ] unit-test
-
-[ f ] [ "server" get laptop? ] unit-test
-[ f ] [ "laptop" get server? ] unit-test
-
-[ f ] [ server laptop class< ] unit-test
-[ f ] [ laptop server class< ] unit-test
-[ f ] [ laptop server classes-intersect? ] unit-test
-
-[ f ] [ 1 2 <computer> laptop? ] unit-test
-[ f ] [ \ + server? ] unit-test
-
-[ "TUPLE: server < computer rackmount ;" ] [
- [ \ server see ] with-string-writer string-lines second
-] unit-test
-
-[
- "IN: tuples.tests TUPLE: bad-superclass < word ;" eval
-] must-fail
-
-! Reshaping with inheritance
-TUPLE: electronic-device ;
-
-[ ] [ "IN: tuples.tests TUPLE: computer < electronic-device ;" eval ] unit-test
-
-[ f ] [ electronic-device laptop class< ] unit-test
-[ t ] [ server electronic-device class< ] unit-test
-[ t ] [ laptop server class-or electronic-device class< ] unit-test
-
-[ t ] [ "laptop" get electronic-device? ] unit-test
-[ t ] [ "laptop" get computer? ] unit-test
-[ t ] [ "laptop" get laptop? ] unit-test
-[ f ] [ "laptop" get server? ] unit-test
-
-[ t ] [ "server" get electronic-device? ] unit-test
-[ t ] [ "server" get computer? ] unit-test
-[ f ] [ "server" get laptop? ] unit-test
-[ t ] [ "server" get server? ] unit-test
-
-[ ] [ "IN: tuples.tests TUPLE: computer ;" eval ] unit-test
-
-[ f ] [ "laptop" get electronic-device? ] unit-test
-[ t ] [ "laptop" get computer? ] unit-test
-
-! Hardcore unit tests
-USE: threads
-
-\ thread slot-names "slot-names" set
-
-[ ] [
- [
- \ thread tuple { "xxx" } "slot-names" get append
- define-tuple-class
- ] with-compilation-unit
-
- [ 1337 sleep ] "Test" spawn drop
-
- [
- \ thread tuple "slot-names" get
- define-tuple-class
- ] with-compilation-unit
-] unit-test
-
-USE: vocabs
-
-\ vocab slot-names "slot-names" set
-
-[ ] [
- [
- \ vocab tuple { "xxx" } "slot-names" get append
- define-tuple-class
- ] with-compilation-unit
-
- all-words drop
-
- [
- \ vocab tuple "slot-names" get
- define-tuple-class
- ] with-compilation-unit
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions hashtables kernel
-kernel.private math namespaces sequences sequences.private
-strings vectors words quotations memory combinators generic
-classes classes.private slots.deprecated slots.private slots
-compiler.units math.private accessors ;
-IN: tuples
-
-M: tuple delegate 2 slot ;
-
-M: tuple set-delegate 2 set-slot ;
-
-M: tuple class 1 slot 2 slot { word } declare ;
-
-ERROR: no-tuple-class class ;
-
-<PRIVATE
-
-GENERIC: tuple-layout ( object -- layout )
-
-M: class tuple-layout "layout" word-prop ;
-
-M: tuple tuple-layout 1 slot ;
-
-: tuple-size tuple-layout layout-size ; inline
-
-PRIVATE>
-
-: check-tuple ( class -- )
- dup tuple-class?
- [ drop ] [ no-tuple-class ] if ;
-
-: tuple>array ( tuple -- array )
- dup tuple-layout
- [ layout-size swap [ array-nth ] curry map ] keep
- layout-class add* ;
-
-: >tuple ( seq -- tuple )
- dup first tuple-layout <tuple> [
- >r 1 tail-slice dup length r>
- [ tuple-size min ] keep
- [ set-array-nth ] curry
- 2each
- ] keep ;
-
-: slot-names ( class -- seq )
- "slots" word-prop [ name>> ] map ;
-
-<PRIVATE
-
-: tuple= ( tuple1 tuple2 -- ? )
- over tuple-layout over tuple-layout eq? [
- dup tuple-size -rot
- [ >r over r> array-nth >r array-nth r> = ] 2curry
- all-integers?
- ] [
- 2drop f
- ] if ;
-
-! Predicate generation. We optimize at the expense of simplicity
-
-: (tuple-predicate-quot) ( class -- quot )
- #! 4 slot == layout-superclasses
- #! 5 slot == layout-echelon
- [
- [ 1 slot dup 5 slot ] %
- dup tuple-layout layout-echelon ,
- [ fixnum>= ] %
- [
- dup tuple-layout layout-echelon ,
- [ swap 4 slot array-nth ] %
- literalize ,
- [ eq? ] %
- ] [ ] make ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
-
-: tuple-predicate-quot ( class -- quot )
- [
- [ dup tuple? ] %
- (tuple-predicate-quot) ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
-
-: define-tuple-predicate ( class -- )
- dup tuple-predicate-quot define-predicate ;
-
-: superclass-size ( class -- n )
- superclasses 1 head-slice*
- [ slot-names length ] map sum ;
-
-: generate-tuple-slots ( class slots -- slots )
- over superclass-size 2 + simple-slots ;
-
-: define-tuple-slots ( class slots -- )
- dupd generate-tuple-slots
- [ "slots" set-word-prop ]
- [ define-accessors ]
- [ define-slots ] 2tri ;
-
-: make-tuple-layout ( class -- layout )
- [ ]
- [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
- [ superclasses dup length 1- ] tri
- <tuple-layout> ;
-
-: define-tuple-layout ( class -- )
- dup make-tuple-layout "layout" set-word-prop ;
-
-: removed-slots ( class newslots -- seq )
- swap slot-names seq-diff ;
-
-: forget-slots ( class slots -- )
- dupd removed-slots [
- [ reader-word forget-method ]
- [ writer-word forget-method ] 2bi
- ] with each ;
-
-: permutation ( seq1 seq2 -- permutation )
- swap [ index ] curry map ;
-
-: reshape-tuple ( oldtuple permutation -- newtuple )
- >r tuple>array 2 cut r>
- [ [ swap ?nth ] [ drop f ] if* ] with map
- append >tuple ;
-
-: reshape-tuples ( class superclass newslots -- )
- nip
- >r dup slot-names r> permutation
- [
- >r "predicate" word-prop instances dup
- r> [ reshape-tuple ] curry map
- become
- ] 2curry after-compilation ;
-
-: define-new-tuple-class ( class superclass slots -- )
- [ drop f tuple-class define-class ]
- [ nip define-tuple-slots ] [
- 2drop
- class-usages [
- drop
- [ define-tuple-layout ]
- [ define-tuple-predicate ]
- bi
- ] assoc-each
- ] 3tri ;
-
-: redefine-tuple-class ( class superclass slots -- )
- [ reshape-tuples ]
- [
- nip
- [ forget-slots ]
- [ drop changed-word ]
- [ drop redefined ]
- 2tri
- ]
- [ define-new-tuple-class ]
- 3tri ;
-
-: tuple-class-unchanged? ( class superclass slots -- ? )
- rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
-
-PRIVATE>
-
-GENERIC# define-tuple-class 2 ( class superclass slots -- )
-
-M: word define-tuple-class
- define-new-tuple-class ;
-
-M: tuple-class define-tuple-class
- 3dup tuple-class-unchanged?
- [ 3dup redefine-tuple-class ] unless
- 3drop ;
-
-: define-error-class ( class superclass slots -- )
- pick >r define-tuple-class r>
- dup [ construct-boa throw ] curry define ;
-
-M: tuple clone
- (clone) dup delegate clone over set-delegate ;
-
-M: tuple equal?
- over tuple? [ tuple= ] [ 2drop f ] if ;
-
-: delegates ( obj -- seq )
- [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
-
-: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
-
-M: tuple hashcode*
- [
- dup tuple-size -rot 0 -rot [
- swapd array-nth hashcode* bitxor
- ] 2curry reduce
- ] recursive-hashcode ;
-
-: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
-
-! Definition protocol
-M: tuple-class reset-class
- { "metaclass" "superclass" "slots" "layout" } reset-props ;
-
-M: object get-slots ( obj slots -- ... )
- [ execute ] with each ;
-
-M: object set-slots ( ... obj slots -- )
- <reversed> get-slots ;
-
-M: object construct-empty ( class -- tuple )
- tuple-layout <tuple> ;
-
-M: object construct ( ... slots class -- tuple )
- construct-empty [ swap set-slots ] keep ;
-
-M: object construct-boa ( ... class -- tuple )
- tuple-layout <tuple-boa> ;
IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
-parser source-files words assocs tuples definitions
+parser source-files words assocs classes.tuple definitions
debugger compiler.units tools.vocabs ;
! This vocab should not exist, but just in case...
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
-vocabs continuations tuples compiler.units io.streams.string ;
+vocabs continuations classes.tuple compiler.units
+io.streams.string ;
IN: words.tests
[ 4 ] [
USING: kernel parser namespaces quotations arrays vectors strings
- sequences assocs tuples math combinators ;
+ sequences assocs classes.tuple math combinators ;
IN: bake
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions namespaces sequences
-strings tuples system vocabs.loader calendar.backend threads
-accessors combinators locals ;
+strings system vocabs.loader calendar.backend threads
+accessors combinators locals classes.tuple ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.syntax help.markup kernel prettyprint sequences ;
+IN: classes.tuple.lib
+
+HELP: >tuple<
+{ $values { "class" "a tuple class" } }
+{ $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." }
+{ $example
+ "USING: kernel prettyprint classes.tuple.lib ;"
+ "TUPLE: foo a b c ;"
+ "1 2 3 \\ foo construct-boa \\ foo >tuple< .s"
+ "1\n2\n3"
+}
+{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
+{ $see-also >tuple*< } ;
+
+HELP: >tuple*<
+{ $values { "class" "a tuple class" } }
+{ $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." }
+{ $example
+ "USING: kernel prettyprint classes.tuple.lib ;"
+ "TUPLE: foo a bb* ccc dddd* ;"
+ "1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s"
+ "2\n4"
+}
+{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
+{ $see-also >tuple< } ;
+
--- /dev/null
+USING: kernel tools.test classes.tuple.lib ;
+IN: classes.tuple.lib.tests
+
+TUPLE: foo a b* c d* e f* ;
+
+[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple< ] unit-test
+[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple*< ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel macros sequences slots words mirrors ;
+IN: classes.tuple.lib
+
+: reader-slots ( seq -- quot )
+ [ slot-spec-reader ] map [ get-slots ] curry ;
+
+MACRO: >tuple< ( class -- )
+ all-slots 1 tail-slice reader-slots ;
+
+MACRO: >tuple*< ( class -- )
+ all-slots
+ [ slot-spec-name "*" tail? ] subset
+ reader-slots ;
+
+
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
-namespaces sequences sequences.lib tuples words strings
+namespaces sequences sequences.lib classes.tuple words strings
tools.walker accessors ;
IN: db
-USING: kernel parser quotations tuples words
+USING: kernel parser quotations classes.tuple words
namespaces.lib namespaces sequences arrays combinators
prettyprint strings math.parser sequences.lib math symbols ;
USE: tools.walker
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
-prettyprint sequences strings tuples alien.c-types
+prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
io namespaces.lib ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
-tuples words sequences slots math
+classes.tuple words sequences slots math
math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ;
IN: db.tuples
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
-mirrors tuples combinators calendar.format symbols
+mirrors classes.tuple combinators calendar.format symbols
singleton ;
IN: db.types
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces sequences definitions io.files
-inspector continuations tuples tools.crossref tools.vocabs
+inspector continuations tools.crossref tools.vocabs
io prettyprint source-files assocs vocabs vocabs.loader
-io.backend splitting ;
+io.backend splitting classes.tuple ;
IN: editors
TUPLE: no-edit-hook ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io kernel namespaces parser prettyprint sequences
words assocs definitions generic quotations effects slots
-continuations tuples debugger combinators vocabs help.stylesheet
-help.topics help.crossref help.markup sorting classes
-vocabs.loader ;
+continuations classes.tuple debugger combinators vocabs
+help.stylesheet help.topics help.crossref help.markup sorting
+classes vocabs.loader ;
IN: help
GENERIC: word-help* ( word -- content )
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: html.elements http.server.validators accessors
-namespaces kernel io math.parser assocs classes words tuples
-arrays sequences io.files http.server.templating.fhtml
-http.server.actions splitting mirrors hashtables
-fry continuations math ;
+USING: html.elements http.server.validators accessors namespaces
+kernel io math.parser assocs classes words classes.tuple arrays
+sequences io.files http.server.templating.fhtml
+http.server.actions splitting mirrors hashtables fry
+continuations math ;
IN: http.server.components
SYMBOL: components
USING: kernel words inspector slots quotations sequences assocs
math arrays inference effects shuffle continuations debugger
-tuples namespaces vectors bit-arrays byte-arrays strings sbufs
-math.functions macros sequences.private combinators mirrors ;
+classes.tuple namespaces vectors bit-arrays byte-arrays strings
+sbufs math.functions macros sequences.private combinators
+mirrors ;
IN: inverse
TUPLE: fail ;
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: math.parser arrays io.encodings sequences kernel assocs
-hashtables io.encodings.ascii generic parser tuples words io
-io.files splitting namespaces math compiler.units accessors ;
+hashtables io.encodings.ascii generic parser classes.tuple words
+io io.files splitting namespaces math compiler.units accessors ;
IN: io.encodings.8-bit
<PRIVATE
{ $values { "port" input-port } { "quot" "a quotation with stack effect " { $snippet "( port -- value )" } } { "value" object } }
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
-HELP: read-until-step
-{ $values { "separators" "a sequence of bytes" } { "port" input-port } { "byte-array/f" "a byte array or " { $link f } } { "separator/f" "a byte or " { $link f } } }
-{ $description "If the port has reached end of file, outputs " { $link f } { $link f } ", otherwise scans the buffer for a separator and outputs a string up to but not including the separator." } ;
-
-HELP: read-until-loop
-{ $values { "seps" "a sequence of bytes" } { "port" input-port } { "accum" byte-vector } { "separator/f" "a byte or " { $link f } } }
-{ $description "Accumulates data in the byte vector, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ;
-
HELP: can-write?
{ $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } }
{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;
USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.nonblocking
io.windows libc kernel math namespaces sequences
-threads tuples.lib windows windows.errors
+threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii
combinators.lib ;
QUALIFIED: windows.winsock
continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
-threads tuples.lib ;
+threads classes.tuple.lib ;
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.streams.string io strings splitting sequences math
- math.parser assocs tuples classes words namespaces
+ math.parser assocs classes.tuple classes words namespaces
hashtables ;
IN: json.writer
! See http://factorcode.org/license.txt for BSD license.
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
-USING: parser kernel words namespaces sequences tuples
+USING: parser kernel words namespaces sequences classes.tuple
combinators macros assocs math ;
IN: match
-USING: help.syntax help.markup kernel math classes tuples
+USING: help.syntax help.markup kernel math classes classes.tuple
calendar ;
IN: models
! See http://factorcode.org/license.txt for BSD license.
!
USING: namespaces sequences kernel math io math.functions
-io.binary strings classes words sbufs tuples arrays vectors
-byte-arrays bit-arrays quotations hashtables assocs help.syntax
-help.markup float-arrays splitting io.streams.byte-array
-io.encodings.string io.encodings.utf8 io.encodings.binary
-combinators accessors locals prettyprint compiler.units
-sequences.private tuples.private ;
+io.binary strings classes words sbufs classes.tuple arrays
+vectors byte-arrays bit-arrays quotations hashtables assocs
+help.syntax help.markup float-arrays splitting
+io.streams.byte-array io.encodings.string io.encodings.utf8
+io.encodings.binary combinators accessors locals prettyprint
+compiler.units sequences.private classes.tuple.private ;
IN: serialize
! Variable holding a assoc of objects already serialized
IN: tools.disassembler.tests\r
-USING: math tuples prettyprint.backend tools.disassembler\r
+USING: math classes.tuple prettyprint.backend tools.disassembler\r
tools.test strings ;\r
\r
[ ] [ \ + disassemble ] unit-test\r
! Copyright (C) 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: splitting tuples classes math kernel sequences arrays ;
+USING: splitting classes.tuple classes math kernel sequences
+arrays ;
IN: tuple-arrays
TUPLE: tuple-array example ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: help.syntax help.markup kernel prettyprint sequences ;
-IN: tuples.lib
-
-HELP: >tuple<
-{ $values { "class" "a tuple class" } }
-{ $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." }
-{ $example
- "USING: kernel prettyprint tuples.lib ;"
- "TUPLE: foo a b c ;"
- "1 2 3 \\ foo construct-boa \\ foo >tuple< .s"
- "1\n2\n3"
-}
-{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
-{ $see-also >tuple*< } ;
-
-HELP: >tuple*<
-{ $values { "class" "a tuple class" } }
-{ $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." }
-{ $example
- "USING: kernel prettyprint tuples.lib ;"
- "TUPLE: foo a bb* ccc dddd* ;"
- "1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s"
- "2\n4"
-}
-{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
-{ $see-also >tuple< } ;
-
+++ /dev/null
-USING: kernel tools.test tuples.lib ;
-IN: tuples.lib.tests
-
-TUPLE: foo a b* c d* e f* ;
-
-[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple< ] unit-test
-[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple*< ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel macros sequences slots words mirrors ;
-IN: tuples.lib
-
-: reader-slots ( seq -- quot )
- [ slot-spec-reader ] map [ get-slots ] curry ;
-
-MACRO: >tuple< ( class -- )
- all-slots 1 tail-slice reader-slots ;
-
-MACRO: >tuple*< ( class -- )
- all-slots
- [ slot-spec-name "*" tail? ] subset
- reader-slots ;
-
-
ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render kernel math models namespaces sequences strings
-quotations assocs combinators classes colors tuples opengl
-math.vectors ;
+quotations assocs combinators classes colors classes.tuple
+opengl math.vectors ;
IN: ui.gadgets.buttons
TUPLE: button pressed? selected? quot ;
! See http://factorcode.org/license.txt for BSD license.
USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib
ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
-tuples colors ;
+classes.tuple colors ;
IN: ui.gadgets.canvas
TUPLE: canvas dlist ;
USING: help.syntax help.markup ui.gadgets kernel arrays
-quotations tuples ui.gadgets.grids ;
+quotations classes.tuple ui.gadgets.grids ;
IN: ui.gadgets.frames
: $ui-frame-constant ( element -- )
USING: help.markup help.syntax opengl kernel strings
-tuples classes quotations models ;
+classes.tuple classes quotations models ;
IN: ui.gadgets
HELP: rect
ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
ui.gadgets.grids io kernel math models namespaces prettyprint
-sequences sequences words tuples ui.gadgets ui.render colors ;
+sequences sequences words classes.tuple ui.gadgets ui.render
+colors ;
IN: ui.gadgets.labelled
TUPLE: labelled-gadget content ;
ui.gadgets.labels ui.gadgets.scrollers
kernel sequences models opengl math namespaces
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
-math.vectors tuples ;
+math.vectors classes.tuple ;
IN: ui.gadgets.lists
TUPLE: list index presenter color hook ;
-USING: ui.gadgets help.markup help.syntax generic kernel tuples
-quotations ;
+USING: ui.gadgets help.markup help.syntax generic kernel
+classes.tuple quotations ;
IN: ui.gadgets.packs
HELP: pack
quotations math opengl combinators math.vectors
io.streams.duplex sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
-ui.gadgets.grid-lines tuples models continuations ;
+ui.gadgets.grid-lines classes.tuple models continuations ;
IN: ui.gadgets.panes
TUPLE: pane output current prototype scrolls?
IN: ui.gadgets.presentations.tests
USING: math ui.gadgets.presentations ui.gadgets tools.test
prettyprint ui.gadgets.buttons io io.streams.string kernel
-tuples ;
+classes.tuple ;
[ t ] [
"Hi" \ + <presentation> [ gadget? ] is?
ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids
ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math
namespaces sequences models combinators math.vectors
-tuples ;
+classes.tuple ;
IN: ui.gadgets.scrollers
TUPLE: scroller viewport x y follows ;
USING: ui.gadgets.packs help.markup help.syntax ui.gadgets
-arrays kernel quotations tuples ;
+arrays kernel quotations classes.tuple ;
IN: ui.gadgets.tracks
HELP: track
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
-math.vectors tuples classes ui.gadgets combinators.lib boxes
+math.vectors classes.tuple classes ui.gadgets combinators.lib
+boxes
calendar alarms symbols ;
IN: ui.gestures
hashtables io io.styles kernel math
math.vectors models namespaces parser prettyprint quotations
sequences sequences.lib strings threads listener
-tuples ui.commands ui.gadgets ui.gadgets.editors
+classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions boxes calendar concurrency.flags ui.tools.workspace ;
IN: ui.tools.interactor
ui.tools.workspace help help.topics io.files io.styles kernel
models namespaces prettyprint quotations sequences sorting
source-files definitions strings tools.completion tools.crossref
-tuples ui.commands ui.gadgets ui.gadgets.editors
+classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
tools.vocabs unicode.case calendar ui ;
namespaces opengl sequences strings x11.xlib x11.events x11.xim
x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
io.encodings.utf8 combinators debugger system command-line
-ui.render math.vectors tuples opengl.gl threads ;
+ui.render math.vectors classes.tuple opengl.gl threads ;
IN: ui.x11
TUPLE: x11-ui-backend ;
projects / factor.git / commitdiff