Don't emit first engine in the sequence

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

@@ -1,8 +1,11 @@
-IN: generic.standard.engines.tuple
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
 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 ;
+classes.algebra math math.private kernel.private
+quotations arrays ;
+IN: generic.standard.engines.tuple
 
 TUPLE: echelon-dispatch-engine n methods ;
 
@@ -28,13 +31,13 @@ TUPLE: tuple-dispatch-engine echelons ;
 : <tuple-dispatch-engine> ( methods -- engine )
     echelon-sort
     [
-        over zero? [
+        ! over zero? [
-            dup assoc-empty?
+        !     dup assoc-empty?
-            [ drop f ] [ values first ] if
+        !     [ drop f ] [ values first ] if
-        ] [
+        ! ] [
             dupd <echelon-dispatch-engine>
-        ] if
+        ! ] if
-    ] assoc-map [ nip ] assoc-subset
+    ] assoc-map ! [ nip ] assoc-subset
     \ tuple-dispatch-engine boa ;
 
 : convert-tuple-methods ( assoc -- assoc' )
@@ -48,52 +51,51 @@ M: trivial-tuple-dispatch-engine engine>quot
     >alist V{ } clone [ hashcode 1array ] distribute-buckets
     [ <trivial-tuple-dispatch-engine> ] map ;
 
+: word-hashcode% [ 1 slot ] % ;
+
 : class-hash-dispatch-quot ( methods -- quot )
-    #! 1 slot == word hashcode
     [
-        [ dup 1 slot ] %
+        \ dup ,
+        word-hashcode%
         hash-methods [ engine>quot ] map hash-dispatch-quot %
     ] [ ] make ;
 
-: tuple-dispatch-engine-word-name ( engine -- string )
+: engine-word-name ( -- string )
-    [
+    generic get word-name "/tuple-dispatch-engine" append ;
-        generic get word-name %
-        "/tuple-dispatch-engine/" %
-        n>> #
-    ] "" make ;
 
-PREDICATE: tuple-dispatch-engine-word < word
+PREDICATE: engine-word < word
     "tuple-dispatch-generic" word-prop generic? ;
 
-M: tuple-dispatch-engine-word stack-effect
+M: engine-word stack-effect
     "tuple-dispatch-generic" word-prop
     [ extra-values ] [ stack-effect ] bi
     dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
 
-M: tuple-dispatch-engine-word compiled-crossref?
+M: engine-word compiled-crossref?
     drop t ;
 
 : remember-engine ( word -- )
     generic get "engines" word-prop push ;
 
-: <tuple-dispatch-engine-word> ( engine -- word )
+: <engine-word> ( -- word )
-    tuple-dispatch-engine-word-name f <word>
+    engine-word-name f <word>
-    [ generic get "tuple-dispatch-generic" set-word-prop ]
+    dup generic get "tuple-dispatch-generic" set-word-prop ;
-    [ remember-engine ]
-    [ ]
-    tri ;
 
-: define-tuple-dispatch-engine-word ( engine quot -- word )
+: define-engine-word ( quot -- word )
-    >r <tuple-dispatch-engine-word> dup r> define ;
+    >r <engine-word> dup r> define ;
+
+: array-nth% 2 + , [ slot { word } declare ] % ;
+
+: tuple-layout-superclasses ( obj -- array )
+    { tuple } declare
+    1 slot { tuple-layout } declare
+    4 slot { array } declare ; inline
 
 : tuple-dispatch-engine-body ( engine -- quot )
-    #! 1 slot == tuple-layout
-    #! 2 slot == 0 array-nth
-    #! 4 slot == layout-superclasses
     [
         picker %
-        [ 1 slot 4 slot ] %
+        [ tuple-layout-superclasses ] %
-        [ n>> 2 + , [ slot ] % ]
+        [ n>> array-nth% ]
         [
             methods>> [
                 <trivial-tuple-dispatch-engine> engine>quot
@@ -104,25 +106,54 @@ M: tuple-dispatch-engine-word compiled-crossref?
     ] [ ] make ;
 
 M: echelon-dispatch-engine engine>quot
-    dup tuple-dispatch-engine-body
+    dup n>> zero? [
-    define-tuple-dispatch-engine-word
+        methods>> dup assoc-empty?
-    1quotation ;
+        [ drop default get ] [ values first engine>quot ] if
+    ] [
+        [
+            picker %
+            [ tuple-layout-superclasses ] %
+            [ n>> array-nth% ]
+            [
+                methods>> [
+                    <trivial-tuple-dispatch-engine> engine>quot
+                ] [
+                    class-hash-dispatch-quot
+                ] if-small? %
+            ] bi
+        ] [ ] make
+    ] if ;
 
 : >=-case-quot ( alist -- quot )
     default get [ drop ] prepend swap
     [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
     alist>quot ;
 
+: tuple-layout-echelon ( obj -- array )
+    { tuple } declare
+    1 slot { tuple-layout } declare
+    5 slot ; inline
+
+: unclip-last [ 1 head* ] [ peek ] bi ;
+
 M: tuple-dispatch-engine engine>quot
-    #! 1 slot == tuple-layout
-    #! 5 slot == layout-echelon
     [
         picker %
-        [ 1 slot 5 slot ] %
+        [ tuple-layout-echelon ] %
-        echelons>>
         [
             tuple assumed set
-            [ engine>quot dup default set ] assoc-map
+            echelons>> dup empty? [
+                unclip-last
+                [
+                    [
+                        engine>quot define-engine-word
+                        [ remember-engine ] [ 1quotation ] bi
+                        dup default set
+                    ] assoc-map
+                ]
+                [ first2 engine>quot 2array ] bi*
+                suffix
+            ] unless
         ] with-scope
         >=-case-quot %
     ] [ ] make ;

core/generic/standard/standard-tests.factor

@@ -251,6 +251,14 @@ HOOK: my-tuple-hook my-var ( -- x )
 
 M: sequence my-tuple-hook my-hook ;
 
+TUPLE: m-t-h-a ;
+
+M: m-t-h-a my-tuple-hook "foo" ;
+
+TUPLE: m-t-h-b < m-t-h-a ;
+
+M: m-t-h-b my-tuple-hook "bar" ;
+
 [ f ] [
     \ my-tuple-hook [ "engines" word-prop ] keep prefix
     [ 1quotation infer ] map all-equal?