Fixing new method dispatch implementation

basis/compiler/compiler.factor

@@ -15,18 +15,17 @@ IN: compiler
 SYMBOL: compile-queue
 SYMBOL: compiled
 
-: queue-compile? ( word -- ? )
+: compile? ( word -- ? )
     #! Don't attempt to compile certain words.
     {
         [ "forgotten" word-prop ]
         [ compiled get key? ]
-        [ single-generic? ]
         [ inlined-block? ]
         [ primitive? ]
     } 1|| not ;
 
 : queue-compile ( word -- )
-    dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
+    dup compile? [ compile-queue get push-front ] [ drop ] if ;
 
 : recompile-callers? ( word -- ? )
     changed-effects get key? ;
@@ -43,6 +42,14 @@ SYMBOL: compiled
     H{ } clone generic-dependencies set
     clear-compiler-error ;
 
+GENERIC: no-compile? ( word -- ? )
+
+M: word no-compile? "no-compile" word-prop ;
+
+M: method-body no-compile? "method-generic" word-prop no-compile? ;
+
+M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
+
 : ignore-error? ( word error -- ? )
     #! Ignore some errors on inline combinators, macros, and special
     #! words such as 'call'.
@@ -50,8 +57,8 @@ SYMBOL: compiled
         {
             [ macro? ]
             [ inline? ]
+            [ no-compile? ]
             [ "special" word-prop ]
-            [ "no-compile" word-prop ]
         } 1||
     ] [
         {
@@ -98,12 +105,16 @@ SYMBOL: compiled
         2bi
     ] if ;
 
+: optimize? ( word -- ? )
+    { [ contains-breakpoints? ] [ single-generic? ] } 1|| not ;
+
 : frontend ( word -- nodes )
     #! If the word contains breakpoints, don't optimize it, since
     #! the walker does not support this.
-    dup contains-breakpoints? [ dup def>> deoptimize-with ] [
+    dup optimize?
-        [ build-tree ] [ deoptimize ] recover optimize-tree
+    [ [ build-tree ] [ deoptimize ] recover optimize-tree ]
-    ] if ;
+    [ dup def>> deoptimize-with ]
+    if ;
 
 : compile-dependency ( word -- )
     #! If a word calls an unoptimized word, try to compile the callee.

basis/debugger/debugger-docs.factor

@@ -1,6 +1,6 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations io.files.private listener
+help generic.single continuations io.files.private listener
 alien.libraries ;
 IN: debugger
 

basis/listener/listener.factor

@@ -62,6 +62,8 @@ SYMBOL: max-stack-items
 
 SYMBOL: error-summary?
 
+t error-summary? set-global
+
 <PRIVATE
 
 : title. ( string -- )

basis/stack-checker/known-words/known-words.factor

@@ -228,16 +228,8 @@ M: object infer-call*
 
 ! More words not to compile
 \ call t "no-compile" set-word-prop
-\ call subwords [ t "no-compile" set-word-prop ] each
-
 \ execute t "no-compile" set-word-prop
-\ execute subwords [ t "no-compile" set-word-prop ] each
-
-\ effective-method t "no-compile" set-word-prop
-\ effective-method subwords [ t "no-compile" set-word-prop ] each
-
 \ execute-unsafe t "no-compile" set-word-prop
-
 \ clear t "no-compile" set-word-prop
 
 : non-inline-word ( word -- )

basis/stack-checker/transforms/transforms.factor

@@ -108,7 +108,6 @@ IN: stack-checker.transforms
 ] 1 define-transform
 
 \ boa t "no-compile" set-word-prop
-M\ tuple-class boa t "no-compile" set-word-prop
 
 \ new [
     dup tuple-class? [

basis/tools/continuations/continuations.factor

@@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
 sequences math namespaces.private continuations.private
 concurrency.messaging quotations kernel.private words
 sequences.private assocs models models.arrow arrays accessors
-generic generic.standard definitions make sbufs tools.crossref ;
+generic generic.single definitions make sbufs tools.crossref ;
 IN: tools.continuations
 
 <PRIVATE
@@ -53,8 +53,7 @@ M: object add-breakpoint ;
 : (step-into-execute) ( word -- )
     {
         { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
-        { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
+        { [ dup single-generic? ] [ effective-method (step-into-execute) ] }
-        { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
         { [ dup uses \ suspend swap member? ] [ execute break ] }
         { [ dup primitive? ] [ execute break ] }
         [ def>> (step-into-quot) ]

basis/ui/tools/error-list/error-list.factor

@@ -10,7 +10,7 @@ ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures
 ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
 ui.tools.inspector ui.gadgets.status-bar ui.operations
 ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
-ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener
+ui.gadgets.labels ui.baseline-alignment ui.images
 compiler.errors tools.errors tools.errors.model ;
 IN: ui.tools.error-list
 

basis/ui/tools/listener/completion/completion.factor

@@ -8,8 +8,7 @@ definitions.icons ui.images ui.commands ui.operations ui.gadgets
 ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers
 ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled
 ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid
-ui.tools.listener.history combinators vocabs ui.tools.listener.popups
+ui.tools.listener.history combinators vocabs ui.tools.listener.popups ;
- ;
 IN: ui.tools.listener.completion
 
 ! We don't directly depend on the listener tool but we use a few slots
@@ -120,8 +119,6 @@ M: object completion-string present ;
 
 M: method-body completion-string method-completion-string ;
 
-M: engine-word completion-string method-completion-string ;
-
 GENERIC# accept-completion-hook 1 ( item popup -- )
 
 : insert-completion ( item popup -- )

core/classes/tuple/tuple-tests.factor

@@ -1,11 +1,11 @@
-USING: definitions generic kernel kernel.private math
+USING: definitions generic kernel kernel.private math math.constants
-math.constants parser sequences tools.test words assocs
+parser sequences tools.test words assocs namespaces quotations
-namespaces quotations sequences.private classes continuations
+sequences.private classes continuations generic.single
-generic.standard effects classes.tuple classes.tuple.private
+generic.standard effects classes.tuple classes.tuple.private arrays
-arrays vectors strings compiler.units accessors classes.algebra
+vectors strings compiler.units accessors classes.algebra calendar
-calendar prettyprint io.streams.string splitting summary
+prettyprint io.streams.string splitting summary columns math.order
-columns math.order classes.private slots slots.private eval see
+classes.private slots slots.private eval see words.symbol
-words.symbol compiler.errors ;
+compiler.errors ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;

core/generic/generic-docs.factor

@@ -1,6 +1,7 @@
 USING: help.markup help.syntax words classes classes.algebra
 definitions kernel alien sequences math quotations
-generic.standard generic.math combinators prettyprint effects ;
+generic.single generic.standard generic.hook generic.math
+combinators prettyprint effects ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"

core/generic/hook/hook.factor

@@ -17,3 +17,6 @@ M: hook-combination picker
 M: hook-combination dispatch# drop 0 ;
 
 M: hook-generic definer drop \ HOOK: f ;
+
+M: hook-generic effective-method
+    [ "combination" word-prop var>> get ] keep (effective-method) ;

core/generic/single/single-tests.factor

@@ -1,11 +1,10 @@
-IN: generic.standard.tests
+IN: generic.single.tests
-USING: tools.test math math.functions math.constants
+USING: tools.test math math.functions math.constants generic.standard
-generic.standard strings sequences arrays kernel accessors words
+generic.single strings sequences arrays kernel accessors words
-specialized-arrays.double byte-arrays bit-arrays parser
+specialized-arrays.double byte-arrays bit-arrays parser namespaces
-namespaces make quotations stack-checker vectors growable
+make quotations stack-checker vectors growable hashtables sbufs
-hashtables sbufs prettyprint byte-vectors bit-vectors
+prettyprint byte-vectors bit-vectors specialized-vectors.double
-specialized-vectors.double definitions generic sets graphs assocs
+definitions generic sets graphs assocs grouping see ;
-grouping see ;
 
 GENERIC: lo-tag-test ( obj -- obj' )
 
@@ -249,23 +248,6 @@ M: string my-hook "a string" ;
 [ "a string" ] [ my-hook my-var set my-hook ] unit-test
 [ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
 
-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?
-] unit-test
-
 HOOK: call-next-hooker my-var ( -- x )
 
 M: sequence call-next-hooker "sequence" ;
@@ -281,7 +263,7 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
 ] unit-test
 
 [ t ] [
-    { } \ nth effective-method nip \ sequence \ nth method eq?
+    { } \ nth effective-method nip M\ sequence nth eq?
 ] unit-test
 
 [ t ] [

core/generic/single/single.factor

@@ -42,16 +42,13 @@ M: single-combination next-method-quot*
         ] [ 3drop f ] if
     ] with-combination ;
 
-: single-effective-method ( obj word -- method )
+: (effective-method) ( obj word -- method )
     [ [ order [ instance? ] with find-last nip ] keep method ]
     [ "default-method" word-prop ]
     bi or ;
 
-M: single-generic effective-method
-    [ [ picker ] with-combination call ] keep single-effective-method ;
-
 M: single-combination make-default-method
-    combination [ [ picker ] dip [ no-method ] curry append ] with-variable ;
+    [ [ picker ] dip [ no-method ] curry append ] with-combination ;
 
 ! ! ! Build an engine ! ! !
 
@@ -101,7 +98,10 @@ TUPLE: tuple-dispatch-engine echelons ;
     [ ?set-at ] change-at ;
 
 : echelon-sort ( assoc -- assoc' )
-    H{ } clone [ [ push-echelon ] curry assoc-each ] keep ;
+    #! Convert an assoc mapping classes to methods into an
+    #! assoc mapping echelons to assocs. The first echelon
+    #! is always there
+    H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
 
 : <tuple-dispatch-engine> ( methods -- engine )
     echelon-sort
@@ -127,9 +127,13 @@ TUPLE: tag-dispatch-engine methods ;
 C: <tag-dispatch-engine> tag-dispatch-engine
 
 : <engine> ( assoc -- engine )
+    dup keys [ not ] filter [ "FOO" throw ] unless-empty
     flatten-methods
+    dup keys [ not ] filter [ "FOO1" throw ] unless-empty
     convert-tuple-methods
+    dup keys [ not ] filter [ "FOO2" throw ] unless-empty
     convert-hi-tag-methods
+    dup keys [ not ] filter [ "FOO3" throw ] unless-empty
     <tag-dispatch-engine> ;
 
 ! ! ! Compile engine ! ! !
@@ -146,7 +150,7 @@ GENERIC: compile-engine ( engine -- obj )
 
 M: tag-dispatch-engine compile-engine
     methods>> compile-engines*
-    [ [ tag-number ] dip ] assoc-map
+    [ [ global [ target-word ] bind tag-number ] dip ] assoc-map
     num-tags get direct-dispatch-table ;
 
 : hi-tag-number ( class -- n ) "type" word-prop ;
@@ -159,16 +163,23 @@ M: hi-tag-dispatch-engine compile-engine
     num-hi-tags direct-dispatch-table ;
 
 : build-fast-hash ( methods -- buckets )
-    >alist V{ } clone [ hashcode 1array ] distribute-buckets
+    V{ } clone [ hashcode 1array ] distribute-buckets
     [ compile-engines* >alist >array ] map ;
 
 M: echelon-dispatch-engine compile-engine
-    methods>> compile-engines* build-fast-hash ;
+    dup n>> 0 = [
+        methods>> dup assoc-size {
+            { 0 [ drop default get ] }
+            { 1 [ >alist first second compile-engine ] }
+        } case
+    ] [
+        methods>> compile-engines* build-fast-hash
+    ] if ;
 
 M: tuple-dispatch-engine compile-engine
     tuple assumed [
         echelons>> compile-engines
-        dup keys supremum f <array> default get prefix
+        dup keys supremum 1+ f <array>
         [ <enum> swap update ] keep
     ] with-variable ;
 

core/generic/standard/standard.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors definitions generic generic.single kernel
-namespaces words math combinators ;
+namespaces words math combinators sequences ;
 IN: generic.standard
 
 TUPLE: standard-combination < single-combination # ;
@@ -32,6 +32,10 @@ M: standard-combination picker
 
 M: standard-combination dispatch# #>> ;
 
-M: simple-generic definer drop \ GENERIC: f ;
+M: standard-generic effective-method
+    [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
+    (effective-method) ;
 
 M: standard-generic definer drop \ GENERIC# f ;
+
+M: simple-generic definer drop \ GENERIC: f ;

core/layouts/layouts.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math words kernel assocs classes
 math.order kernel.private ;
@@ -16,12 +16,12 @@ SYMBOL: tag-numbers
 
 SYMBOL: type-numbers
 
-: tag-number ( class -- n )
-    tag-numbers get at [ object tag-number ] unless* ;
-
 : type-number ( class -- n )
     type-numbers get at ;
 
+: tag-number ( class -- n )
+    type-number dup num-tags get >= [ drop object tag-number ] when ;
+
 : tag-fixnum ( n -- tagged )
     tag-bits get shift ;
 

core/sequences/sequences-docs.factor

@@ -1,6 +1,6 @@
 USING: arrays help.markup help.syntax math
 sequences.private vectors strings kernel math.order layouts
-quotations generic.standard ;
+quotations generic.single ;
 IN: sequences
 
 HELP: sequence
@@ -1466,8 +1466,8 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
 { $subsection produce }
 { $subsection produce-as }
 "Filtering:"
-{ $subsection push-if }
 { $subsection filter }
+{ $subsection partition }
 "Testing if a sequence contains elements satisfying a predicate:"
 { $subsection any? }
 { $subsection all? }