Working on call-next-method, and identity-tuple

core/bootstrap/compiler/compiler.factor

@@ -16,12 +16,6 @@ IN: bootstrap.compiler
 
 "cpu." cpu append require
 
-: enable-compiler ( -- )
-    [ optimized-recompile-hook ] recompile-hook set-global ;
-
-: disable-compiler ( -- )
-    [ default-recompile-hook ] recompile-hook set-global ;
-
 enable-compiler
 
 nl

core/bootstrap/image/image.factor

@@ -444,7 +444,6 @@ PRIVATE>
         "resource:/core/bootstrap/stage1.factor" run-file
         build-image
         write-image
-        \ word-props target-word
     ] with-scope ;
 
 : make-images ( -- )

core/bootstrap/primitives.factor

@@ -159,17 +159,24 @@ num-types get f <array> builtins set
 "tuple-layout" "classes.tuple.private" create register-builtin
 
 ! Catch-all class for providing a default method.
-"object" "kernel" create [ drop t ] "predicate" set-word-prop
 "object" "kernel" create
-f builtins get [ ] subset union-class define-class
+[ f builtins get [ ] subset union-class define-class ]
+[ [ drop t ] "predicate" set-word-prop ]
+bi
+
+"object?" "kernel" vocab-words delete-at
 
 ! Class of objects with object tag
 "hi-tag" "kernel.private" create
-f builtins get num-tags get tail union-class define-class
+builtins get num-tags get tail define-union-class
 
 ! Empty class with no instances
-"null" "kernel" create [ drop f ] "predicate" set-word-prop
+"null" "kernel" create
-"null" "kernel" create f { } union-class define-class
+[ f { } union-class define-class ]
+[ [ drop f ] "predicate" set-word-prop ]
+bi
+
+"null?" "kernel" vocab-words delete-at
 
 "fixnum" "math" create { } define-builtin
 "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@@ -378,17 +385,9 @@ define-builtin
     ]
 } cleave
 
-! Define general-t type, which is any object that is not f.
-"general-t" "kernel" create
-f "f" "syntax" lookup builtins get remove [ ] subset union-class
-define-class
-
 "f" "syntax" create [ not ] "predicate" set-word-prop
 "f?" "syntax" vocab-words delete-at
 
-"general-t" "kernel" create [ ] "predicate" set-word-prop
-"general-t?" "kernel" vocab-words delete-at
-
 ! Create special tombstone values
 "tombstone" "hashtables.private" create
 "tuple" "kernel" lookup

core/bootstrap/syntax.factor

@@ -66,6 +66,7 @@ IN: bootstrap.syntax
     "CS{"
     "<<"
     ">>"
+    "call-next-method"
 } [ "syntax" create drop ] each
 
 "t" "syntax" lookup define-symbol

core/classes/algebra/algebra-tests.factor

@@ -23,8 +23,8 @@ random inference effects kernel.private ;
 [ t ] [ number    object   number class-and* ] unit-test
 [ t ] [ object    number   number class-and* ] unit-test
 [ t ] [ slice     reversed null   class-and* ] unit-test
-[ t ] [ general-t \ f      null   class-and* ] unit-test
+[ t ] [ \ f class-not \ f      null   class-and* ] unit-test
-[ t ] [ general-t \ f      object class-or*  ] unit-test
+[ t ] [ \ f class-not \ f      object class-or*  ] unit-test
 
 TUPLE: first-one ;
 TUPLE: second-one ;

core/classes/classes-docs.factor

@@ -21,7 +21,6 @@ $nl
     { { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } }
     { { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } }
     { { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } }
-    { { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } }
 }
 "The set of class predicate words is a class:"
 { $subsection predicate }

core/classes/classes-tests.factor

@@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
 classes.algebra vectors definitions source-files
-compiler.units ;
+compiler.units kernel.private ;
 IN: classes.tests
 
 ! DEFER: bah
@@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 ! Test generic see and parsing
 [ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
 [ [ \ bah see ] with-string-writer ] unit-test
+
+[ t ] [ 3 object instance? ] unit-test
+[ t ] [ 3 fixnum instance? ] unit-test
+[ f ] [ 3 float instance? ] unit-test
+[ t ] [ 3 number instance? ] unit-test
+[ f ] [ 3 null instance? ] unit-test
+[ t ] [ "hi" \ hi-tag instance? ] unit-test

core/classes/classes.factor

@@ -60,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     dup class? [ "superclass" word-prop ] [ drop f ] if ;
 
 : superclasses ( class -- supers )
-    [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ;
+    [ superclass ] follow reverse ;
 
 : members ( class -- seq )
     #! Output f for non-classes to work with algebra code
@@ -133,3 +133,6 @@ GENERIC: class ( object -- class )
 M: hi-tag class hi-tag type>class ;
 
 M: object class tag type>class ;
+
+: instance? ( obj class -- ? )
+    "predicate" word-prop call ;

core/classes/tuple/tuple-docs.factor

@@ -153,14 +153,6 @@ HELP: tuple=
 { $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: 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-removed-slots
-{ $values { "class" tuple-class } { "slots" "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

core/classes/tuple/tuple-tests.factor

@@ -511,3 +511,34 @@ USE: vocabs
         define-tuple-class
     ] with-compilation-unit
 ] unit-test
+
+[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with
+
+! Accessors not being forgotten...
+[ [ ] ] [
+    "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
+    <string-reader>
+    "forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+: accessor-exists? ( class name -- ? )
+    >r "forget-accessors-test" "classes.tuple.tests" lookup r>
+    ">>" append "accessors" lookup method >boolean ;
+
+[ t ] [ "x" accessor-exists? ] unit-test
+[ t ] [ "y" accessor-exists? ] unit-test
+[ t ] [ "z" accessor-exists? ] unit-test
+
+[ [ ] ] [
+    "IN: classes.tuple.tests GENERIC: forget-accessors-test"
+    <string-reader>
+    "forget-accessors-test" parse-stream
+] unit-test
+
+[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+[ f ] [ "x" accessor-exists? ] unit-test
+[ f ] [ "y" accessor-exists? ] unit-test
+[ f ] [ "z" accessor-exists? ] unit-test

core/classes/tuple/tuple.factor

@@ -19,7 +19,7 @@ ERROR: no-tuple-class class ;
 
 GENERIC: tuple-layout ( object -- layout )
 
-M: class tuple-layout "layout" word-prop ;
+M: tuple-class tuple-layout "layout" word-prop ;
 
 M: tuple tuple-layout 1 slot ;
 
@@ -40,7 +40,9 @@ PRIVATE>
     [ drop ] [ no-tuple-class ] if ;
 
 : tuple>array ( tuple -- array )
-    prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ;
+    prepare-tuple>array
+    >r copy-tuple-slots r>
+    layout-class prefix ;
 
 : tuple-slots ( tuple -- array )
     prepare-tuple>array drop copy-tuple-slots ;
@@ -120,15 +122,6 @@ PRIVATE>
 : define-tuple-layout ( class -- )
     dup make-tuple-layout "layout" set-word-prop ;
 
-: removed-slots ( class newslots -- seq )
-    swap slot-names seq-diff ;
-
-: forget-removed-slots ( class slots -- )
-    dupd removed-slots [
-        [ reader-word forget-method ]
-        [ writer-word forget-method ] 2bi
-    ] with each ;
-
 : all-slot-names ( class -- slots )
     superclasses [ slot-names ] map concat \ class prefix ;
 
@@ -189,9 +182,8 @@ M: tuple-class update-class
             tri
         ] each-subclass
     ]
-    [ nip forget-removed-slots ]
     [ define-new-tuple-class ]
-    3tri ;
+    3bi ;
 
 : tuple-class-unchanged? ( class superclass slots -- ? )
     rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
@@ -213,7 +205,19 @@ M: tuple-class define-tuple-class
     dup [ construct-boa throw ] curry define ;
 
 M: tuple-class reset-class
-    { "metaclass" "superclass" "slots" "layout" } reset-props ;
+    [
+        dup "slot-names" word-prop [
+            [ reader-word forget-method ]
+            [ writer-word forget-method ] 2bi
+        ] with each
+    ] [
+        {
+            "metaclass"
+            "superclass"
+            "layout"
+            "slots"
+        } reset-props
+    ] bi ;
 
 M: tuple clone
     (clone) dup delegate clone over set-delegate ;
@@ -228,12 +232,6 @@ M: tuple hashcode*
         ] 2curry reduce
     ] recursive-hashcode ;
 
-M: object construct-empty ( class -- tuple )
-    tuple-layout <tuple> ;
-
-M: object construct-boa ( ... class -- tuple )
-    tuple-layout <tuple-boa> ;
-
 ! Deprecated
 M: object get-slots ( obj slots -- ... )
     [ execute ] with each ;
@@ -241,10 +239,6 @@ M: object get-slots ( obj slots -- ... )
 M: object set-slots ( ... obj slots -- )
     <reversed> get-slots ;
 
-M: object construct ( ... slots class -- tuple )
+: delegates ( obj -- seq ) [ delegate ] follow ;
-    construct-empty [ swap set-slots ] keep ;
-
-: delegates ( obj -- seq )
-    [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
 
 : is? ( obj quot -- ? ) >r delegates r> contains? ; inline

core/compiler/compiler-docs.factor

@@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser
 assocs words.private sequences compiler.units ;
 IN: compiler
 
+HELP: enable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
+HELP: disable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
 ARTICLE: "compiler-usage" "Calling the optimizing compiler"
-"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
+"Normally, new word definitions are recompiled automatically. This can be changed:"
-$nl
+{ $subsection disable-compiler }
-"The main entry point to the optimizing compiler:"
+{ $subsection enable-compiler }
+"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
 { $subsection optimized-recompile-hook }
 "Removing a word's optimized definition:"
 { $subsection decompile }
-"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ;
+"Higher-level words can be found in " { $link "compilation-units" } "." ;
 
 ARTICLE: "compiler" "Optimizing compiler"
 "Factor is a fully compiled language implementation with two distinct compilers:"

core/compiler/compiler.factor

@@ -56,5 +56,11 @@ IN: compiler
         compiled get >alist
     ] with-scope ;
 
+: enable-compiler ( -- )
+    [ optimized-recompile-hook ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+    [ default-recompile-hook ] recompile-hook set-global ;
+
 : recompile-all ( -- )
     forget-errors all-words compile ;

core/definitions/definitions-tests.factor

@@ -4,7 +4,7 @@ compiler.units words ;
 
 TUPLE: combination-1 ;
 
-M: combination-1 perform-combination 2drop [ ] ;
+M: combination-1 perform-combination drop [ ] define ;
 
 M: combination-1 make-default-method 2drop [ "No method" throw ] ;
 

core/generic/generic-tests.factor

@@ -21,19 +21,6 @@ M: word   class-of drop "word"   ;
 [ "Hello world" ] [ 4 foobar foobar ] unit-test
 [ "Goodbye cruel world" ] [ 4 foobar ] unit-test
 
-GENERIC: bool>str ( x -- y )
-M: general-t bool>str drop "true" ;
-M: f bool>str drop "false" ;
-
-: str>bool
-    H{
-        { "true" t }
-        { "false" f }
-    } at ;
-
-[ t ] [ t bool>str str>bool ] unit-test
-[ f ] [ f bool>str str>bool ] unit-test
-
 ! Testing unions
 UNION: funnies quotation float complex ;
 
@@ -51,16 +38,6 @@ M: very-funny gooey sq ;
 
 [ 0.25 ] [ 0.5 gooey ] unit-test
 
-DEFER: complement-test
-FORGET: complement-test
-GENERIC: complement-test ( x -- y )
-
-M: f         complement-test drop "f" ;
-M: general-t complement-test drop "general-t" ;
-
-[ "general-t" ] [ 5 complement-test ] unit-test
-[ "f" ] [ f complement-test ] unit-test
-
 GENERIC: empty-method-test ( x -- y )
 M: object empty-method-test ;
 TUPLE: for-arguments-sake ;

core/generic/generic.factor

@@ -6,16 +6,7 @@ classes.algebra quotations arrays vocabs effects ;
 IN: generic
 
 ! Method combination protocol
-GENERIC: perform-combination ( word combination -- quot )
+GENERIC: perform-combination ( word combination -- )
-
-M: object perform-combination
-    #! We delay the invalid method combination error for a
-    #! reason. If we call forget-vocab on a vocabulary which
-    #! defines a method combination, a generic using this
-    #! method combination, and a method on the generic, and the
-    #! method combination is forgotten first, then forgetting
-    #! the method will throw an error. We don't want that.
-    nip [ "Invalid method combination" throw ] curry [ ] like ;
 
 GENERIC: make-default-method ( generic combination -- method )
 
@@ -38,6 +29,18 @@ PREDICATE: method-spec < pair
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
+: next-method-class ( class generic -- class/f )
+    order [ class< ] with subset reverse dup length 1 =
+    [ drop f ] [ second ] if ;
+
+: next-method ( class generic -- class/f )
+    [ next-method-class ] keep method ;
+
+GENERIC: next-method-quot ( class generic -- quot )
+
+: (call-next-method) ( class generic -- )
+    next-method-quot call ;
+
 TUPLE: check-method class generic ;
 
 : check-method ( class generic -- class generic )

core/generic/math/math.factor

@@ -12,9 +12,9 @@ PREDICATE: math-class < class
         number bootstrap-word class<
     ] if ;
 
-: last/first ( seq -- pair ) dup peek swap first 2array ;
+: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
 
-: math-precedence ( class -- n )
+: math-precedence ( class -- pair )
     {
         { [ dup null class< ] [ drop { -1 -1 } ] }
         { [ dup math-class? ] [ class-types last/first ] }

core/generic/standard/engines/tuple/tuple.factor

@@ -15,7 +15,7 @@ C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
 TUPLE: tuple-dispatch-engine echelons ;
 
 : push-echelon ( class method assoc -- )
-    >r swap dup tuple-layout layout-echelon r>
+    >r swap dup "layout" word-prop layout-echelon r>
     [ ?set-at ] change-at ;
 
 : echelon-sort ( assoc -- assoc' )

core/generic/standard/standard.factor

@@ -8,6 +8,10 @@ generic.standard.engines.tag generic.standard.engines.predicate
 generic.standard.engines.tuple accessors ;
 IN: generic.standard
 
+GENERIC: dispatch# ( word -- n )
+
+M: word dispatch# "combination" word-prop dispatch# ;
+
 : unpickers
     {
         [ nip ]
@@ -101,7 +105,7 @@ PREDICATE: simple-generic < standard-generic
     T{ standard-combination f 0 } define-generic ;
 
 : with-standard ( combination quot -- quot' )
-    >r #>> (dispatch#) r> with-variable ;
+    >r #>> (dispatch#) r> with-variable ; inline
 
 M: standard-generic mangle-method
     drop 1quotation ;
@@ -112,6 +116,27 @@ M: standard-combination make-default-method
 M: standard-combination perform-combination
     [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
 
+M: standard-combination dispatch# #>> ;
+
+ERROR: inconsistent-next-method object class generic ;
+
+ERROR: no-next-method class generic ;
+
+M: standard-generic next-method-quot
+    [
+        [
+            [ [ instance? ] curry ]
+            [ dispatch# (picker) ] bi* prepend %
+        ]
+        [
+            2dup next-method
+            [ 2nip 1quotation ]
+            [ [ no-next-method ] 2curry ] if* ,
+        ]
+        [ [ inconsistent-next-method ] 2curry , ]
+        2tri
+    ] [ ] make ;
+
 TUPLE: hook-combination var ;
 
 C: <hook-combination> hook-combination
@@ -124,6 +149,8 @@ PREDICATE: hook-generic < generic
         dip var>> [ get ] curry prepend
     ] with-variable ; inline
 
+M: hook-combination dispatch# drop 0 ;
+
 M: hook-generic mangle-method
     drop 1quotation [ drop ] prepend ;
 
@@ -133,14 +160,6 @@ M: hook-combination make-default-method
 M: hook-combination perform-combination
     [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
 
-GENERIC: dispatch# ( word -- n )
-
-M: word dispatch# "combination" word-prop dispatch# ;
-
-M: standard-combination dispatch# #>> ;
-
-M: hook-combination dispatch# drop 0 ;
-
 M: simple-generic definer drop \ GENERIC: f ;
 
 M: standard-generic definer drop \ GENERIC# f ;

core/inference/class/class-tests.factor

@@ -21,7 +21,7 @@ GENERIC: mynot ( x -- y )
 
 M: f mynot drop t ;
 
-M: general-t mynot drop f ;
+M: object mynot drop f ;
 
 GENERIC: detect-f ( x -- y )
 
@@ -297,3 +297,15 @@ cell-bits 32 = [
 [ t ] [
     [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
 ] unit-test
+
+[ t ] [
+    [
+        dup integer? [
+            dup fixnum? [
+                1 +
+            ] [
+                2 +
+            ] if
+        ] when
+    ] \ + inlined?
+] unit-test

core/inference/class/class.factor

@@ -176,9 +176,18 @@ M: pair constraint-satisfied?
 
 : predicate-constraints ( class #call -- )
     [
-        0 `input class,
+        ! If word outputs true, input is an instance of class
-        general-t 0 `output class,
+        [
-    ] set-constraints ;
+            0 `input class,
+            \ f class-not 0 `output class,
+        ] set-constraints
+    ] [
+        ! If word outputs false, input is not an instance of class
+        [
+            class-not 0 `input class,
+            \ f 0 `output class,
+        ] set-constraints
+    ] 2bi ;
 
 : compute-constraints ( #call -- )
     dup node-param "constraints" word-prop [
@@ -209,7 +218,7 @@ M: #push infer-classes-before
 
 M: #if child-constraints
     [
-        general-t 0 `input class,
+        \ f class-not 0 `input class,
         f 0 `input literal,
     ] make-constraints ;
 

core/inference/dataflow/dataflow.factor

@@ -9,15 +9,13 @@ IN: inference.dataflow
 : <computed> \ <computed> counter ;
 
 ! Literal value
-TUPLE: value literal uid recursion ;
+TUPLE: value < identity-tuple literal uid recursion ;
 
 : <value> ( obj -- value )
     <computed> recursive-state get value construct-boa ;
 
 M: value hashcode* nip value-uid ;
 
-M: value equal? 2drop f ;
-
 ! Result of curry
 TUPLE: curried obj quot ;
 
@@ -30,13 +28,12 @@ C: <composed> composed
 
 UNION: special curried composed ;
 
-TUPLE: node param
+TUPLE: node < identity-tuple
+param
 in-d out-d in-r out-r
 classes literals intervals
 history successor children ;
 
-M: node equal? 2drop f ;
-
 M: node hashcode* drop node hashcode* ;
 
 GENERIC: flatten-curry ( value -- )

core/inference/transforms/transforms-tests.factor

@@ -1,6 +1,7 @@
 IN: inference.transforms.tests
 USING: sequences inference.transforms tools.test math kernel
-quotations inference accessors combinators words arrays ;
+quotations inference accessors combinators words arrays
+classes ;
 
 : compose-n-quot <repetition> >quotation ;
 : compose-n compose-n-quot call ;
@@ -56,3 +57,5 @@ C: <color> color
 [ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
 
 [ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
+
+[ fixnum instance? ] must-infer

core/inference/transforms/transforms.factor

@@ -3,7 +3,7 @@
 USING: arrays kernel words sequences generic math namespaces
 quotations assocs combinators math.bitfields inference.backend
 inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables ;
+inspector hashtables classes generic ;
 IN: inference.transforms
 
 : pop-literals ( n -- rstate seq )
@@ -98,3 +98,11 @@ M: duplicated-slots-error summary
         \ construct-empty 1 1 <effect> make-call-node
     ] if
 ] "infer" set-word-prop
+
+\ instance? [
+    [ +inlined+ depends-on ] [ "predicate" word-prop ] bi
+] 1 define-transform
+
+\ (call-next-method) [
+    [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform

core/kernel/kernel-docs.factor

@@ -250,8 +250,9 @@ $nl
 { $subsection eq? }
 "Value comparison:"
 { $subsection = }
-"Generic words for custom value comparison methods:"
+"Custom value comparison methods:"
 { $subsection equal? }
+{ $subsection identity-tuple }
 "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
 { $subsection <=> }
 { $subsection compare }
@@ -377,10 +378,13 @@ HELP: equal?
     }
     $nl
     "If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word."
-}
+} ;
+
+HELP: identity-tuple
+{ $class-description "A class defining an " { $link equal? } " method which always returns f." }
 { $examples
-    "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
+    "To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
-    { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" }
+    { $code "TUPLE: foo < identity-tuple ;" }
     "By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:"
     { $unchecked-example "T{ foo } dup = ." "t" }
     { $unchecked-example "T{ foo } dup clone = ." "f" }
@@ -665,6 +669,11 @@ HELP: bi@
         "[ p ] bi@"
         ">r p r> p"
     }
+    "The following two lines are also equivalent:"
+    { $code
+        "[ p ] bi@"
+        "[ p ] [ p ] bi*"
+    }
 } ;
 
 HELP: 2bi@
@@ -676,6 +685,11 @@ HELP: 2bi@
         "[ p ] 2bi@"
         ">r >r p r> r> p"
     }
+    "The following two lines are also equivalent:"
+    { $code
+        "[ p ] 2bi@"
+        "[ p ] [ p ] 2bi*"
+    }
 } ;
 
 HELP: tri@
@@ -687,6 +701,11 @@ HELP: tri@
         "[ p ] tri@"
         ">r >r p r> p r> p"
     }
+    "The following two lines are also equivalent:"
+    { $code
+        "[ p ] tri@"
+        "[ p ] [ p ] [ p ] tri*"
+    }
 } ;
 
 HELP: if ( cond true false -- )
@@ -785,19 +804,6 @@ HELP: null
     "The canonical empty class with no instances."
 } ;
 
-HELP: general-t
-{ $class-description
-    "The class of all objects not equal to " { $link f } "."
-}
-{ $examples
-    "Here is an implementation of " { $link if } " using generic words:"
-    { $code
-        "GENERIC# my-if 2 ( ? true false -- )"
-        "M: f my-if 2nip call ;"
-        "M: general-t my-if drop nip call ;"
-    }
-} ;
-
 HELP: most
 { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
 { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;

core/kernel/kernel.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel.private slots.private ;
+USING: kernel.private slots.private classes.tuple.private ;
 IN: kernel
 
 ! Stack stuff
@@ -114,12 +114,6 @@ DEFER: if
     [ 2nip call ] if ; inline
 
 ! Object protocol
-GENERIC: delegate ( obj -- delegate )
-
-M: object delegate drop f ;
-
-GENERIC: set-delegate ( delegate tuple -- )
-
 GENERIC: hashcode* ( depth obj -- code )
 
 M: object hashcode* 2drop 0 ;
@@ -130,6 +124,10 @@ GENERIC: equal? ( obj1 obj2 -- ? )
 
 M: object equal? 2drop f ;
 
+TUPLE: identity-tuple ;
+
+M: identity-tuple equal? 2drop f ;
+
 : = ( obj1 obj2 -- ? )
     2dup eq? [ 2drop t ] [ equal? ] if ; inline
 
@@ -142,18 +140,11 @@ M: object clone ;
 M: callstack clone (clone) ;
 
 ! Tuple construction
-GENERIC# get-slots 1 ( tuple slots -- ... )
+: construct-empty ( class -- tuple )
+    tuple-layout <tuple> ;
 
-GENERIC# set-slots 1 ( ... tuple slots -- )
+: construct-boa ( ... class -- tuple )
-
+    tuple-layout <tuple-boa> ;
-GENERIC: construct-empty ( class -- tuple )
-
-GENERIC: construct ( ... slots class -- tuple ) inline
-
-GENERIC: construct-boa ( ... class -- tuple )
-
-: construct-delegate ( delegate class -- tuple )
-    >r { set-delegate } r> construct ; inline
 
 ! Quotation building
 : 2curry ( obj1 obj2 quot -- curry )
@@ -201,3 +192,20 @@ GENERIC: construct-boa ( ... class -- tuple )
 : do-primitive ( number -- ) "Improper primitive call" throw ;
 
 PRIVATE>
+
+! Deprecated
+GENERIC: delegate ( obj -- delegate )
+
+M: object delegate drop f ;
+
+GENERIC: set-delegate ( delegate tuple -- )
+
+GENERIC# get-slots 1 ( tuple slots -- ... )
+
+GENERIC# set-slots 1 ( ... tuple slots -- )
+
+: construct ( ... slots class -- tuple )
+    construct-empty [ swap set-slots ] keep ; inline
+
+: construct-delegate ( delegate class -- tuple )
+    >r { set-delegate } r> construct ; inline

core/optimizer/control/control.factor

@@ -154,7 +154,7 @@ SYMBOL: potential-loops
     ] [
         node-class {
             { [ dup null class< ] [ drop f f ] }
-            { [ dup general-t class< ] [ drop t t ] }
+            { [ dup \ f class-not class< ] [ drop t t ] }
             { [ dup \ f class< ] [ drop f t ] }
             { [ t ] [ drop f f ] }
         } cond

core/optimizer/inlining/inlining.factor

@@ -70,12 +70,20 @@ DEFER: (flat-length)
     ] if ;
 
 ! Partial dispatch of math-generic words
+: normalize-math-class ( class -- class' )
+    { fixnum bignum ratio float complex }
+    [ class< ] with find nip object or ;
+
 : math-both-known? ( word left right -- ? )
     math-class-max swap specific-method ;
 
 : inline-math-method ( #call word -- node )
-    over node-input-classes first2 3dup math-both-known?
+    over node-input-classes
-    [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
+    [ first normalize-math-class ]
+    [ second normalize-math-class ] bi
+    3dup math-both-known?
+    [ math-method f splice-quot ]
+    [ 2drop 2drop t ] if ;
 
 : inline-method ( #call -- node )
     dup node-param {

core/optimizer/known-words/known-words.factor

@@ -75,7 +75,7 @@ sequences.private combinators ;
     dup node-in-d second dup value? [
         swap [
             value-literal 0 `input literal,
-            general-t 0 `output class,
+            \ f class-not 0 `output class,
         ] set-constraints
     ] [
         2drop

core/optimizer/math/math.factor

@@ -269,7 +269,7 @@ generic.standard system ;
 : comparison-constraints ( node true false -- )
     >r >r dup node set intervals dup [
         2dup
-        r> general-t (comparison-constraints)
+        r> \ f class-not (comparison-constraints)
         r> \ f (comparison-constraints)
     ] [
         r> r> 2drop 2drop

core/parser/parser.factor

@@ -365,7 +365,17 @@ ERROR: bad-number ;
 
 : (:) CREATE-WORD parse-definition ;
 
-: (M:) CREATE-METHOD parse-definition ;
+SYMBOL: current-class
+SYMBOL: current-generic
+
+: (M:)
+    CREATE-METHOD
+    [
+        [ "method-class" word-prop current-class set ]
+        [ "method-generic" word-prop current-generic set ]
+        [ ] tri
+        parse-definition
+    ] with-scope ;
 
 : scan-object ( -- object )
     scan-word dup parsing?

core/prettyprint/prettyprint-tests.factor

@@ -57,8 +57,6 @@ unit-test
 
 [ ] [ \ integer see ] unit-test
 
-[ ] [ \ general-t see ] unit-test
-
 [ ] [ \ generic see ] unit-test
 
 [ ] [ \ duplex-stream see ] unit-test

core/sequences/sequences.factor

@@ -416,6 +416,9 @@ PRIVATE>
         swap >r [ push ] curry compose r> while
     ] keep { } like ; inline
 
+: follow ( obj quot -- seq )
+    >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
+
 : index ( obj seq -- n )
     [ = ] with find drop ;
 

core/syntax/syntax-docs.factor

@@ -243,7 +243,7 @@ HELP: flushable
 HELP: t
 { $syntax "t" }
 { $values { "t" "the canonical truth value" } }
-{ $description "The canonical instance of " { $link general-t } ". It is just a symbol." } ;
+{ $class-description "The canonical truth value, which is an instance of itself." } ;
 
 HELP: f
 { $syntax "f" }

core/syntax/syntax.factor

@@ -185,4 +185,10 @@ IN: bootstrap.syntax
         [ \ >> parse-until >quotation ] with-compilation-unit
         call
     ] define-syntax
+
+    "call-next-method" [
+        current-class get literalize parsed
+        current-generic get literalize parsed
+        \ (call-next-method) parsed
+    ] define-syntax
 ] with-compilation-unit

core/vocabs/vocabs.factor

@@ -6,13 +6,11 @@ IN: vocabs
 
 SYMBOL: dictionary
 
-TUPLE: vocab
+TUPLE: vocab < identity-tuple
 name words
 main help
 source-loaded? docs-loaded? ;
 
-M: vocab equal? 2drop f ;
-
 : <vocab> ( name -- vocab )
     H{ } clone
     { set-vocab-name set-vocab-words }
@@ -92,10 +90,6 @@ TUPLE: vocab-link name ;
 : <vocab-link> ( name -- vocab-link )
     vocab-link construct-boa ;
 
-M: vocab-link equal?
-    over vocab-link?
-    [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ;
-
 M: vocab-link hashcode*
     vocab-link-name hashcode* ;
 

core/words/words.factor

@@ -173,7 +173,7 @@ GENERIC: subwords ( word -- seq )
 M: word subwords drop f ;
 
 : reset-generic ( word -- )
-    dup subwords [ forget ] each
+    dup subwords forget-all
     dup reset-word
     { "methods" "combination" "default-method" } reset-props ;
 

extra/io/launcher/launcher.factor

@@ -6,7 +6,7 @@ init threads continuations math io.encodings io.streams.duplex
 io.nonblocking accessors ;
 IN: io.launcher
 
-TUPLE: process
+TUPLE: process < identity-tuple
 
 command
 detached
@@ -65,8 +65,6 @@ M: object register-process drop ;
     V{ } clone over processes get set-at
     register-process ;
 
-M: process equal? 2drop f ;
-
 M: process hashcode* process-handle hashcode* ;
 
 : pass-environment? ( process -- ? )

extra/io/sockets/impl/impl.factor

@@ -96,14 +96,13 @@ M: inet6 parse-sockaddr
 M: f parse-sockaddr nip ;
 
 : addrinfo>addrspec ( addrinfo -- addrspec )
-    dup addrinfo-addr
+    [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
-    swap addrinfo-family addrspec-of-family
     parse-sockaddr ;
 
 : parse-addrinfo-list ( addrinfo -- seq )
-    [ dup ]
+    [ addrinfo-next ] follow
-    [ dup addrinfo-next swap addrinfo>addrspec ]
+    [ addrinfo>addrspec ] map
-    [ ] unfold nip [ ] subset ;
+    [ ] subset ;
 
 : prepare-resolve-host ( host serv passive? -- host' serv' flags )
     #! If the port is a number, we resolve for 'http' then

extra/models/models.factor

@@ -4,13 +4,12 @@ USING: generic kernel math sequences arrays assocs alarms
 calendar ;
 IN: models
 
-TUPLE: model value connections dependencies ref locked? ;
+TUPLE: model < identity-tuple
+value connections dependencies ref locked? ;
 
 : <model> ( value -- model )
     V{ } clone V{ } clone 0 f model construct-boa ;
 
-M: model equal? 2drop f ;
-
 M: model hashcode* drop model hashcode* ;
 
 : add-dependency ( dep model -- )

extra/ui/freetype/freetype.factor

@@ -27,9 +27,8 @@ DEFER: freetype
     \ freetype get-global expired? [ init-freetype ] when
     \ freetype get-global ;
 
-TUPLE: font ascent descent height handle widths ;
+TUPLE: font < identity-tuple
-
+ascent descent height handle widths ;
-M: font equal? 2drop f ;
 
 M: font hashcode* drop font hashcode* ;
 

extra/ui/gadgets/gadgets.factor

@@ -44,14 +44,12 @@ M: array rect-dim drop { 0 0 } ;
 : rect-union ( rect1 rect2 -- newrect )
     (rect-union) <extent-rect> ;
 
-TUPLE: gadget
+TUPLE: gadget < identity-tuple
 pref-dim parent children orientation focus
 visible? root? clipped? layout-state graft-state graft-node
 interior boundary
 model ;
 
-M: gadget equal? 2drop f ;
-
 M: gadget hashcode* drop gadget hashcode* ;
 
 M: gadget model-changed 2drop ;
@@ -354,7 +352,7 @@ SYMBOL: in-layout?
     swap [ over (add-gadget) ] each relayout ;
 
 : parents ( gadget -- seq )
-    [ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ;
+    [ gadget-parent ] follow ;
 
 : each-parent ( gadget quot -- ? )
     >r parents r> all? ; inline
@@ -401,7 +399,7 @@ M: f request-focus-on 2drop ;
     dup focusable-child swap request-focus-on ;
 
 : focus-path ( world -- seq )
-    [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ;
+    [ gadget-parent ] follow ;
 
 : make-gadget ( quot gadget -- gadget )
     [ \ make-gadget rot with-variable ] keep ; inline

extra/ui/gadgets/worlds/worlds.factor

@@ -5,7 +5,7 @@ namespaces opengl sequences io combinators math.vectors
 ui.gadgets ui.gestures ui.render ui.backend inspector ;
 IN: ui.gadgets.worlds
 
-TUPLE: world
+TUPLE: world < identity-tuple
 active? focused?
 glass
 title status
@@ -46,8 +46,6 @@ M: world request-focus-on ( child gadget -- )
     t over set-gadget-root?
     dup request-focus ;
 
-M: world equal? 2drop f ;
-
 M: world hashcode* drop world hashcode* ;
 
 M: world pref-dim*