Debugging inheritancE

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/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 ;
 

core/classes/classes.factor

@@ -83,7 +83,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 +92,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,24 +109,22 @@ 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 )
 

core/classes/predicate/predicate.factor

@@ -14,9 +14,14 @@ 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
     {

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
 

core/classes/tuple/tuple.factor

@@ -161,25 +161,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 -- )
     [
@@ -214,6 +212,9 @@ M: tuple-class define-tuple-class
     [ define-tuple-class ] [ 2drop ] 3bi
     dup [ construct-boa throw ] curry define ;
 
+M: tuple-class reset-class
+    { "metaclass" "superclass" "slots" "layout" } reset-props ;
+
 M: tuple clone
     (clone) dup delegate clone over set-delegate ;
 
@@ -227,12 +228,6 @@ M: tuple hashcode*
         ] 2curry reduce
     ] recursive-hashcode ;
 
-M: tuple-class reset-class
-    { "metaclass" "superclass" "slots" "layout" } reset-props ;
-
-M: object get-slots ( obj slots -- ... )
-    [ execute ] with each ;
-
 M: object construct-empty ( class -- tuple )
     tuple-layout <tuple> ;
 
@@ -240,6 +235,9 @@ M: object construct-boa ( ... class -- tuple )
     tuple-layout <tuple-boa> ;
 
 ! Deprecated
+M: object get-slots ( obj slots -- ... )
+    [ execute ] with each ;
+
 M: object set-slots ( ... obj slots -- )
     <reversed> get-slots ;
 

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 ;

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

@@ -63,15 +63,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"

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

@@ -1,7 +1,6 @@
 USING: classes.private generic.standard.engines namespaces
-arrays mirrors assocs sequences.private quotations
+arrays assocs sequences.private quotations kernel.private
-kernel.private layouts math slots.private math.private
+layouts math slots.private math.private kernel accessors ;
-kernel accessors ;
 IN: generic.standard.engines.tag
 
 TUPLE: lo-tag-dispatch-engine methods ;

core/generic/standard/new/new.factor

@@ -1,145 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-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 generic.standard.engines
-generic.standard.engines.tag generic.standard.engines.predicate
-generic.standard.engines.tuple accessors ;
-IN: generic.standard.new
-
-: unpickers
-    {
-        [ nip ]
-        [ >r nip r> swap ]
-        [ >r >r nip r> r> -rot ]
-    } ; inline
-
-: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
-
-ERROR: no-method object generic ;
-
-: error-method ( word -- quot )
-    picker swap [ no-method ] curry append ;
-
-: empty-method ( word -- quot )
-    [
-        picker % [ delegate dup ] %
-        unpicker over suffix ,
-        error-method \ drop prefix , \ if ,
-    ] [ ] make ;
-
-: default-method ( word -- pair )
-    "default-method" word-prop
-    object bootstrap-word swap 2array ;
-
-: push-method ( method specializer atomic assoc -- )
-    [
-        [ H{ } clone <predicate-dispatch-engine> ] unless*
-        [ methods>> set-at ] keep
-    ] change-at ;
-
-: flatten-method ( class method assoc -- )
-    >r >r dup flatten-class keys swap r> r> [
-        >r spin r> push-method
-    ] 3curry each ;
-
-: flatten-methods ( assoc -- assoc' )
-    H{ } clone [
-        [
-            flatten-method
-        ] curry assoc-each
-    ] keep ;
-
-: <big-dispatch-engine> ( assoc -- engine )
-    flatten-methods
-    convert-tuple-methods
-    convert-hi-tag-methods
-    <lo-tag-dispatch-engine> ;
-
-: find-default ( methods -- quot )
-    #! Side-effects methods.
-    object swap delete-at* [
-        drop generic get "default-method" word-prop
-    ] unless 1quotation ;
-
-GENERIC: mangle-method ( method generic -- quot )
-
-: single-combination ( words -- quot )
-    [
-        object bootstrap-word assumed set
-        [ generic set ]
-        [
-            "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
-        ] bi
-    ] with-scope ;
-
-TUPLE: standard-combination # ;
-
-C: <standard-combination> standard-combination
-
-PREDICATE: standard-generic < generic
-    "combination" word-prop standard-combination? ;
-
-PREDICATE: simple-generic < standard-generic
-    "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 ;
-
-M: standard-generic mangle-method
-    drop ;
-
-M: standard-combination make-default-method
-    [ empty-method ] with-standard ;
-
-M: standard-combination perform-combination
-    [ single-combination ] with-standard ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-PREDICATE: hook-generic < generic
-    "combination" word-prop hook-combination? ;
-
-: with-hook ( combination quot -- quot' )
-    0 (dispatch#) [
-        dip var>> [ get ] curry prepend
-    ] with-variable ; inline
-
-M: hook-generic mangle-method
-    drop [ drop ] prepend ;
-
-M: hook-combination make-default-method
-    [ error-method ] with-hook ;
-
-M: hook-combination perform-combination
-    [ single-combination ] with-hook ;
-
-GENERIC: dispatch# ( word -- n )
-
-M: word dispatch# "combination" word-prop dispatch# ;
-
-M: standard-combination dispatch# #>> ;
-
-M: hook-combination dispatch# drop 0 ;
-
-M: simple-generic definer drop \ GENERIC: f ;
-
-M: standard-generic definer drop \ GENERIC# f ;
-
-M: hook-generic definer drop \ HOOK: f ;

core/generic/standard/standard-tests.factor

@@ -1,10 +1,8 @@
-IN: generic.standard.new.tests
+IN: generic.standard.tests
 USING: tools.test math math.functions math.constants
-generic.standard.new strings sequences arrays kernel accessors
+generic.standard strings sequences arrays kernel accessors
 words float-arrays byte-arrays bit-arrays parser ;
 
-<< : GENERIC: CREATE-GENERIC define-simple-generic ; parsing >>
-
 GENERIC: lo-tag-test
 
 M: integer lo-tag-test 3 + ;
@@ -24,7 +22,7 @@ GENERIC: hi-tag-test
 
 M: string hi-tag-test ", in bed" append ;
 
-M: number hi-tag-test 3 + ;
+M: integer hi-tag-test 3 + ;
 
 M: array hi-tag-test [ hi-tag-test ] map ;
 

core/generic/standard/standard.factor

@@ -3,32 +3,23 @@
 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 # ;
+: unpickers
-
-C: <standard-combination> standard-combination
-
-SYMBOL: (dispatch#)
-
-: (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 ;
 
 ERROR: no-method object generic ;
 
-: error-method ( word --  quot )
+: error-method ( word -- quot )
     picker swap [ no-method ] curry append ;
 
 : empty-method ( word -- quot )
@@ -38,144 +29,112 @@ ERROR: no-method object generic ;
         error-method \ drop prefix , \ if ,
     ] [ ] make ;
 
-: class-predicates ( assoc -- assoc )
-    [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
-
-: simplify-alist ( class assoc -- default assoc' )
-    {
-        { [ dup empty? ] [ 2drop [ "Unreachable" throw ] { } ] }
-        { [ dup length 1 = ] [ nip first second { } ] }
-        { [ 2dup second first class< ] [ 1 tail-slice simplify-alist ] }
-        { [ t ] [ nip [ first second ] [ 1 tail-slice ] bi ] }
-    } cond ;
-
 : 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 ;
+    flatten-methods
+    convert-tuple-methods
+    convert-hi-tag-methods
+    <lo-tag-dispatch-engine> ;
 
-: single-combination ( methods -- quot )
+: find-default ( methods -- quot )
-    dup length 4 <= [
+    #! Side-effects methods.
-        small-generic
+    object swap delete-at* [
-    ] [
+        drop generic get "default-method" word-prop 1quotation
-        flatten-methods
+    ] unless ;
-        dup dispatched-types [ number class< ] all?
-        [ tag-generic ] [ big-generic ] if
-    ] if ;
 
-: standard-methods ( word -- alist )
+GENERIC: mangle-method ( method generic -- quot )
-    dup methods swap default-method prefix
-    [ 1quotation ] assoc-map ;
 
-M: standard-combination make-default-method
+: single-combination ( words -- quot )
-    standard-combination-# (dispatch#)
-    [ empty-method ] with-variable ;
-
-M: standard-combination perform-combination
-    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
+        [
-    ] with-hook ;
+            "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
+        ] bi
+    ] 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 ;
+
+M: standard-generic mangle-method
+    drop 1quotation ;
+
+M: standard-combination make-default-method
+    [ empty-method ] with-standard ;
+
+M: standard-combination perform-combination
+    [ single-combination ] with-standard ;
+
+TUPLE: hook-combination var ;
+
+C: <hook-combination> hook-combination
 
 PREDICATE: hook-generic < generic
     "combination" word-prop hook-combination? ;
 
+: with-hook ( combination quot -- quot' )
+    0 (dispatch#) [
+        dip var>> [ get ] curry prepend
+    ] with-variable ; inline
+
+M: hook-generic mangle-method
+    drop 1quotation [ drop ] prepend ;
+
+M: hook-combination make-default-method
+    [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+    [ single-combination ] with-hook ;
+
 GENERIC: dispatch# ( word -- n )
 
 M: word dispatch# "combination" word-prop dispatch# ;
 
-M: standard-combination dispatch# standard-combination-# ;
+M: standard-combination dispatch# #>> ;
 
 M: hook-combination dispatch# drop 0 ;
 

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/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 )