Merge branch 'master' of git://factorcode.org/git/factor

core/assocs/assocs-docs.factor

@@ -16,6 +16,22 @@ $nl
 "To make an assoc into an alist:"
 { $subsection >alist } ;
 
+ARTICLE: "enums" "Enumerations"
+"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:"
+{ $subsection enum }
+{ $subsection <enum> }
+"Inverting a permutation using enumerations:"
+{ $example "USING: assocs sorting prettyprint ;" ": invert <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
+
+HELP: enum
+{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
+$nl
+"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
+
+HELP: <enum>
+{ $values { "seq" sequence } { "enum" enum } }
+{ $description "Creates a new enumeration." } ;
+
 ARTICLE: "assocs-protocol" "Associative mapping protocol"
 "All associative mappings must be instances of a mixin class:"
 { $subsection assoc }

core/assocs/assocs.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays math sequences.private vectors ;
+USING: kernel sequences arrays math sequences.private vectors
+accessors ;
 IN: assocs
 
 MIXIN: assoc
@@ -189,3 +190,24 @@ M: f clear-assoc drop ;
 M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
 
 INSTANCE: sequence assoc
+
+TUPLE: enum seq ;
+
+C: <enum> enum
+
+M: enum at*
+    seq>> 2dup bounds-check?
+    [ nth t ] [ 2drop f f ] if ;
+
+M: enum set-at seq>> set-nth ;
+
+M: enum delete-at enum-seq delete-nth ;
+
+M: enum >alist ( enum -- alist )
+    seq>> [ length ] keep 2array flip ;
+
+M: enum assoc-size seq>> length ;
+
+M: enum clear-assoc seq>> delete-all ;
+
+INSTANCE: enum assoc

core/bootstrap/compiler/compiler.factor

@@ -16,12 +16,6 @@ IN: bootstrap.compiler
 
 "cpu." cpu word-name 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/layouts/layouts.factor

@@ -2,7 +2,8 @@
 ! 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 classes.tuple.private ;
+float-arrays quotations assocs layouts classes.tuple.private
+kernel.private ;
 
 BIN: 111 tag-mask set
 8 num-tags set
@@ -15,6 +16,7 @@ H{
     { bignum      BIN: 001 }
     { tuple       BIN: 010 }
     { object      BIN: 011 }
+    { hi-tag      BIN: 011 }
     { ratio       BIN: 100 }
     { float       BIN: 101 }
     { complex     BIN: 110 }

core/bootstrap/primitives.factor

@@ -31,6 +31,7 @@ crossref off
 "syntax" vocab vocab-words bootstrap-syntax set
 H{ } clone dictionary set
 H{ } clone changed-words set
+H{ } clone forgotten-definitions set
 H{ } clone root-cache set
 H{ } clone source-files set
 H{ } clone update-map set
@@ -101,17 +102,24 @@ num-types get f <array> builtins set
 } [ create-vocab drop ] each
 
 ! Builtin classes
-: builtin-predicate-quot ( class -- quot )
+: lo-tag-eq-quot ( n -- quot )
+    [ \ tag , , \ eq? , ] [ ] make ;
+
+: hi-tag-eq-quot ( n -- quot )
     [
-        "type" word-prop
+        [ dup tag ] % \ hi-tag tag-number , \ eq? ,
-        [ tag-mask get < \ tag \ type ? , ] [ , ] bi
+        [ [ hi-tag ] % , \ eq? , ] [ ] make ,
-        \ eq? ,
+        [ drop f ] ,
+        \ if ,
     ] [ ] make ;
 
+: builtin-predicate-quot ( class -- quot )
+    "type" word-prop
+    dup tag-mask get <
+    [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
+
 : define-builtin-predicate ( class -- )
-    [ dup builtin-predicate-quot define-predicate ]
+    dup builtin-predicate-quot define-predicate ;
-    [ predicate-word make-inline ]
-    bi ;
 
 : lookup-type-number ( word -- n )
     global [ target-word ] bind type-number ;
@@ -119,27 +127,56 @@ num-types get f <array> builtins set
 : register-builtin ( class -- )
     [ dup lookup-type-number "type" set-word-prop ]
     [ dup "type" word-prop builtins get set-nth ]
-    bi ;
+    [ f f builtin-class define-class ]
+    tri ;
 
 : define-builtin-slots ( symbol slotspec -- )
     [ drop ] [ 1 simple-slots ] 2bi
     [ "slots" set-word-prop ] [ define-slots ] 2bi ;
 
 : define-builtin ( symbol slotspec -- )
-    >r
+    >r [ define-builtin-predicate ] keep
-    {
-        [ register-builtin ]
-        [ f f builtin-class define-class ]
-        [ define-builtin-predicate ]
-        [ ]
-    } cleave
     r> define-builtin-slots ;
 
-! Forward definitions
+"fixnum" "math" create register-builtin
-"object" "kernel" create t "class" set-word-prop
+"bignum" "math" create register-builtin
-"object" "kernel" create union-class "metaclass" set-word-prop
+"tuple" "kernel" create register-builtin
+"ratio" "math" create register-builtin
+"float" "math" create register-builtin
+"complex" "math" create register-builtin
+"f" "syntax" lookup register-builtin
+"array" "arrays" create register-builtin
+"wrapper" "kernel" create register-builtin
+"float-array" "float-arrays" create register-builtin
+"callstack" "kernel" create register-builtin
+"string" "strings" create register-builtin
+"bit-array" "bit-arrays" create register-builtin
+"quotation" "quotations" create register-builtin
+"dll" "alien" create register-builtin
+"alien" "alien" create register-builtin
+"word" "words" create register-builtin
+"byte-array" "byte-arrays" create register-builtin
+"tuple-layout" "classes.tuple.private" create register-builtin
 
-"null" "kernel" create drop
+! Catch-all class for providing a default method.
+"object" "kernel" create
+[ 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
+builtins get num-tags get tail define-union-class
+
+! Empty class with no instances
+"null" "kernel" create
+[ 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
@@ -328,47 +365,28 @@ define-builtin
     }
 } define-builtin
 
-"tuple" "kernel" create { } define-builtin
+"tuple" "kernel" create {
-
+    [ { } define-builtin ]
-"tuple" "kernel" lookup
+    [ { "delegate" } "slot-names" set-word-prop ]
-{
+    [ define-tuple-layout ]
+    [
+        {
             {
                 { "object" "kernel" }
                 "delegate"
                 { "delegate" "kernel" }
                 { "set-delegate" "kernel" }
             }
-}
+        }
-[ drop ] [ generate-tuple-slots ] 2bi
+        [ drop ] [ generate-tuple-slots ] 2bi
-[ [ name>> ] map "slot-names" set-word-prop ]
+        [ "slots" set-word-prop ]
-[ "slots" set-word-prop ]
+        [ define-slots ]
-[ define-slots ] 2tri
+        2bi
-
+    ]
-"tuple" "kernel" lookup define-tuple-layout
+} 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" create "syntax" vocab-words delete-at
+"f?" "syntax" vocab-words delete-at
-
-"general-t" "kernel" create [ ] "predicate" set-word-prop
-"general-t?" "kernel" create "syntax" vocab-words delete-at
-
-! 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
-
-! Class of objects with object tag
-"hi-tag" "classes.private" create
-f builtins get num-tags get tail union-class define-class
-
-! Null class with no instances.
-"null" "kernel" create [ drop f ] "predicate" set-word-prop
-"null" "kernel" create f { } union-class define-class
 
 ! Create special tombstone values
 "tombstone" "hashtables.private" create
@@ -638,7 +656,6 @@ f builtins get num-tags get tail union-class define-class
     { "code-room" "memory" }
     { "os-env" "system" }
     { "millis" "system" }
-    { "type" "kernel.private" }
     { "tag" "kernel.private" }
     { "modify-code-heap" "compiler.units" }
     { "dlopen" "alien" }
@@ -710,7 +727,6 @@ f builtins get num-tags get tail union-class define-class
     { "(sleep)" "threads.private" }
     { "<float-array>" "float-arrays" }
     { "<tuple-boa>" "classes.tuple.private" }
-    { "class-hash" "kernel.private" }
     { "callstack>array" "kernel" }
     { "innermost-frame-quot" "kernel.private" }
     { "innermost-frame-scan" "kernel.private" }

core/bootstrap/stage1.factor

@@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ;
         ! Rehash hashtables, since bootstrap.image creates them
         ! using the host image's hashing algorithms
         [ hashtable? ] instances [ rehash ] each
-
         boot
     ] %
 

core/bootstrap/syntax.factor

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

core/classes/algebra/algebra-tests.factor

@@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
-random inference effects ;
+random inference effects kernel.private ;
 
 : class= [ class< ] 2keep swap class< and ;
 
@@ -23,8 +23,8 @@ random inference effects ;
 [ 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 ;
@@ -96,7 +96,7 @@ UNION: z1 b1 c1 ;
 
 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
 
-[ f ] [ growable hi-tag classes-intersect? ] unit-test
+[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
 
 [ t ] [
     growable tuple sequence class-and class<

core/classes/algebra/algebra.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes combinators accessors sequences arrays
 vectors assocs namespaces words sorting layouts math hashtables
-;
+kernel.private ;
 IN: classes.algebra
 
 : 2cache ( key1 key2 assoc quot -- value )
@@ -211,12 +211,6 @@ C: <anonymous-complement> anonymous-complement
 : flatten-class ( class -- assoc )
     [ (flatten-class) ] H{ } make-assoc ;
 
-: class-hashes ( class -- seq )
-    flatten-class keys [
-        dup builtin-class?
-        [ "type" word-prop ] [ hashcode ] if
-    ] map ;
-
 : flatten-builtin-class ( class -- assoc )
     flatten-class [
         dup tuple class< [ 2drop tuple tuple ] when
@@ -229,5 +223,5 @@ C: <anonymous-complement> anonymous-complement
 : class-tags ( class -- tag/f )
     class-types [
         dup num-tags get >=
-        [ drop object tag-number ] when
+        [ drop \ hi-tag tag-number ] when
     ] map prune ;

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

@@ -25,9 +25,11 @@ SYMBOL: class-or-cache
     class-and-cache get clear-assoc
     class-or-cache get clear-assoc ;
 
-PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
-
 SYMBOL: update-map
+
+PREDICATE: class < word
+    "class" word-prop ;
+
 SYMBOL: builtins
 
 PREDICATE: builtin-class < class
@@ -58,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     dup class? [ "superclass" word-prop ] [ drop f ] if ;
 
 : superclasses ( class -- supers )
-    [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
+    [ superclass ] follow reverse ;
 
 : members ( class -- seq )
     #! Output f for non-classes to work with algebra code
@@ -72,7 +74,7 @@ M: word reset-class drop ;
 
 ! update-map
 : class-uses ( class -- seq )
-    dup members swap superclass [ suffix ] when* ;
+    [ members ] [ superclass ] bi [ suffix ] when* ;
 
 : class-usages ( class -- assoc )
     [ update-map get at ] closure ;
@@ -83,7 +85,7 @@ M: word reset-class drop ;
 : update-map- ( class -- )
     dup class-uses update-map get remove-vertex ;
 
-: define-class-props ( superclass members metaclass -- assoc )
+: make-class-props ( superclass members metaclass -- assoc )
     [
         [ dup [ bootstrap-word ] when "superclass" set ]
         [ [ bootstrap-word ] map "members" set ]
@@ -92,12 +94,16 @@ M: word reset-class drop ;
     ] H{ } make-assoc ;
 
 : (define-class) ( word props -- )
-    over reset-class
+    >r
-    over deferred? [ over define-symbol ] when
+    dup reset-class
-    >r dup word-props r> union over set-word-props
+    dup deferred? [ dup define-symbol ] when
-    dup predicate-word 2dup 1quotation "predicate" set-word-prop
+    dup word-props
-    over "predicating" set-word-prop
+    r> union over set-word-props
-    t "class" set-word-prop ;
+    dup predicate-word
+    [ 1quotation "predicate" set-word-prop ]
+    [ swap "predicating" set-word-prop ]
+    [ drop t "class" set-word-prop ]
+    2tri ;
 
 PRIVATE>
 
@@ -105,25 +111,28 @@ GENERIC: update-class ( class -- )
 
 M: class update-class drop ;
 
-: update-classes ( assoc -- )
-    [ drop update-class ] assoc-each ;
-
 GENERIC: update-methods ( assoc -- )
 
+: update-classes ( class -- )
+    class-usages
+    [ [ drop update-class ] assoc-each ]
+    [ update-methods ]
+    bi ;
+
 : define-class ( word superclass members metaclass -- )
     #! If it was already a class, update methods after.
     reset-caches
-    define-class-props
+    make-class-props
     [ drop update-map- ]
-    [ (define-class) ] [
+    [ (define-class) ]
-        drop
+    [ drop update-map+ ]
-        [ update-map+ ] [
+    2tri ;
-            class-usages
-            [ update-classes ]
-            [ update-methods ] bi
-        ] bi
-    ] 2tri ;
 
-GENERIC: class ( object -- class ) inline
+GENERIC: class ( object -- class )
 
-M: object class type type>class ;
+M: hi-tag class hi-tag type>class ;
+
+M: object class tag type>class ;
+
+: instance? ( obj class -- ? )
+    "predicate" word-prop call ;

core/classes/mixin/mixin.factor

@@ -7,7 +7,7 @@ IN: classes.mixin
 PREDICATE: mixin-class < union-class "mixin" word-prop ;
 
 M: mixin-class reset-class
-    { "metaclass" "members" "mixin" } reset-props ;
+    { "class" "metaclass" "members" "mixin" } reset-props ;
 
 : redefine-mixin-class ( class members -- )
     dupd define-union-class

core/classes/predicate/predicate.factor

@@ -14,11 +14,19 @@ PREDICATE: predicate-class < class
     ] [ ] make ;
 
 : define-predicate-class ( class superclass definition -- )
-    >r dupd f predicate-class define-class
+    [ drop f predicate-class define-class ]
-    r> dupd "predicate-definition" set-word-prop
+    [ nip "predicate-definition" set-word-prop ]
-    dup predicate-quot define-predicate ;
+    [
+        2drop
+        [ dup predicate-quot define-predicate ]
+        [ update-classes ]
+        bi
+    ] 3tri ;
 
 M: predicate-class reset-class
     {
-        "metaclass" "predicate-definition" "superclass"
+        "class"
+        "metaclass"
+        "predicate-definition"
+        "superclass"
     } reset-props ;

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

@@ -62,13 +62,13 @@ C: <point> point
 [ 200 ] [ "p" get y>> ] unit-test
 [ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
 
-"p" get 300 ">>z" "accessors" lookup execute drop
+[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
 
 [ 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
+[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
 
 [ 3 ] [ "p" get tuple-size ] unit-test
 
@@ -394,7 +394,9 @@ test-server-slot-values
 ! Reshape crash
 TUPLE: test1 a ; TUPLE: test2 < test1 b ;
 
-T{ test2 f "a" "b" } "test" set
+C: <test2> test2
+
+"a" "b" <test2> "test" set
 
 : test-a/b
     [ "a" ] [ "test" get a>> ] unit-test
@@ -509,3 +511,45 @@ 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
+
+TUPLE: another-forget-accessors-test ;
+
+
+[ [ ] ] [
+    "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
+    <string-reader>
+    "another-forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ \ another-forget-accessors-test class? ] 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 ;
 
@@ -161,25 +154,23 @@ PRIVATE>
 : update-tuples-after ( class -- )
     outdated-tuples get [ all-slot-names ] cache drop ;
 
-: subclasses ( class -- classes )
+M: tuple-class update-class
-    class-usages keys [ tuple-class? ] subset ;
-
-: each-subclass ( class quot -- )
-    >r subclasses r> each ; inline
-
-: define-tuple-shape ( class -- )
-    [ define-tuple-slots ]
     [ define-tuple-layout ]
+    [ define-tuple-slots ]
     [ define-tuple-predicate ]
     tri ;
 
 : define-new-tuple-class ( class superclass slots -- )
     [ drop f tuple-class define-class ]
     [ nip "slot-names" set-word-prop ]
-    [
+    [ 2drop update-classes ]
-        2drop
+    3tri ;
-        [ define-tuple-shape ] each-subclass
+
-    ] 3tri ;
+: subclasses ( class -- classes )
+    class-usages keys [ tuple-class? ] subset ;
+
+: each-subclass ( class quot -- )
+    >r subclasses r> each ; inline
 
 : redefine-tuple-class ( class superclass slots -- )
     [
@@ -191,9 +182,8 @@ PRIVATE>
             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 ;
@@ -214,6 +204,22 @@ M: tuple-class define-tuple-class
     [ define-tuple-class ] [ 2drop ] 3bi
     dup [ construct-boa throw ] curry define ;
 
+M: tuple-class reset-class
+    [
+        dup "slot-names" word-prop [
+            [ reader-word method forget ]
+            [ writer-word method forget ] 2bi
+        ] with each
+    ] [
+        {
+            "class"
+            "metaclass"
+            "superclass"
+            "layout"
+            "slots"
+        } reset-props
+    ] bi ;
+
 M: tuple clone
     (clone) dup delegate clone over set-delegate ;
 
@@ -227,26 +233,13 @@ M: tuple hashcode*
         ] 2curry reduce
     ] recursive-hashcode ;
 
-M: tuple-class reset-class
+! Deprecated
-    { "metaclass" "superclass" "slots" "layout" } reset-props ;
-
 M: object get-slots ( obj slots -- ... )
     [ execute ] with each ;
 
-M: object construct-empty ( class -- tuple )
-    tuple-layout <tuple> ;
-
-M: object construct-boa ( ... class -- tuple )
-    tuple-layout <tuple-boa> ;
-
-! Deprecated
 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/classes/union/union.factor

@@ -1,33 +1,21 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel assocs combinators classes
-generic.standard namespaces arrays math quotations ;
+namespaces arrays math quotations ;
 IN: classes.union
 
 PREDICATE: union-class < class
     "metaclass" word-prop union-class eq? ;
 
 ! Union classes for dispatch on multiple classes.
-: small-union-predicate-quot ( members -- quot )
+: union-predicate-quot ( members -- quot )
     dup empty? [
         drop [ drop f ]
     ] [
-        unclip first "predicate" word-prop swap
+        unclip "predicate" word-prop swap [
-        [ >r "predicate" word-prop [ dup ] prepend r> ]
+            "predicate" word-prop [ dup ] prepend
-        assoc-map alist>quot
+            [ drop t ]
-    ] if ;
+        ] { } map>assoc alist>quot
-
-: big-union-predicate-quot ( members -- quot )
-    [ small-union-predicate-quot ] [ dup ]
-    class-hash-dispatch-quot ;
-
-: union-predicate-quot ( members -- quot )
-    [ [ drop t ] ] { } map>assoc
-    dup length 4 <= [
-        small-union-predicate-quot
-    ] [
-        flatten-methods
-        big-union-predicate-quot
     ] if ;
 
 : define-union-predicate ( class -- )
@@ -36,7 +24,9 @@ PREDICATE: union-class < class
 M: union-class update-class define-union-predicate ;
 
 : define-union-class ( class members -- )
-    f swap union-class define-class ;
+    [ f swap union-class define-class ]
+    [ drop update-classes ]
+    2bi ;
 
 M: union-class reset-class
-    { "metaclass" "members" } reset-props ;
+    { "class" "metaclass" "members" } reset-props ;

core/combinators/combinators.factor

@@ -9,18 +9,24 @@ hashtables sorting ;
     [ call ] with each ;
 
 : cleave>quot ( seq -- quot )
-    [ [ keep ] curry ] map concat [ drop ] append ;
+    [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
 
 : 2cleave ( x seq -- )
-    [ [ call ] 3keep drop ] each 2drop ;
+    [ 2keep ] each 2drop ;
 
 : 2cleave>quot ( seq -- quot )
-    [ [ 2keep ] curry ] map concat [ 2drop ] append ;
+    [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
+
+: 3cleave ( x seq -- )
+    [ 3keep ] each 3drop ;
+
+: 3cleave>quot ( seq -- quot )
+    [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
 
 : spread>quot ( seq -- quot )
     [ length [ >r ] <repetition> concat ]
     [ [ [ r> ] prepend ] map concat ] bi
-    append ;
+    append [ ] like ;
 
 : spread ( objs... seq -- )
     spread>quot call ;

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/compiler/tests/intrinsics.factor

@@ -174,11 +174,6 @@ sequences.private ;
 [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
 [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
 
-[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
-[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
-[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
-[ t ] [ f type f [ type ] compile-call eq? ] unit-test
-
 [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
@@ -223,9 +218,6 @@ sequences.private ;
 
 [ t ] [ f [ f eq? ] compile-call ] unit-test
 
-! regression
-[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
-
 ! regression
 [ 3 ] [
     100001 f <array> 3 100000 pick set-nth

core/compiler/tests/templates.factor

@@ -26,10 +26,6 @@ IN: compiler.tests
 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
 unit-test
 
-[ { 1 2 3 } { 1 4 3 } 8 8 ]
-[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
-unit-test
-
 ! Test literals in either side of a shuffle
 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
 
@@ -176,14 +172,14 @@ TUPLE: my-tuple ;
 [ 1 t ] [
     B{ 1 2 3 4 } [
         { c-ptr } declare
-        [ 0 alien-unsigned-1 ] keep type
+        [ 0 alien-unsigned-1 ] keep hi-tag
     ] compile-call byte-array type-number =
 ] unit-test
 
 [ t ] [
     B{ 1 2 3 4 } [
         { c-ptr } declare
-        0 alien-cell type
+        0 alien-cell hi-tag
     ] compile-call alien type-number =
 ] unit-test
 

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics
     { +output+ { "out" } }
 } define-intrinsic
 
-\ type [
-    "end" define-label
-    ! Get the tag
-    "y" operand "obj" operand tag-mask get ANDI
-    ! Tag the tag
-    "y" operand "x" operand %tag-fixnum
-    ! Compare with object tag number (3).
-    0 "y" operand object tag-number CMPI
-    ! Jump if the object doesn't store type info in its header
-    "end" get BNE
-    ! It does store type info in its header
-    "x" operand "obj" operand header-offset LWZ
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } { f "y" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
-    "end" define-label
-    "tuple" define-label
-    "object" define-label
-    ! Get the tag
-    "y" operand "obj" operand tag-mask get ANDI
-    ! Compare with tuple tag number (2).
-    0 "y" operand tuple tag-number CMPI
-    "tuple" get BEQ
-    ! Compare with object tag number (3).
-    0 "y" operand object tag-number CMPI
-    "object" get BEQ
-    ! Tag the tag
-    "y" operand "x" operand %tag-fixnum
-    "end" get B
-    "object" get resolve-label
-    ! Load header type
-    "x" operand "obj" operand header-offset LWZ
-    "end" get B
-    "tuple" get resolve-label
-    ! Load class hash
-    "x" operand "obj" operand tuple-class-offset LWZ
-    "x" operand dup class-hash-offset LWZ
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } { f "y" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
 : userenv ( reg -- )
     #! Load the userenv pointer in a register.
     "userenv" f rot %load-dlsym ;

core/cpu/x86/intrinsics/intrinsics.factor

@@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
     { +output+ { "in" } }
 } define-intrinsic
 
-\ type [
-    "end" define-label
-    ! Make a copy
-    "x" operand "obj" operand MOV
-    ! Get the tag
-    "x" operand tag-mask get AND
-    ! Tag the tag
-    "x" operand %tag-fixnum
-    ! Compare with object tag number (3).
-    "x" operand object tag-number tag-fixnum CMP
-    "end" get JNE
-    ! If we have equality, load type from header
-    "x" operand "obj" operand -3 [+] MOV
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
-    "end" define-label
-    "tuple" define-label
-    "object" define-label
-    ! Make a copy
-    "x" operand "obj" operand MOV
-    ! Get the tag
-    "x" operand tag-mask get AND
-    ! Tag the tag
-    "x" operand %tag-fixnum
-    ! Compare with tuple tag number (2).
-    "x" operand tuple tag-number tag-fixnum CMP
-    "tuple" get JE
-    ! Compare with object tag number (3).
-    "x" operand object tag-number tag-fixnum CMP
-    "object" get JE
-    "end" get JMP
-    "object" get resolve-label
-    ! Load header type
-    "x" operand "obj" operand header-offset [+] MOV
-    "end" get JMP
-    "tuple" get resolve-label
-    ! Load class hash
-    "x" operand "obj" operand tuple-class-offset [+] MOV
-    "x" operand dup class-hash-offset [+] MOV
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
 ! Slots
 : %slot-literal-known-tag
     "obj" operand

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-docs.factor

@@ -37,7 +37,6 @@ $nl
 { $subsection create-method }
 "Method definitions can be looked up:"
 { $subsection method }
-{ $subsection methods }
 "A generic word contains methods; the list of methods specializing on a class can also be obtained:"
 { $subsection implementors }
 "Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@@ -63,15 +62,6 @@ ARTICLE: "method-combination" "Custom method combination"
 "Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the definition protocol words " { $link definer } " and " { $link synopsis* } " on the class of words having this method combination, to properly support developer tools."
 $nl
 "The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
-$nl
-"Method combination utilities:"
-{ $subsection single-combination }
-{ $subsection class-predicates }
-{ $subsection simplify-alist }
-{ $subsection math-upgrade }
-{ $subsection object-method }
-{ $subsection error-method }
-"More quotation construction utilities can be found in " { $link "quotations" } " and " { $link "combinators-quot" } "."
 { $see-also "generic-introspection" } ;
 
 ARTICLE: "generic" "Generic words and methods"
@@ -129,10 +119,6 @@ HELP: <method>
 { $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
 { $description "Creates a new method." } ;
 
-HELP: methods
-{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
 HELP: order
 { $values { "generic" generic } { "seq" "a sequence of classes" } }
 { $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
@@ -160,4 +146,4 @@ HELP: forget-methods
 { $values { "class" class } }
 { $description "Remove all method definitions which specialize on the class." } ;
 
-{ sort-classes methods order } related-words
+{ sort-classes order } related-words

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 ;
@@ -171,37 +148,6 @@ M: f tag-and-f 4 ;
 
 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
 
-! define-class hashing issue
-TUPLE: debug-combination ;
-
-M: debug-combination make-default-method
-    2drop [ "Oops" throw ] ;
-
-M: debug-combination perform-combination
-    drop
-    order [ dup class-hashes ] { } map>assoc sort-keys
-    1quotation ;
-
-SYMBOL: redefinition-test-generic
-
-[
-    redefinition-test-generic
-    T{ debug-combination }
-    define-generic
-] with-compilation-unit
-
-TUPLE: redefinition-test-tuple ;
-
-"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
-
-[ t ] [
-    [
-        redefinition-test-generic ,
-        "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
-        redefinition-test-generic ,
-    ] { } make all-equal?
-] unit-test
-
 ! Issues with forget
 GENERIC: generic-forget-test-1
 

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 )
 
@@ -25,8 +16,9 @@ PREDICATE: generic < word
 M: generic definition drop f ;
 
 : make-generic ( word -- )
-    dup { "unannotated-def" } reset-props
+    [ { "unannotated-def" } reset-props ]
-    dup dup "combination" word-prop perform-combination define ;
+    [ dup "combination" word-prop perform-combination ]
+    bi ;
 
 : method ( class generic -- method/f )
     "methods" word-prop at ;
@@ -37,10 +29,17 @@ PREDICATE: method-spec < pair
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
-: methods ( word -- assoc )
+: next-method-class ( class generic -- class/f )
-    "methods" word-prop
+    order [ class< ] with subset reverse dup length 1 =
-    [ keys sort-classes ] keep
+    [ drop f ] [ second ] if ;
-    [ dupd at ] curry { } map>assoc ;
+
+: 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 ;
 
@@ -62,6 +61,9 @@ PREDICATE: method-body < word
 M: method-body stack-effect
     "method-generic" word-prop stack-effect ;
 
+M: method-body crossref?
+    drop t ;
+
 : method-word-props ( class generic -- assoc )
     [
         "method-generic" set
@@ -104,14 +106,6 @@ M: method-spec definer
 M: method-spec definition
     first2 method definition ;
 
-: forget-method ( class generic -- )
-    dup generic? [
-        [ delete-at* ] with-methods
-        [ forget-word ] [ drop ] if
-    ] [
-        2drop
-    ] if ;
-
 M: method-spec forget*
     first2 method forget* ;
 
@@ -120,9 +114,15 @@ M: method-body definer
 
 M: method-body forget*
     dup "forgotten" word-prop [ drop ] [
-        dup "method-class" word-prop
+        [
-        over "method-generic" word-prop forget-method
+            [   "method-class" word-prop ]
-        t "forgotten" set-word-prop
+            [ "method-generic" word-prop ] bi
+            dup generic? [
+                [ delete-at* ] with-methods
+                [ call-next-method ] [ drop ] if
+            ] [ 2drop ] if
+        ]
+        [ t "forgotten" set-word-prop ] bi
     ] if ;
 
 : implementors* ( classes -- words )
@@ -135,12 +135,13 @@ M: method-body forget*
     dup associate implementors* ;
 
 : forget-methods ( class -- )
-    [ implementors ] keep [ swap 2array ] curry map forget-all ;
+    [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
 
 M: class forget* ( class -- )
-    dup forget-methods
+    [ forget-methods ]
-    dup update-map-
+    [ update-map- ]
-    forget-word ;
+    [ call-next-method ]
+    tri ;
 
 M: assoc update-methods ( assoc -- )
     implementors* [ make-generic ] each ;
@@ -156,11 +157,15 @@ M: assoc update-methods ( assoc -- )
     ] if ;
 
 M: generic subwords
-    dup "methods" word-prop values
+    [
-    swap "default-method" word-prop suffix ;
+        [ "default-method" word-prop , ]
+        [ "methods" word-prop values % ]
+        [ "engines" word-prop % ]
+        tri
+    ] { } make ;
 
-M: generic forget-word
+M: generic forget*
-    dup subwords [ forget ] each (forget-word) ;
+    [ subwords forget-all ] [ call-next-method ] bi ;
 
 : xref-generics ( -- )
     all-words [ subwords [ xref ] each ] each ;

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 ] }
@@ -71,13 +71,15 @@ M: math-combination make-default-method
 
 M: math-combination perform-combination
     drop
+    dup
     \ over [
         dup math-class? [
             \ dup [ >r 2dup r> math-method ] math-vtable
         ] [
             over object-method
         ] if nip
-    ] math-vtable nip ;
+    ] math-vtable nip
+    define ;
 
 PREDICATE: math-generic < generic ( word -- ? )
     "combination" word-prop math-combination? ;

core/generic/standard/engines/engines.factor

@@ -0,0 +1,49 @@
+USING: assocs kernel namespaces quotations generic math
+sequences combinators words classes.algebra ;
+IN: generic.standard.engines
+
+SYMBOL: default
+SYMBOL: assumed
+
+GENERIC: engine>quot ( engine -- quot )
+
+M: quotation engine>quot ;
+
+M: method-body engine>quot 1quotation ;
+
+: engines>quots ( assoc -- assoc' )
+    [ engine>quot ] assoc-map ;
+
+: engines>quots* ( assoc -- assoc' )
+    [ over assumed [ engine>quot ] with-variable ] assoc-map ;
+
+: if-small? ( assoc true false -- )
+    >r >r dup assoc-size 4 <= r> r> if ; inline
+
+: linear-dispatch-quot ( alist -- quot )
+    default get [ drop ] prepend swap
+    [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
+    alist>quot ;
+
+: split-methods ( assoc class -- first second )
+    [ [ nip class< not ] curry assoc-subset ]
+    [ [ nip class<     ] curry assoc-subset ] 2bi ;
+
+: convert-methods ( assoc class word -- assoc' )
+    over >r >r split-methods dup assoc-empty? [
+        r> r> 3drop
+    ] [
+        r> execute r> pick set-at
+    ] if ; inline
+
+SYMBOL: (dispatch#)
+
+: (picker) ( n -- quot )
+    {
+        { 0 [ [ dup ] ] }
+        { 1 [ [ over ] ] }
+        { 2 [ [ pick ] ] }
+        [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+    } case ;
+
+: picker ( -- quot ) \ (dispatch#) get (picker) ;

core/generic/standard/engines/predicate/predicate.factor

@@ -0,0 +1,32 @@
+USING: generic.standard.engines generic namespaces kernel
+sequences classes.algebra accessors words combinators
+assocs ;
+IN: generic.standard.engines.predicate
+
+TUPLE: predicate-dispatch-engine methods ;
+
+C: <predicate-dispatch-engine> predicate-dispatch-engine
+
+: class-predicates ( assoc -- assoc )
+    [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
+
+: keep-going? ( assoc -- ? )
+    assumed get swap second first class< ;
+
+: prune-redundant-predicates ( assoc -- default assoc' )
+    {
+        { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+        { [ dup length 1 = ] [ first second { } ] }
+        { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
+        { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
+    } cond ;
+
+: sort-methods ( assoc -- assoc' )
+    [ keys sort-classes ]
+    [ [ dupd at ] curry ] bi { } map>assoc ;
+
+M: predicate-dispatch-engine engine>quot
+    methods>> clone
+    default get object bootstrap-word pick set-at engines>quots
+    sort-methods prune-redundant-predicates
+    class-predicates alist>quot ;

core/generic/standard/engines/tag/tag.factor

@@ -0,0 +1,57 @@
+USING: classes.private generic.standard.engines namespaces
+arrays assocs sequences.private quotations kernel.private
+math slots.private math.private kernel accessors words
+layouts ;
+IN: generic.standard.engines.tag
+
+TUPLE: lo-tag-dispatch-engine methods ;
+
+C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
+
+: direct-dispatch-quot ( alist n -- quot )
+    default get <array>
+    [ <enum> swap update ] keep
+    [ dispatch ] curry >quotation ;
+
+: lo-tag-number ( class -- n )
+     dup \ hi-tag bootstrap-word eq? [
+        drop \ hi-tag tag-number
+    ] [
+        "type" word-prop
+    ] if ;
+
+M: lo-tag-dispatch-engine engine>quot
+    methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
+    [
+        picker % [ tag ] % [
+            linear-dispatch-quot
+        ] [
+            num-tags get direct-dispatch-quot
+        ] if-small? %
+    ] [ ] make ;
+
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+    \ hi-tag bootstrap-word
+    \ <hi-tag-dispatch-engine> convert-methods ;
+
+: num-hi-tags num-types get num-tags get - ;
+
+: hi-tag-number ( class -- n )
+    "type" word-prop num-tags get - ;
+
+: hi-tag-quot ( -- quot )
+    [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
+
+M: hi-tag-dispatch-engine engine>quot
+    methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+    [
+        picker % hi-tag-quot % [
+            linear-dispatch-quot
+        ] [
+            num-hi-tags direct-dispatch-quot
+        ] if-small? %
+    ] [ ] make ;

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

@@ -0,0 +1,128 @@
+IN: generic.standard.engines.tuple
+USING: kernel classes.tuple.private hashtables assocs sorting
+accessors combinators sequences slots.private math.parser words
+effects namespaces generic generic.standard.engines
+classes.algebra math math.private quotations arrays ;
+
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: trivial-tuple-dispatch-engine methods ;
+
+C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+    >r swap dup "layout" word-prop layout-echelon r>
+    [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+    V{ } clone [
+        [
+            push-echelon
+        ] curry assoc-each
+    ] keep sort-keys ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+    echelon-sort
+    [
+        over zero? [
+            dup assoc-empty?
+            [ drop f ] [ values first ] if
+        ] [
+            dupd <echelon-dispatch-engine>
+        ] if
+    ] assoc-map [ nip ] assoc-subset
+    \ tuple-dispatch-engine construct-boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+    tuple bootstrap-word
+    \ <tuple-dispatch-engine> convert-methods ;
+
+M: trivial-tuple-dispatch-engine engine>quot
+    methods>> engines>quots* linear-dispatch-quot ;
+
+: hash-methods ( methods -- buckets )
+    >alist V{ } clone [ hashcode 1array ] distribute-buckets
+    [ <trivial-tuple-dispatch-engine> ] map ;
+
+: class-hash-dispatch-quot ( methods -- quot )
+    #! 1 slot == word hashcode
+    [
+        [ dup 1 slot ] %
+        hash-methods [ engine>quot ] map hash-dispatch-quot %
+    ] [ ] make ;
+
+: tuple-dispatch-engine-word-name ( engine -- string )
+    [
+        generic get word-name %
+        "/tuple-dispatch-engine/" %
+        n>> #
+    ] "" make ;
+
+PREDICATE: tuple-dispatch-engine-word < word
+    "tuple-dispatch-engine" word-prop ;
+
+M: tuple-dispatch-engine-word stack-effect
+    "tuple-dispatch-generic" word-prop stack-effect ;
+
+M: tuple-dispatch-engine-word crossref?
+    drop t ;
+
+: remember-engine ( word -- )
+    generic get "engines" word-prop push ;
+
+: <tuple-dispatch-engine-word> ( engine -- word )
+    tuple-dispatch-engine-word-name f <word>
+    {
+        [ t "tuple-dispatch-engine" set-word-prop ]
+        [ generic get "tuple-dispatch-generic" set-word-prop ]
+        [ remember-engine ]
+        [ ]
+    } cleave ;
+
+: define-tuple-dispatch-engine-word ( engine quot -- word )
+    >r <tuple-dispatch-engine-word> dup r> define ;
+
+: tuple-dispatch-engine-body ( engine -- quot )
+    #! 1 slot == tuple-layout
+    #! 2 slot == 0 array-nth
+    #! 4 slot == layout-superclasses
+    [
+        picker %
+        [ 1 slot 4 slot ] %
+        [ n>> 2 + , [ slot ] % ]
+        [
+            methods>> [
+                <trivial-tuple-dispatch-engine> engine>quot
+            ] [
+                class-hash-dispatch-quot
+            ] if-small? %
+        ] bi
+    ] [ ] make ;
+
+M: echelon-dispatch-engine engine>quot
+    dup tuple-dispatch-engine-body
+    define-tuple-dispatch-engine-word
+    1quotation ;
+
+: >=-case-quot ( alist -- quot )
+    default get [ drop ] prepend swap
+    [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
+    alist>quot ;
+
+M: tuple-dispatch-engine engine>quot
+    #! 1 slot == tuple-layout
+    #! 5 slot == layout-echelon
+    [
+        picker %
+        [ 1 slot 5 slot ] %
+        echelons>>
+        [
+            tuple assumed set
+            [ engine>quot dup default set ] assoc-map
+        ] with-scope
+        >=-case-quot %
+    ] [ ] make ;

core/generic/standard/standard-tests.factor

@@ -0,0 +1,235 @@
+IN: generic.standard.tests
+USING: tools.test math math.functions math.constants
+generic.standard strings sequences arrays kernel accessors
+words float-arrays byte-arrays bit-arrays parser namespaces ;
+
+GENERIC: lo-tag-test
+
+M: integer lo-tag-test 3 + ;
+
+M: float lo-tag-test 4 - ;
+
+M: rational lo-tag-test 2 - ;
+
+M: complex lo-tag-test sq ;
+
+[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
+[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
+[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
+[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
+
+GENERIC: hi-tag-test
+
+M: string hi-tag-test ", in bed" append ;
+
+M: integer hi-tag-test 3 + ;
+
+M: array hi-tag-test [ hi-tag-test ] map ;
+
+M: sequence hi-tag-test reverse ;
+
+[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
+
+[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
+
+[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
+
+TUPLE: shape ;
+
+TUPLE: abstract-rectangle < shape width height ;
+
+TUPLE: rectangle < abstract-rectangle ;
+
+C: <rectangle> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> area 4 pi * = ] unit-test
+
+GENERIC: perimiter
+
+: rectangle-perimiter + 2 * ;
+
+M: rectangle perimiter
+    [ width>> ] [ height>> ] bi
+    rectangle-perimiter ;
+
+: hypotenuse [ sq ] bi@ + sqrt ;
+
+M: parallelogram perimiter
+    [ width>> ]
+    [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
+    rectangle-perimiter ;
+
+M: circle perimiter 2 * pi * ;
+
+[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
+[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+
+GENERIC: big-mix-test
+
+M: object big-mix-test drop "object" ;
+
+M: tuple big-mix-test drop "tuple" ;
+
+M: integer big-mix-test drop "integer" ;
+
+M: float big-mix-test drop "float" ;
+
+M: complex big-mix-test drop "complex" ;
+
+M: string big-mix-test drop "string" ;
+
+M: array big-mix-test drop "array" ;
+
+M: sequence big-mix-test drop "sequence" ;
+
+M: rectangle big-mix-test drop "rectangle" ;
+
+M: parallelogram big-mix-test drop "parallelogram" ;
+
+M: circle big-mix-test drop "circle" ;
+
+[ "integer" ] [ 3 big-mix-test ] unit-test
+[ "float" ] [ 5.0 big-mix-test ] unit-test
+[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
+[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
+[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
+[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
+[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
+[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
+[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
+[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
+[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
+[ "string" ] [ "hello" big-mix-test ] unit-test
+[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
+[ "tuple" ] [ H{ } big-mix-test ] unit-test
+[ "object" ] [ \ + big-mix-test ] unit-test
+
+GENERIC: small-lo-tag
+
+M: fixnum small-lo-tag drop "fixnum" ;
+
+M: string small-lo-tag drop "string" ;
+
+M: array small-lo-tag drop "array" ;
+
+M: float-array small-lo-tag drop "float-array" ;
+
+M: byte-array small-lo-tag drop "byte-array" ;
+
+[ "fixnum" ] [ 3 small-lo-tag ] unit-test
+
+[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
+
+! Testing next-method
+TUPLE: person ;
+
+TUPLE: intern < person ;
+
+TUPLE: employee < person ;
+
+TUPLE: tape-monkey < employee ;
+
+TUPLE: manager < employee ;
+
+TUPLE: junior-manager < manager ;
+
+TUPLE: middle-manager < manager ;
+
+TUPLE: senior-manager < manager ;
+
+TUPLE: executive < senior-manager ;
+
+TUPLE: ceo < executive ;
+
+GENERIC: salary ( person -- n )
+
+M: intern salary
+    #! Intentional mistake.
+    call-next-method ;
+
+M: employee salary drop 24000 ;
+
+M: manager salary call-next-method 12000 + ;
+
+M: middle-manager salary call-next-method 5000 + ;
+
+M: senior-manager salary call-next-method 15000 + ;
+
+M: executive salary call-next-method 2 * ;
+
+M: ceo salary
+    #! Intentional error.
+    drop 5 call-next-method 3 * ;
+
+[ salary ] must-infer
+
+[ 24000 ] [ employee construct-boa salary ] unit-test
+
+[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
+
+[ 36000 ] [ junior-manager construct-boa salary ] unit-test
+
+[ 41000 ] [ middle-manager construct-boa salary ] unit-test
+
+[ 51000 ] [ senior-manager construct-boa salary ] unit-test
+
+[ 102000 ] [ executive construct-boa salary ] unit-test
+
+[ ceo construct-boa salary ]
+[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with
+
+[ intern construct-boa salary ]
+[ T{ no-next-method f intern salary } = ] must-fail-with
+
+! Weird shit
+TUPLE: a ;
+TUPLE: b ;
+TUPLE: c ;
+
+UNION: x a b ;
+UNION: y a c ;
+
+UNION: z x y ;
+
+GENERIC: funky* ( obj -- )
+
+M: z funky* "z" , drop ;
+
+M: x funky* "x" , call-next-method ;
+
+M: y funky* "y" , call-next-method ;
+
+M: a funky* "a" , call-next-method ;
+
+M: b funky* "b" , call-next-method ;
+
+M: c funky* "c" , call-next-method ;
+
+: funky [ funky* ] { } make ;
+
+[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
+
+[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
+
+[ t ] [
+    T{ a } funky
+    { { "a" "x" "z" } { "a" "y" "z" } } member?
+] unit-test

core/generic/standard/standard.factor

@@ -3,26 +3,21 @@
 USING: arrays assocs kernel kernel.private slots.private math
 namespaces sequences vectors words quotations definitions
 hashtables layouts combinators sequences.private generic
-classes classes.algebra classes.private ;
+classes classes.algebra classes.private generic.standard.engines
+generic.standard.engines.tag generic.standard.engines.predicate
+generic.standard.engines.tuple accessors ;
 IN: generic.standard
 
-TUPLE: standard-combination # ;
+GENERIC: dispatch# ( word -- n )
 
-C: <standard-combination> standard-combination
+M: word dispatch# "combination" word-prop dispatch# ;
 
-SYMBOL: (dispatch#)
+: unpickers
-
-: (picker) ( n -- quot )
     {
-        { 0 [ [ dup ] ] }
+        [ nip ]
-        { 1 [ [ over ] ] }
+        [ >r nip r> swap ]
-        { 2 [ [ pick ] ] }
+        [ >r >r nip r> r> -rot ]
-        [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+    } ; inline
-    } case ;
-
-: picker ( -- quot ) \ (dispatch#) get (picker) ;
-
-: unpickers { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } ; inline
 
 : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
 
@@ -38,159 +33,134 @@ ERROR: no-method object generic ;
         error-method \ drop prefix , \ if ,
     ] [ ] make ;
 
-: class-predicates ( assoc -- assoc )
-    [
-        >r >r picker r> "predicate" word-prop append r>
-    ] assoc-map ;
-
-: (simplify-alist) ( class i assoc -- default assoc )
-    2dup length 1- = [
-        nth second { } rot drop
-    ] [
-        3dup >r 1+ r> nth first class< [
-            >r 1+ r> (simplify-alist)
-        ] [
-            [ nth second ] 2keep swap 1+ tail rot drop
-        ] if
-    ] if ;
-
-: simplify-alist ( class assoc -- default assoc )
-    dup empty? [
-        2drop [ "Unreachable" throw ] { }
-    ] [
-        0 swap (simplify-alist)
-    ] if ;
-
 : default-method ( word -- pair )
     "default-method" word-prop
     object bootstrap-word swap 2array ;
 
-: method-alist>quot ( alist base-class -- quot )
+: push-method ( method specializer atomic assoc -- )
-    bootstrap-word swap simplify-alist
-    class-predicates alist>quot ;
-
-: small-generic ( methods -- def )
-    object method-alist>quot ;
-
-: hash-methods ( methods -- buckets )
-    V{ } clone [
-        tuple bootstrap-word over class< [
-            drop t
-        ] [
-            class-hashes
-        ] if
-    ] distribute-buckets ;
-
-: class-hash-dispatch-quot ( methods quot picker -- quot )
-    >r >r hash-methods r> map
-    hash-dispatch-quot r> [ class-hash ] rot 3append ; inline
-
-: big-generic ( methods -- quot )
-    [ small-generic ] picker class-hash-dispatch-quot ;
-
-: vtable-class ( n -- class )
-    bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
-
-: group-methods ( assoc -- vtable )
-    #! Input is a predicate -> method association.
-    #! n is vtable size (either num-types or num-tags).
-    num-tags get [
-        vtable-class
-        [ swap first classes-intersect? ] curry subset
-    ] with map ;
-
-: build-type-vtable ( alist-seq -- alist-seq )
-    dup length [
-        vtable-class
-        swap simplify-alist
-        class-predicates alist>quot
-    ] 2map ;
-
-: tag-generic ( methods -- quot )
     [
-        picker %
+        [ H{ } clone <predicate-dispatch-engine> ] unless*
-        \ tag ,
+        [ methods>> set-at ] keep
-        group-methods build-type-vtable ,
+    ] change-at ;
-        \ dispatch ,
-    ] [ ] make ;
 
-: flatten-method ( class body -- )
+: flatten-method ( class method assoc -- )
-    over members pick object bootstrap-word eq? not and [
+    >r >r dup flatten-class keys swap r> r> [
-        >r members r> [ flatten-method ] curry each
+        >r spin r> push-method
-    ] [
+    ] 3curry each ;
-        swap set
-    ] if ;
 
-: flatten-methods ( methods -- newmethods )
+: flatten-methods ( assoc -- assoc' )
-    [ [ flatten-method ] assoc-each ] V{ } make-assoc ;
+    H{ } clone [
+        [
+            flatten-method
+        ] curry assoc-each
+    ] keep ;
 
-: dispatched-types ( methods -- seq )
+: <big-dispatch-engine> ( assoc -- engine )
-    keys object bootstrap-word swap remove prune ;
-
-: single-combination ( methods -- quot )
-    dup length 4 <= [
-        small-generic
-    ] [
     flatten-methods
-        dup dispatched-types [ number class< ] all?
+    convert-tuple-methods
-        [ tag-generic ] [ big-generic ] if
+    convert-hi-tag-methods
-    ] if ;
+    <lo-tag-dispatch-engine> ;
 
-: standard-methods ( word -- alist )
+: find-default ( methods -- quot )
-    dup methods swap default-method prefix
+    #! Side-effects methods.
-    [ 1quotation ] assoc-map ;
+    object bootstrap-word swap delete-at* [
+        drop generic get "default-method" word-prop 1quotation
+    ] unless ;
 
-M: standard-combination make-default-method
+GENERIC: mangle-method ( method generic -- quot )
-    standard-combination-# (dispatch#)
-    [ empty-method ] with-variable ;
 
-M: standard-combination perform-combination
+: single-combination ( word -- quot )
-    standard-combination-# (dispatch#) [
-        [ standard-methods ] keep "inline" word-prop
-        [ small-generic ] [ single-combination ] if
-    ] with-variable ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-: with-hook ( combination quot -- quot' )
-    0 (dispatch#) [
-        swap slip
-        hook-combination-var [ get ] curry
-        prepend
-    ] with-variable ; inline
-
-M: hook-combination make-default-method
-    [ error-method ] with-hook ;
-
-M: hook-combination perform-combination
     [
-        standard-methods
+        object bootstrap-word assumed set {
-        [ [ drop ] prepend ] assoc-map
+            [ generic set ]
-        single-combination
+            [ "engines" word-prop forget-all ]
-    ] with-hook ;
+            [ V{ } clone "engines" set-word-prop ]
+            [
+                "methods" word-prop
+                [ generic get mangle-method ] assoc-map
+                [ find-default default set ]
+                [
+                    generic get "inline" word-prop [
+                        <predicate-dispatch-engine>
+                    ] [
+                        <big-dispatch-engine>
+                    ] if
+                ] bi
+                engine>quot
+            ]
+        } cleave
+    ] with-scope ;
 
-: define-simple-generic ( word -- )
+TUPLE: standard-combination # ;
-    T{ standard-combination f 0 } define-generic ;
+
+C: <standard-combination> standard-combination
 
 PREDICATE: standard-generic < generic
     "combination" word-prop standard-combination? ;
 
 PREDICATE: simple-generic < standard-generic
-    "combination" word-prop standard-combination-# zero? ;
+    "combination" word-prop #>> zero? ;
+
+: define-simple-generic ( word -- )
+    T{ standard-combination f 0 } define-generic ;
+
+: with-standard ( combination quot -- quot' )
+    >r #>> (dispatch#) r> with-variable ; inline
+
+M: standard-generic mangle-method
+    drop 1quotation ;
+
+M: standard-combination make-default-method
+    [ empty-method ] with-standard ;
+
+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
+        \ if ,
+    ] [ ] make ;
+
+TUPLE: hook-combination var ;
+
+C: <hook-combination> hook-combination
 
 PREDICATE: hook-generic < generic
     "combination" word-prop hook-combination? ;
 
-GENERIC: dispatch# ( word -- n )
+: with-hook ( combination quot -- quot' )
-
+    0 (dispatch#) [
-M: word dispatch# "combination" word-prop dispatch# ;
+        dip var>> [ get ] curry prepend
-
+    ] with-variable ; inline
-M: standard-combination dispatch# standard-combination-# ;
 
 M: hook-combination dispatch# drop 0 ;
 
+M: hook-generic mangle-method
+    drop 1quotation [ drop ] prepend ;
+
+M: hook-combination make-default-method
+    [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+    [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
+
 M: simple-generic definer drop \ GENERIC: f ;
 
 M: standard-generic definer drop \ GENERIC# f ;

core/inference/backend/backend.factor

@@ -3,14 +3,23 @@
 USING: inference.dataflow inference.state arrays generic io
 io.streams.string kernel math namespaces parser prettyprint
 sequences strings vectors words quotations effects classes
-continuations debugger assocs combinators compiler.errors ;
+continuations debugger assocs combinators compiler.errors
+generic.standard.engines.tuple ;
 IN: inference.backend
 
 : recursive-label ( word -- label/f )
     recursive-state get at ;
 
-: inline? ( word -- ? )
+GENERIC: inline? ( word -- ? )
-    dup "method-generic" word-prop swap or "inline" word-prop ;
+
+M: method-body inline?
+    "method-generic" word-prop inline? ;
+
+M: tuple-dispatch-engine-word inline?
+    "tuple-dispatch-generic" word-prop inline? ;
+
+M: word inline?
+    "inline" word-prop ;
 
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys

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 )
 
@@ -120,7 +120,7 @@ M: object xyz ;
     [
         [ no-cond ] 1
         [ 1array dup quotation? [ >quotation ] unless ] times
-    ] \ type inlined?
+    ] \ quotation? inlined?
 ] unit-test
 
 [ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
@@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ;
     \ >float inlined?
 ] unit-test
 
+GENERIC: detect-float ( a -- b )
+
+M: float detect-float ;
+
+[ t ] [
+    [ { real float } declare + detect-float ]
+    \ detect-float inlined?
+] unit-test
+
+[ t ] [
+    [ { float real } declare + detect-float ]
+    \ detect-float inlined?
+] unit-test
+
 [ t ] [
     [ 3 + = ] \ equal? inlined?
 ] unit-test
@@ -297,3 +311,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

@@ -175,10 +175,19 @@ M: pair constraint-satisfied?
     [ intersect-value-interval ] 2each ;
 
 : predicate-constraints ( class #call -- )
+    [
+        ! If word outputs true, input is an instance of class
         [
             0 `input class,
-        general-t 0 `output class,
+            \ f class-not 0 `output class,
-    ] set-constraints ;
+        ] 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 ;
 
@@ -265,7 +274,7 @@ DEFER: (infer-classes)
     (merge-intervals) r> set-intervals ;
 
 : annotate-merge ( nodes #merge/#entry -- )
-    2dup merge-classes merge-intervals ;
+    [ merge-classes ] [ merge-intervals ] 2bi ;
 
 : merge-children ( node -- )
     dup node-successor dup #merge? [
@@ -281,28 +290,31 @@ DEFER: (infer-classes)
 M: #label infer-classes-before ( #label -- )
     #! First, infer types under the hypothesis which hold on
     #! entry to the recursive label.
-    dup 1array swap annotate-entry ;
+    [ 1array ] keep annotate-entry ;
 
 M: #label infer-classes-around ( #label -- )
     #! Now merge the types at every recursion point with the
     #! entry types.
-    dup annotate-node
+    {
-    dup infer-classes-before
+        [ annotate-node ]
-    dup infer-children
+        [ infer-classes-before ]
-    dup collect-recursion over suffix
+        [ infer-children ]
-    pick annotate-entry
+        [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
-    node-child (infer-classes) ;
+        [ node-child (infer-classes) ]
+    } cleave ;
 
 M: object infer-classes-around
-    dup infer-classes-before
+    {
-    dup annotate-node
+        [ infer-classes-before ]
-    dup infer-children
+        [ annotate-node ]
-    merge-children ;
+        [ infer-children ]
+        [ merge-children ]
+    } cleave ;
 
 : (infer-classes) ( node -- )
     [
-        dup infer-classes-around
+        [ infer-classes-around ]
-        node-successor (infer-classes)
+        [ node-successor (infer-classes) ] bi
     ] when* ;
 
 : infer-classes-with ( node classes literals intervals -- )

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/known-words/known-words.factor

@@ -383,15 +383,9 @@ set-primitive-effect
 \ millis { } { integer } <effect> set-primitive-effect
 \ millis make-flushable
 
-\ type { object } { fixnum } <effect> set-primitive-effect
-\ type make-foldable
-
 \ tag { object } { fixnum } <effect> set-primitive-effect
 \ tag make-foldable
 
-\ class-hash { object } { fixnum } <effect> set-primitive-effect
-\ class-hash make-foldable
-
 \ cwd { } { string } <effect> set-primitive-effect
 
 \ cd { string } { } <effect> set-primitive-effect

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 )
@@ -43,6 +43,8 @@ IN: inference.transforms
 
 \ 2cleave [ 2cleave>quot ] 1 define-transform
 
+\ 3cleave [ 3cleave>quot ] 1 define-transform
+
 \ spread [ spread>quot ] 1 define-transform
 
 ! Bitfields
@@ -96,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" }
@@ -413,12 +417,6 @@ HELP: clone
 { $values { "obj" object } { "cloned" "a new object" } }
 { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
 
-HELP: type ( object -- n )
-{ $values { "object" object } { "n" "a type number" } }
-{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
-
-{ type tag type>class } related-words
-
 HELP: ? ( ? true false -- true/false )
 { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
 { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
@@ -671,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@
@@ -682,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@
@@ -693,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 -- )
@@ -791,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 ;
+USING: kernel.private slots.private classes.tuple.private ;
 IN: kernel
 
 ! Stack stuff
@@ -99,14 +99,14 @@ DEFER: if
 
 ! Appliers
 : bi@ ( x y quot -- )
-    tuck 2slip call ; inline
+    dup bi* ; inline
 
 : tri@ ( x y z quot -- )
-    tuck >r bi@ r> call ; inline
+    dup dup tri* ; inline
 
 ! Double appliers
 : 2bi@ ( w x y z quot -- )
-    dup -roll 3slip call ; inline
+    dup 2bi* ; inline
 
 : while ( pred body tail -- )
     >r >r dup slip r> r> roll
@@ -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 )
@@ -194,8 +185,27 @@ GENERIC: construct-boa ( ... class -- tuple )
 
 <PRIVATE
 
+: hi-tag ( obj -- n ) 0 slot ; inline
+
 : declare ( spec -- ) drop ;
 
 : 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/layouts/layouts-docs.factor

@@ -14,7 +14,7 @@ HELP: tag-mask
 { $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
 
 HELP: num-types
-{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ;
+{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
 
 HELP: tag-number
 { $values { "class" class } { "n" "an integer or " { $link f } } }
@@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits
 
 ARTICLE: "layouts-types" "Type numbers"
 "Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsection type }
+{ $subsection hi-tag }
 "Built-in type numbers can be converted to classes, and vice versa:"
 { $subsection type>class }
 { $subsection type-number }

core/mirrors/mirrors-docs.factor

@@ -7,9 +7,6 @@ $nl
 "A mirror provides such a view of a tuple:"
 { $subsection mirror }
 { $subsection <mirror> }
-"An enum provides such a view of a sequence:"
-{ $subsection enum }
-{ $subsection <enum> }
 "Utility word used by developer tools which inspect objects:"
 { $subsection make-mirror }
 { $see-also "slots" } ;
@@ -44,11 +41,6 @@ HELP: >mirror<
 { $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
 { $description "Pushes the object being viewed in the mirror together with its slots." } ;
 
-HELP: enum
-{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
-$nl
-"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
-
 HELP: make-mirror
 { $values { "obj" object } { "assoc" assoc } }
 { $description "Creates an assoc which reflects the internal structure of the object." } ;

core/mirrors/mirrors.factor

@@ -48,27 +48,6 @@ M: mirror assoc-size mirror-slots length ;
 
 INSTANCE: mirror assoc
 
-TUPLE: enum seq ;
-
-C: <enum> enum
-
-M: enum at*
-    enum-seq 2dup bounds-check?
-    [ nth t ] [ 2drop f f ] if ;
-
-M: enum set-at enum-seq set-nth ;
-
-M: enum delete-at enum-seq delete-nth ;
-
-M: enum >alist ( enum -- alist )
-    enum-seq dup length swap 2array flip ;
-
-M: enum assoc-size enum-seq length ;
-
-M: enum clear-assoc enum-seq delete-all ;
-
-INSTANCE: enum assoc
-
 : sort-assoc ( assoc -- alist )
     >alist
     [ dup first unparse-short swap ] { } map>assoc

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,25 @@ DEFER: (flat-length)
     ] if ;
 
 ! Partial dispatch of math-generic words
+: normalize-math-class ( class -- class' )
+    {
+        fixnum bignum integer
+        ratio rational
+        float real
+        complex number
+        object
+    } [ class< ] with find nip ;
+
 : 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
@@ -87,29 +87,6 @@ sequences.private combinators ;
     { { @ @ } [ 2drop t ] }
 } define-identities
 
-! type applied to an object of a known type can be folded
-: known-type? ( node -- ? )
-    node-class-first class-types length 1 number= ;
-
-: fold-known-type ( node -- node )
-    dup node-class-first class-types inline-literals ;
-
-\ type [
-    { [ dup known-type? ] [ fold-known-type ] }
-] define-optimizers
-
-! if the result of type is n, then the object has type n
-{ tag type } [
-    [
-        num-types get swap [
-            [
-                [ type>class object or 0 `input class, ] keep
-                0 `output literal,
-            ] set-constraints
-        ] curry each
-    ] "constraints" set-word-prop
-] each
-
 ! Specializers
 { 1+ 1- sq neg recip sgn } [
     { number } "specializer" set-word-prop

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/optimizer/specializers/specializers.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic hashtables kernel kernel.private math
 namespaces sequences vectors words strings layouts combinators
-sequences.private classes generic.standard assocs ;
+sequences.private classes generic.standard
+generic.standard.engines assocs ;
 IN: optimizer.specializers
 
 : (make-specializer) ( class picker -- quot )

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?
@@ -467,18 +477,22 @@ SYMBOL: interactive-vocabs
         nl
     ] when 2drop ;
 
-: filter-moved ( assoc -- newassoc )
+: filter-moved ( assoc1 assoc2 -- seq )
-    [
+    diff [
         drop where dup [ first ] when
         file get source-file-path =
-    ] assoc-subset ;
+    ] assoc-subset keys ;
 
-: removed-definitions ( -- definitions )
+: removed-definitions ( -- assoc1 assoc2 )
     new-definitions old-definitions
-    [ get first2 union ] bi@ diff ;
+    [ get first2 union ] bi@ ;
+
+: removed-classes ( -- assoc1 assoc2 )
+    new-definitions old-definitions
+    [ get second ] bi@ ;
 
 : smudged-usage ( -- usages referenced removed )
-    removed-definitions filter-moved keys [
+    removed-definitions filter-moved [
         outside-usages
         [
             empty? [ drop f ] [
@@ -495,8 +509,10 @@ SYMBOL: interactive-vocabs
 : fix-class-words ( -- )
     #! If a class word had a compound definition which was
     #! removed, it must go back to being a symbol.
-    new-definitions get first2 diff
+    new-definitions get first2
-    [ nip dup reset-generic define-symbol ] assoc-each ;
+    filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each
+    removed-classes
+    filter-moved [ class? ] subset [ reset-class ] each ;
 
 : forget-smudged ( -- )
     smudged-usage forget-all
@@ -505,9 +521,10 @@ SYMBOL: interactive-vocabs
 
 : finish-parsing ( lines quot -- )
     file get
-    [ record-form ] keep
+    [ record-form ]
-    [ record-definitions ] keep
+    [ record-definitions ]
-    record-checksum ;
+    [ record-checksum ]
+    tri ;
 
 : parse-stream ( stream name -- quot )
     [

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

@@ -190,4 +190,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-docs.factor

@@ -324,11 +324,7 @@ HELP: constructor-word
 { $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." }
 { $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ;
 
-HELP: forget-word
+{ POSTPONE: FORGET: forget forget* forget-vocab } related-words
-{ $values { "word" word } }
-{ $description "Removes a word from its vocabulary. User code should call " { $link forget } " instead, since it also does the right thing when forgetting class words." } ;
-
-{ POSTPONE: FORGET: forget forget-word forget-vocab } related-words
 
 HELP: target-word
 { $values { "word" word } { "target" word } }

core/words/words.factor

@@ -63,10 +63,11 @@ SYMBOL: bootstrapping?
 : bootstrap-word ( word -- target )
     [ target-word ] [ ] if-bootstrapping ;
 
-: crossref? ( word -- ? )
+GENERIC: crossref? ( word -- ? )
+
+M: word crossref?
     {
         { [ dup "forgotten" word-prop ] [ f ] }
-        { [ dup "method-generic" word-prop ] [ t ] }
         { [ dup word-vocabulary ] [ t ] }
         { [ t ] [ f ] }
     } cond nip ;
@@ -172,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 ;
 
@@ -211,9 +212,7 @@ M: word where "loc" word-prop ;
 
 M: word set-where swap "loc" set-word-prop ;
 
-GENERIC: forget-word ( word -- )
+M: word forget*
-
-: (forget-word) ( word -- )
     dup "forgotten" word-prop [
         dup delete-xref
         dup delete-compiled-xref
@@ -221,10 +220,6 @@ GENERIC: forget-word ( word -- )
         dup t "forgotten" set-word-prop
     ] unless drop ;
 
-M: word forget-word (forget-word) ;
-
-M: word forget* forget-word ;
-
 M: word hashcode*
     nip 1 slot { fixnum } declare ;
 

extra/help/handbook/handbook.factor

@@ -152,6 +152,7 @@ ARTICLE: "collections" "Collections"
 "Implementations:"
 { $subsection "hashtables" }
 { $subsection "alists" }
+{ $subsection "enums" }
 { $heading "Other collections" }
 { $subsection "boxes" }
 { $subsection "dlists" }

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/io/unix/linux/linux.factor

@@ -20,8 +20,10 @@ TUPLE: inotify watches ;
 
 : <inotify> ( -- port/f )
     H{ } clone
-    inotify_init [ io-error ] [ inotify <buffered-port> ] bi
+    inotify_init dup 0 < [ 2drop f ] [
-    { set-inotify-watches set-delegate } inotify construct ;
+        inotify <buffered-port>
+        { set-inotify-watches set-delegate } inotify construct
+    ] if ;
 
 : inotify-fd inotify get-global handle>> ;
 
@@ -105,9 +107,12 @@ TUPLE: inotify-task ;
     f inotify-task <input-task> ;
 
 : init-inotify ( mx -- )
-    <inotify>
+    <inotify> dup [
         dup inotify set-global
-    <inotify-task> swap register-io-task ;
+        <inotify-task> swap register-io-task
+    ] [
+        2drop
+    ] if ;
 
 M: inotify-task do-io-task ( task -- )
     io-task-port read-notifications f ;
@@ -115,7 +120,7 @@ M: inotify-task do-io-task ( task -- )
 M: linux init-io ( -- )
     <select-mx>
     [ mx set-global ]
-    [ [ init-inotify ] curry ignore-errors ] bi ;
+    [ init-inotify ] bi ;
 
 linux set-io-backend
 

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/reports/noise/noise.factor

@@ -136,7 +136,7 @@ M: lambda-word word-noise-factor
 
 : flatten-generics ( words -- words' )
     [
-        dup generic? [ methods values ] [ 1array ] if
+        dup generic? [ "methods" word-prop values ] [ 1array ] if
     ] map concat ;
 
 : noisy-words ( -- alist )

extra/smtp/smtp-tests.factor

@@ -3,6 +3,12 @@ smtp.server kernel sequences namespaces logging accessors
 assocs sorting ;
 IN: smtp.tests
 
+[ t ] [
+    <email>
+    dup clone "a" "b" set-header drop
+    headers>> assoc-empty?
+] unit-test
+
 { 0 0 } [ [ ] with-smtp-connection ] must-infer-as
 
 [ "hello\nworld" validate-address ] must-fail

extra/smtp/smtp.factor

@@ -106,7 +106,7 @@ LOG: smtp-response DEBUG
 TUPLE: email from to subject headers body ;
 
 M: email clone
-    (clone) [ clone ] change-headers ;
+    call-next-method [ clone ] change-headers ;
 
 : (send) ( email -- )
     [

extra/tools/walker/walker.factor

@@ -3,7 +3,7 @@
 USING: threads kernel namespaces continuations combinators
 sequences math namespaces.private continuations.private
 concurrency.messaging quotations kernel.private words
-sequences.private assocs models ;
+sequences.private assocs models arrays accessors ;
 IN: tools.walker
 
 SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -51,9 +51,16 @@ DEFER: start-walker-thread
 : walk ( quot -- quot' )
     \ break prefix [ break rethrow ] recover ;
 
-: add-breakpoint ( quot -- quot' )
+GENERIC: add-breakpoint ( quot -- quot' )
+
+M: callable add-breakpoint
     dup [ break ] head? [ \ break prefix ] unless ;
 
+M: array add-breakpoint
+    [ add-breakpoint ] map ;
+
+M: object add-breakpoint ;
+
 : (step-into-quot) ( quot -- ) add-breakpoint call ;
 
 : (step-into-if) ? (step-into-quot) ;
@@ -74,7 +81,7 @@ DEFER: start-walker-thread
 \ (step-into-execute) t "step-into?" set-word-prop
 
 : (step-into-continuation)
-    continuation callstack over set-continuation-call break ;
+    continuation callstack >>call break ;
 
 ! Messages sent to walker thread
 SYMBOL: step
@@ -94,15 +101,18 @@ SYMBOL: +stopped+
 : change-frame ( continuation quot -- continuation' )
     #! Applies quot to innermost call frame of the
     #! continuation.
+    >r clone r> [
         >r clone r>
-    over continuation-call clone
         [
-        dup innermost-frame-scan 1+
+            >r
-        swap innermost-frame-quot
+            [ innermost-frame-scan 1+ ]
-        rot call
+            [ innermost-frame-quot ] bi
-    ] keep
+            r> call
-    [ set-innermost-frame-quot ] keep
+        ]
-    over set-continuation-call ; inline
+        [ drop set-innermost-frame-quot ]
+        [ drop ]
+        2tri
+    ] curry change-call ; inline
 
 : step-msg ( continuation -- continuation' )
     [
@@ -143,6 +153,7 @@ SYMBOL: +stopped+
             swap % unclip {
                 { [ dup \ break eq? ] [ , ] }
                 { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+                { [ dup array? ] [ add-breakpoint , \ break , ] }
                 { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
                 { [ t ] [ , \ break , ] }
             } cond %
@@ -177,16 +188,17 @@ SYMBOL: +stopped+
                 { step-back [ f ] }
                 { f [ +stopped+ set-status f ] }
                 [
-                    dup walker-continuation tget set-model
+                    [ walker-continuation tget set-model ]
-                    step-into-msg
+                    [ step-into-msg ] bi
                 ]
             } case
         ] handle-synchronous
     ] [ ] while ;
 
 : step-back-msg ( continuation -- continuation' )
-    walker-history tget dup pop*
+    walker-history tget
-    empty? [ drop walker-history tget pop ] unless ;
+    [ pop* ]
+    [ dup empty? [ drop ] [ nip pop ] if ] bi ;
 
 : walker-suspended ( continuation -- continuation' )
     +suspended+ set-status

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*

license.txt

@@ -1,24 +1,22 @@
-/*
+Copyright (C) 2003, 2008 Slava Pestov and friends.
- * Copyright (C) 2003, 2007 Slava Pestov and friends.
+
- *
+Redistribution and use in source and binary forms, with or without
- * Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
- * modification, are permitted provided that the following conditions are met:
+
- *
+1. Redistributions of source code must retain the above copyright notice,
- * 1. Redistributions of source code must retain the above copyright notice,
+   this list of conditions and the following disclaimer.
- *    this list of conditions and the following disclaimer.
+
- *
+2. Redistributions in binary form must reproduce the above copyright notice,
- * 2. Redistributions in binary form must reproduce the above copyright notice,
+   this list of conditions and the following disclaimer in the documentation
- *    this list of conditions and the following disclaimer in the documentation
+   and/or other materials provided with the distribution.
- *    and/or other materials provided with the distribution.
+
- *
+THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
- * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
- * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
- * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
- * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
- * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- */

vm/data_gc.c

@@ -730,7 +730,6 @@ void garbage_collection(CELL gen,
 
 	/* collect objects referenced from stacks and environment */
 	collect_roots();
-	
 	/* collect objects referenced from older generations */
 	collect_cards();
 

vm/factor.c

@@ -36,22 +36,36 @@ void do_stage1_init(void)
 	fprintf(stderr,"*** Stage 2 early init... ");
 	fflush(stderr);
 
+	GROWABLE_ARRAY(words);
+
 	begin_scan();
 
 	CELL obj;
 	while((obj = next_object()) != F)
 	{
 		if(type_of(obj) == WORD_TYPE)
-		{
+			GROWABLE_ADD(words,obj);
-			F_WORD *word = untag_object(obj);
-			default_word_code(word,false);
-			update_word_xt(word);
-		}
 	}
 
 	/* End heap scan */
 	gc_off = false;
 
+	GROWABLE_TRIM(words);
+	REGISTER_ROOT(words);
+
+	CELL i;
+	CELL length = array_capacity(untag_object(words));
+	for(i = 0; i < length; i++)
+	{
+		F_WORD *word = untag_word(array_nth(untag_array(words),i));
+		REGISTER_UNTAGGED(word);
+		default_word_code(word,false);
+		UNREGISTER_UNTAGGED(word);
+		update_word_xt(word);
+	}
+
+	UNREGISTER_ROOT(words);
+
 	iterate_code_heap(relocate_code_block);
 
 	userenv[STAGE2_ENV] = T;

vm/primitives.c

@@ -106,7 +106,6 @@ void *primitives[] = {
 	primitive_code_room,
 	primitive_os_env,
 	primitive_millis,
-	primitive_type,
 	primitive_tag,
 	primitive_modify_code_heap,
 	primitive_dlopen,
@@ -178,7 +177,6 @@ void *primitives[] = {
 	primitive_sleep,
 	primitive_float_array,
 	primitive_tuple_boa,
-	primitive_class_hash,
 	primitive_callstack_to_array,
 	primitive_innermost_stack_frame_quot,
 	primitive_innermost_stack_frame_scan,

vm/run.c

@@ -22,8 +22,11 @@ void fix_stacks(void)
 be stored in registers, so callbacks must save and restore the correct values */
 void save_stacks(void)
 {
+	if(stack_chain)
+	{
 		stack_chain->datastack = ds;
 		stack_chain->retainstack = rs;
+	}
 }
 
 /* called on entry into a compiled callback */
@@ -304,32 +307,11 @@ DEFINE_PRIMITIVE(sleep)
 	sleep_millis(to_cell(dpop()));
 }
 
-DEFINE_PRIMITIVE(type)
-{
-	drepl(tag_fixnum(type_of(dpeek())));
-}
-
 DEFINE_PRIMITIVE(tag)
 {
 	drepl(tag_fixnum(TAG(dpeek())));
 }
 
-DEFINE_PRIMITIVE(class_hash)
-{
-	CELL obj = dpeek();
-	CELL tag = TAG(obj);
-	if(tag == TUPLE_TYPE)
-	{
-		F_TUPLE *tuple = untag_object(obj);
-		F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
-		drepl(layout->hashcode);
-	}
-	else if(tag == OBJECT_TYPE)
-		drepl(get(UNTAG(obj)));
-	else
-		drepl(tag_fixnum(tag));
-}
-
 DEFINE_PRIMITIVE(slot)
 {
 	F_FIXNUM slot = untag_fixnum_fast(dpop());

vm/run.h

@@ -253,9 +253,7 @@ DECLARE_PRIMITIVE(set_os_envs);
 DECLARE_PRIMITIVE(eq);
 DECLARE_PRIMITIVE(millis);
 DECLARE_PRIMITIVE(sleep);
-DECLARE_PRIMITIVE(type);
 DECLARE_PRIMITIVE(tag);
-DECLARE_PRIMITIVE(class_hash);
 DECLARE_PRIMITIVE(slot);
 DECLARE_PRIMITIVE(set_slot);