Fleshed out new dispatch code

basis/compiler/compiler.factor

@@ -2,13 +2,14 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces arrays sequences io words fry
 continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io source-files.errors
+generic.single combinators deques search-deques macros io
-stack-checker stack-checker.state stack-checker.inlining
+source-files.errors stack-checker stack-checker.state
-stack-checker.errors combinators.short-circuit compiler.errors
+stack-checker.inlining stack-checker.errors combinators.short-circuit
-compiler.units compiler.tree.builder compiler.tree.optimizer
+compiler.errors compiler.units compiler.tree.builder
-compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.two-operand compiler.cfg.linear-scan
+compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
+compiler.utilities ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -19,6 +20,7 @@ SYMBOL: compiled
     {
         [ "forgotten" word-prop ]
         [ compiled get key? ]
+        [ single-generic? ]
         [ inlined-block? ]
         [ primitive? ]
     } 1|| not ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel arrays sequences math math.order
-math.partial-dispatch generic generic.standard generic.math
+math.partial-dispatch generic generic.standard generic.single generic.math
 classes.algebra classes.union sets quotations assocs combinators
 words namespaces continuations classes fry combinators.smart hints
 locals

basis/debugger/debugger.factor

@@ -6,7 +6,7 @@ sequences assocs sequences.private strings io.styles
 io.pathnames vectors words system splitting math.parser
 classes.mixin classes.tuple continuations continuations.private
 combinators generic.math classes.builtin classes compiler.units
-generic.standard vocabs init kernel.private io.encodings
+generic.standard generic.single vocabs init kernel.private io.encodings
 accessors math.order destructors source-files parser
 classes.tuple.parser effects.parser lexer
 generic.parser strings.parser vocabs.loader vocabs.parser see

basis/hints/hints.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser words definitions kernel sequences assocs arrays
 kernel.private fry combinators accessors vectors strings sbufs
 byte-arrays byte-vectors io.binary io.streams.string splitting math
-math.parser generic generic.standard generic.standard.engines classes
+math.parser generic generic.single generic.standard classes
 hashtables namespaces ;
 IN: hints
 

basis/see/see.factor

@@ -1,13 +1,13 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes classes.builtin
-classes.intersection classes.mixin classes.predicate
+classes.intersection classes.mixin classes.predicate classes.singleton
-classes.singleton classes.tuple classes.union combinators
+classes.tuple classes.union combinators definitions effects generic
-definitions effects generic generic.standard io io.pathnames
+generic.single generic.standard generic.hook io io.pathnames
 io.streams.string io.styles kernel make namespaces prettyprint
 prettyprint.backend prettyprint.config prettyprint.custom
-prettyprint.sections sequences sets sorting strings summary
+prettyprint.sections sequences sets sorting strings summary words
-words words.symbol words.constant words.alias ;
+words.symbol words.constant words.alias ;
 IN: see
 
 GENERIC: synopsis* ( defspec -- )

basis/stack-checker/backend/backend.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry arrays generic io io.streams.string kernel math
+USING: fry arrays generic io io.streams.string kernel math namespaces
-namespaces parser sequences strings vectors words quotations
+parser sequences strings vectors words quotations effects classes
-effects classes continuations assocs combinators
+continuations assocs combinators compiler.errors accessors math.order
-compiler.errors accessors math.order definitions sets
+definitions sets hints macros stack-checker.state
-generic.standard.engines.tuple hints macros stack-checker.state
 stack-checker.visitor stack-checker.errors stack-checker.values
 stack-checker.recursive-state ;
 IN: stack-checker.backend

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

@@ -12,7 +12,7 @@ classes.tuple.private vectors vectors.private words definitions
 words.private assocs summary compiler.units system.private
 combinators locals locals.backend locals.types words.private
 quotations.private combinators.private stack-checker.values
-generic.standard.private
+generic.single generic.single.private
 alien.libraries
 stack-checker.alien
 stack-checker.state
@@ -236,6 +236,8 @@ M: object infer-call*
 \ 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/tools/crossref/crossref.factor

@@ -3,8 +3,7 @@
 USING: words assocs definitions io io.pathnames io.styles kernel
 prettyprint sorting see sets sequences arrays hashtables help.crossref
 help.topics help.markup quotations accessors source-files namespaces
-graphs vocabs generic generic.standard.engines.tuple threads
+graphs vocabs generic generic.single threads compiler.units init ;
-compiler.units init ;
 IN: tools.crossref
 
 SYMBOL: crossref
@@ -82,7 +81,7 @@ M: object irrelevant? drop f ;
 
 M: default-method irrelevant? drop t ;
 
-M: engine-word irrelevant? drop t ;
+M: predicate-engine irrelevant? drop t ;
 
 PRIVATE>
 

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

@@ -3,13 +3,13 @@
 USING: accessors arrays assocs calendar colors colors.constants
 documents documents.elements fry kernel words sets splitting math
 math.vectors models.delay models.arrow combinators.short-circuit
-parser present sequences tools.completion help.vocabs generic
+parser present sequences tools.completion help.vocabs generic fonts
-generic.standard.engines.tuple fonts definitions.icons ui.images
+definitions.icons ui.images ui.commands ui.operations ui.gadgets
-ui.commands ui.operations ui.gadgets ui.gadgets.editors
+ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers
-ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables
+ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled
-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

core/bootstrap/primitives.factor

@@ -69,7 +69,7 @@ bootstrapping? on
     "classes.predicate"
     "compiler.units"
     "continuations.private"
-    "generic.standard.private"
+    "generic.single.private"
     "growable"
     "hashtables"
     "hashtables.private"
@@ -533,7 +533,7 @@ tuple
     { "jit-compile" "quotations" (( quot -- )) }
     { "load-locals" "locals.backend" (( ... n -- )) }
     { "check-datastack" "kernel.private" (( array in# out# -- ? )) }
-    { "lookup-method" "generic.standard.private" (( object methods -- method )) }
+    { "lookup-method" "generic.single.private" (( object methods -- method )) }
 } [ [ first3 ] dip swap make-primitive ] each-index
 
 ! Bump build number

core/generic/hook/hook-docs.factor

@@ -0,0 +1,10 @@
+USING: generic generic.single generic.standard help.markup help.syntax sequences math
+math.parser effects ;
+IN: generic.hook
+
+HELP: hook-combination
+{ $class-description
+    "Performs hook method combination . See " { $link POSTPONE: HOOK: } "."
+} ;
+
+{ standard-combination hook-combination } related-words

core/generic/hook/hook.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors definitions generic generic.single kernel
+namespaces words ;
+IN: generic.hook
+
+TUPLE: hook-combination < single-combination var ;
+
+C: <hook-combination> hook-combination
+
+PREDICATE: hook-generic < generic
+    "combination" word-prop hook-combination? ;
+
+M: hook-combination picker
+    combination get var>> [ get ] curry ;
+
+M: hook-combination dispatch# drop 0 ;
+
+M: hook-generic definer drop \ HOOK: f ;

core/generic/single/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

core/generic/single/single-docs.factor

@@ -0,0 +1,27 @@
+USING: generic help.markup help.syntax sequences math
+math.parser effects ;
+IN: generic.single
+
+HELP: no-method
+{ $values { "object" "an object" } { "generic" "a generic word" } }
+{ $description "Throws a " { $link no-method } " error." }
+{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ;
+
+HELP: inconsistent-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
+{ $examples
+    "The following code throws this error:"
+    { $code
+        "GENERIC: error-test ( object -- )"
+        ""
+        "M: string error-test print ;"
+        ""
+        "M: integer error-test number>string call-next-method ;"
+        ""
+        "123 error-test"
+    }
+    "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
+    $nl
+    "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
+    { $code "M: integer error-test number>string error-test ;" }
+} ;

core/generic/single/single.factor

@@ -1,13 +1,66 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes.algebra math combinators
+USING: accessors arrays assocs classes classes.algebra
-generic.standard.engines hashtables kernel kernel.private layouts
+combinators definitions generic hashtables kernel
-namespaces sequences words sorting quotations effects
+kernel.private layouts make math namespaces quotations
-generic.standard.private words.private ;
+sequences words generic.single.private words.private
-IN: generic.standard.compiler
+effects ;
+IN: generic.single
+
+ERROR: no-method object generic ;
+
+ERROR: inconsistent-next-method class generic ;
+
+TUPLE: single-combination ;
+
+PREDICATE: single-generic < generic
+    "combination" word-prop single-combination? ;
+
+GENERIC: dispatch# ( word -- n )
+
+M: generic dispatch# "combination" word-prop dispatch# ;
+
+SYMBOL: assumed
+SYMBOL: default
+SYMBOL: generic-word
+SYMBOL: combination
+
+: with-combination ( combination quot -- )
+    [ combination ] dip with-variable ; inline
+
+HOOK: picker combination ( -- quot )
+
+M: single-combination next-method-quot*
+    [
+        2dup next-method dup [
+            [
+                pick "predicate" word-prop %
+                1quotation ,
+                [ inconsistent-next-method ] 2curry ,
+                \ if ,
+            ] [ ] make picker prepend
+        ] [ 3drop f ] if
+    ] with-combination ;
+
+: single-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 ;
 
 ! ! ! Build an engine ! ! !
 
+: find-default ( methods -- default )
+    #! Side-effects methods.
+    [ object bootstrap-word ] dip delete-at* [
+        drop generic-word get "default-method" word-prop
+    ] unless ;
+
 ! 1. Flatten methods
 TUPLE: predicate-engine methods ;
 
@@ -28,6 +81,10 @@ TUPLE: predicate-engine methods ;
     H{ } clone [ [ flatten-method ] curry assoc-each ] keep ;
 
 ! 2. Convert methods
+: split-methods ( assoc class -- first second )
+    [ [ nip class<= not ] curry assoc-filter ]
+    [ [ nip class<=     ] curry assoc-filter ] 2bi ;
+
 : convert-methods ( assoc class word -- assoc' )
     over [ split-methods ] 2dip pick assoc-empty?
     [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
@@ -76,10 +133,6 @@ C: <tag-dispatch-engine> tag-dispatch-engine
     <tag-dispatch-engine> ;
 
 ! ! ! Compile engine ! ! !
-SYMBOL: assumed
-SYMBOL: default
-SYMBOL: generic-word
-
 GENERIC: compile-engine ( engine -- obj )
 
 : compile-engines ( assoc -- assoc' )
@@ -98,8 +151,7 @@ M: tag-dispatch-engine compile-engine
 
 : hi-tag-number ( class -- n ) "type" word-prop ;
 
-: num-hi-tags ( -- n )
+: num-hi-tags ( -- n ) num-types get num-tags get - ;
-    num-types get num-tags get - ;
 
 M: hi-tag-dispatch-engine compile-engine
     methods>> compile-engines*
@@ -123,8 +175,8 @@ M: tuple-dispatch-engine compile-engine
 : sort-methods ( assoc -- assoc' )
     >alist [ keys sort-classes ] keep extract-keys ;
 
-: literalize-methods ( assoc -- assoc' )
+: quote-methods ( assoc -- assoc' )
-    [ [ ] curry \ drop prefix ] assoc-map ;
+    [ 1quotation \ drop prefix ] assoc-map ;
 
 : methods-with-default ( engine -- assoc )
     methods>> clone default get object bootstrap-word pick set-at ;
@@ -141,34 +193,49 @@ M: tuple-dispatch-engine compile-engine
     } cond ;
 
 : class-predicates ( assoc -- assoc )
-    [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ;
+    [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
 
-: predicate-engine-effect ( -- effect )
+PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
-    (dispatch#) get 1+ dup 1+ <effect> ;
+
+: <predicate-engine-word> ( -- word )
+    generic-word get name>> "/predicate-engine" append f <word>
+    dup generic-word get "owner-generic" set-word-prop ;
+
+M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
 
 : define-predicate-engine ( alist -- word )
-    [ generic-word get name>> "/predicate-engine" append f <word> dup ] dip
+    [ <predicate-engine-word> ] dip
-    predicate-engine-effect define-declared ;
+    [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
 
 M: predicate-engine compile-engine
     methods-with-default
     sort-methods
-    literalize-methods
+    quote-methods
     prune-redundant-predicates
     class-predicates
-    [ peek wrapped>> ]
+    [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
-    [ alist>quot picker prepend define-predicate-engine ] if-empty ;
 
 M: word compile-engine ;
 
 M: f compile-engine ;
 
-: build-engine ( generic combination -- engine )
+: build-decision-tree ( generic -- methods )
-    [
+    {
-        #>> (dispatch#) set
         [ generic-word set ]
-        [ "default-method" word-prop default set ]
+        [ "engines" word-prop forget-all ]
-        [ "methods" word-prop ] tri
+        [ V{ } clone "engines" set-word-prop ]
-        <engine> compile-engine 1quotation
+        [
-        picker [ lookup-method ] surround
+            "methods" word-prop clone
-    ] with-scope ;
+            [ find-default default set ]
+            [ <engine> compile-engine ] bi
+        ]
+    } cleave ;
+
+: execute-unsafe ( word -- ) (execute) ;
+
+M: single-combination perform-combination
+    [
+        dup build-decision-tree
+        [ "decision-tree" set-word-prop ]
+        [ 1quotation picker [ lookup-method execute-unsafe ] surround define ] 2bi
+    ] with-combination ;

core/generic/standard/authors.txt

@@ -1 +1 @@
-Slava Pestov
+Slava Pestov

core/generic/standard/engines/engines.factor

@@ -1,53 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel kernel.private namespaces quotations
-generic math sequences combinators words classes.algebra arrays
-;
-IN: generic.standard.engines
-
-SYMBOL: default
-SYMBOL: assumed
-SYMBOL: (dispatch#)
-
-GENERIC: engine>quot ( engine -- quot )
-
-: 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 -- )
-    [ dup assoc-size 4 <= ] 2dip if ; inline
-
-: linear-dispatch-quot ( alist -- quot )
-    default get [ drop ] prepend swap
-    [
-        [ [ dup ] swap [ eq? ] curry compose ]
-        [ [ drop ] prepose ]
-        bi* [ ] like
-    ] assoc-map
-    alist>quot ;
-
-: split-methods ( assoc class -- first second )
-    [ [ nip class<= not ] curry assoc-filter ]
-    [ [ nip class<=     ] curry assoc-filter ] 2bi ;
-
-: convert-methods ( assoc class word -- assoc' )
-    over [ split-methods ] 2dip pick assoc-empty? [
-        3drop
-    ] [
-        [ execute ] dip pick set-at
-    ] if ; inline
-
-: (picker) ( n -- quot )
-    {
-        { 0 [ [ dup ] ] }
-        { 1 [ [ over ] ] }
-        { 2 [ [ pick ] ] }
-        [ 1- (picker) [ dip swap ] curry ]
-    } case ;
-
-: picker ( -- quot ) \ (dispatch#) get (picker) ;
-
-GENERIC: extra-values ( generic -- n )

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

@@ -1,38 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic.standard.engines generic namespaces kernel
-kernel.private sequences classes.algebra accessors words
-combinators assocs arrays ;
-IN: generic.standard.engines.predicate
-
-TUPLE: predicate-dispatch-engine methods ;
-
-C: <predicate-dispatch-engine> predicate-dispatch-engine
-
-: class-predicates ( assoc -- assoc )
-    [ [ "predicate" word-prop picker prepend ] dip ] 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? ] [ rest-slice prune-redundant-predicates ] }
-        [ [ first second ] [ rest-slice ] bi ]
-    } cond ;
-
-: sort-methods ( assoc -- assoc' )
-    >alist [ keys sort-classes ] keep extract-keys ;
-
-: methods-with-default ( engine -- assoc )
-    methods>> clone default get object bootstrap-word pick set-at ;
-
-M: predicate-dispatch-engine engine>quot
-    methods-with-default
-    engines>quots
-    sort-methods
-    prune-redundant-predicates
-    class-predicates
-    alist>quot ;

core/generic/standard/engines/predicate/summary.txt

@@ -1 +0,0 @@
-Chained-conditional dispatch strategy

core/generic/standard/engines/summary.txt

@@ -1 +0,0 @@
-Generic word dispatch strategy implementation

core/generic/standard/engines/tag/summary.txt

@@ -1 +0,0 @@
-Jump table keyed by pointer tag dispatch strategy

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

@@ -1,71 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes.private generic.standard.engines namespaces make
-arrays assocs sequences.private quotations kernel.private
-math slots.private math.private kernel accessors words
-layouts sorting sequences combinators ;
-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 ;
-
-: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
-
-: tag-dispatch-test ( tag# -- quot )
-    picker [ tag ] append swap [ eq? ] curry append ;
-
-: tag-dispatch-quot ( alist -- quot )
-    [ default get ] dip
-    [ [ tag-dispatch-test ] dip ] assoc-map
-    alist>quot ;
-
-M: lo-tag-dispatch-engine engine>quot
-    methods>> engines>quots*
-    [ [ lo-tag-number ] dip ] assoc-map
-    [
-        [ sort-tags tag-dispatch-quot ]
-        [ picker % [ tag ] % 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 ( -- n ) num-types get num-tags get - ;
-
-: hi-tag-number ( class -- n )
-    "type" word-prop ;
-
-: hi-tag-quot ( -- quot )
-    \ hi-tag def>> ;
-
-M: hi-tag-dispatch-engine engine>quot
-    methods>> engines>quots*
-    [ [ hi-tag-number ] dip ] assoc-map
-    [
-        picker % hi-tag-quot % [
-            sort-tags linear-dispatch-quot
-        ] [
-            num-tags get , \ fixnum-fast ,
-            [ [ num-tags get - ] dip ] assoc-map
-            num-hi-tags direct-dispatch-quot
-        ] if-small? %
-    ] [ ] make ;

core/generic/standard/engines/tuple/summary.txt

@@ -1 +0,0 @@
-Tuple class dispatch strategy

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

@@ -1,167 +0,0 @@
-! 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 make generic generic.standard.engines
-classes.algebra math math.private kernel.private
-quotations arrays definitions ;
-IN: generic.standard.engines.tuple
-
-: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline
-
-: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline
-
-: tuple-layout% ( -- )
-    [ { tuple } declare 1 slot { array } declare ] % ; inline
-
-: tuple-layout-echelon% ( -- )
-    [ 4 slot ] % ; inline
-
-TUPLE: echelon-dispatch-engine n methods ;
-
-C: <echelon-dispatch-engine> echelon-dispatch-engine
-
-TUPLE: trivial-tuple-dispatch-engine n methods ;
-
-C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
-
-TUPLE: tuple-dispatch-engine echelons ;
-
-: push-echelon ( class method assoc -- )
-    [ swap dup "layout" word-prop third ] dip
-    [ ?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
-    [ dupd <echelon-dispatch-engine> ] assoc-map
-    \ tuple-dispatch-engine boa ;
-
-: convert-tuple-methods ( assoc -- assoc' )
-    tuple bootstrap-word
-    \ <tuple-dispatch-engine> convert-methods ;
-
-M: trivial-tuple-dispatch-engine engine>quot
-    [ n>> ] [ methods>> ] bi dup assoc-empty? [
-        2drop default get [ drop ] prepend
-    ] [
-        [
-            [ nth-superclass% ]
-            [ engines>quots* linear-dispatch-quot % ] bi*
-        ] [ ] make
-    ] if ;
-
-: hash-methods ( n methods -- buckets )
-    >alist V{ } clone [ hashcode 1array ] distribute-buckets
-    [ <trivial-tuple-dispatch-engine> ] with map ;
-
-: class-hash-dispatch-quot ( n methods -- quot )
-    [
-        \ dup ,
-        [ drop nth-hashcode% ]
-        [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
-    ] [ ] make ;
-
-: engine-word-name ( -- string )
-    generic get name>> "/tuple-dispatch-engine" append ;
-
-PREDICATE: engine-word < word
-    "tuple-dispatch-generic" word-prop generic? ;
-
-M: engine-word stack-effect
-    "tuple-dispatch-generic" word-prop
-    [ extra-values ] [ stack-effect ] bi
-    dup [
-        [ in>> length + ] [ out>> ] [ terminated?>> ] tri
-        effect boa
-    ] [ 2drop f ] if ;
-
-M: engine-word where "tuple-dispatch-generic" word-prop where ;
-
-M: engine-word crossref? "forgotten" word-prop not ;
-
-: remember-engine ( word -- )
-    generic get "engines" word-prop push ;
-
-: <engine-word> ( -- word )
-    engine-word-name f <word>
-    dup generic get "tuple-dispatch-generic" set-word-prop ;
-
-: define-engine-word ( quot -- word )
-    [ <engine-word> dup ] dip define ;
-
-: tuple-dispatch-engine-body ( engine -- quot )
-    [
-        picker %
-        tuple-layout%
-        [ n>> ] [ methods>> ] bi
-        [ <trivial-tuple-dispatch-engine> engine>quot ]
-        [ class-hash-dispatch-quot ]
-        if-small? %
-    ] [ ] make ;
-
-M: echelon-dispatch-engine engine>quot
-    dup n>> zero? [
-        methods>> dup assoc-empty?
-        [ drop default get ] [ values first engine>quot ] if
-    ] [
-        tuple-dispatch-engine-body
-    ] if ;
-
-: >=-case-quot ( default alist -- quot )
-    [ [ drop ] prepend ] dip
-    [
-        [ [ dup ] swap [ fixnum>= ] curry compose ]
-        [ [ drop ] prepose ]
-        bi* [ ] like
-    ] assoc-map
-    alist>quot ;
-
-: simplify-echelon-alist ( default alist -- default' alist' )
-    dup empty? [
-        dup first first 1 <= [
-            nip unclip second swap
-            simplify-echelon-alist
-        ] when
-    ] unless ;
-
-: echelon-case-quot ( alist -- quot )
-    #! We don't have to test for echelon 1 since all tuple
-    #! classes are at least at depth 1 in the inheritance
-    #! hierarchy.
-    default get swap simplify-echelon-alist
-    [
-        [
-            picker %
-            tuple-layout%
-            tuple-layout-echelon%
-            >=-case-quot %
-        ] [ ] make
-    ] unless-empty ;
-
-M: tuple-dispatch-engine engine>quot
-    [
-        [
-            tuple assumed set
-            echelons>> unclip-last
-            [
-                [
-                    engine>quot
-                    over 0 = [
-                        define-engine-word
-                        [ remember-engine ] [ 1quotation ] bi
-                    ] unless
-                    dup default set
-                ] assoc-map
-            ]
-            [ first2 engine>quot 2array ] bi*
-            suffix
-        ] with-scope
-        echelon-case-quot %
-    ] [ ] make ;

core/generic/standard/standard-docs.factor

@@ -1,12 +1,7 @@
-USING: generic help.markup help.syntax sequences math
+USING: generic generic.single help.markup help.syntax sequences math
 math.parser effects ;
 IN: generic.standard
 
-HELP: no-method
-{ $values { "object" "an object" } { "generic" "a generic word" } }
-{ $description "Throws a " { $link no-method } " error." }
-{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ;
-
 HELP: standard-combination
 { $class-description
     "Performs standard method combination."
@@ -22,32 +17,6 @@ HELP: standard-combination
     }
 } ;
 
-HELP: hook-combination
-{ $class-description
-    "Performs hook method combination . See " { $link POSTPONE: HOOK: } "."
-} ;
-
 HELP: define-simple-generic
 { $values { "word" "a word" } { "effect" effect } }
-{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
+{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
-
-{ standard-combination hook-combination } related-words
-
-HELP: inconsistent-next-method
-{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
-{ $examples
-    "The following code throws this error:"
-    { $code
-        "GENERIC: error-test ( object -- )"
-        ""
-        "M: string error-test print ;"
-        ""
-        "M: integer error-test number>string call-next-method ;"
-        ""
-        "123 error-test"
-    }
-    "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
-    $nl
-    "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
-    { $code "M: integer error-test number>string error-test ;" }
-} ;

core/generic/standard/standard.factor

@@ -1,100 +1,10 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel kernel.private slots.private math
+USING: accessors definitions generic generic.single kernel
-namespaces make sequences vectors words quotations definitions
+namespaces words math combinators ;
-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
 
-GENERIC: dispatch# ( word -- n )
+TUPLE: standard-combination < single-combination # ;
-
-M: generic dispatch#
-    "combination" word-prop dispatch# ;
-
-GENERIC: method-declaration ( class generic -- quot )
-
-M: generic method-declaration
-    "combination" word-prop method-declaration ;
-
-M: quotation engine>quot
-    assumed get generic get method-declaration prepend ;
-
-ERROR: no-method object generic ;
-
-: error-method ( word -- quot )
-    [ picker ] dip [ no-method ] curry append ;
-
-: push-method ( method specializer atomic assoc -- )
-    [
-        [ H{ } clone <predicate-dispatch-engine> ] unless*
-        [ methods>> set-at ] keep
-    ] change-at ;
-
-: flatten-method ( class method assoc -- )
-    [ [ flatten-class keys ] keep ] 2dip [
-        [ spin ] dip 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> ;
-
-: mangle-method ( method -- quot )
-    1quotation generic get extra-values \ drop <repetition>
-    prepend [ ] like ;
-
-: find-default ( methods -- quot )
-    #! Side-effects methods.
-    [ object bootstrap-word ] dip delete-at* [
-        drop generic get "default-method" word-prop mangle-method
-    ] unless ;
-
-: <standard-engine> ( word -- engine )
-    object bootstrap-word assumed set {
-        [ generic set ]
-        [ "engines" word-prop forget-all ]
-        [ V{ } clone "engines" set-word-prop ]
-        [
-            "methods" word-prop
-            [ mangle-method ] assoc-map
-            [ find-default default set ]
-            [ <big-dispatch-engine> ]
-            bi
-        ]
-    } cleave ;
-
-: single-combination ( word -- quot )
-    [ <standard-engine> engine>quot ] with-scope ;
-
-ERROR: inconsistent-next-method class generic ;
-
-: single-next-method-quot ( class generic -- quot/f )
-    2dup next-method dup [
-        [
-            pick "predicate" word-prop %
-            1quotation ,
-            [ inconsistent-next-method ] 2curry ,
-            \ if ,
-        ] [ ] make
-    ] [ 3drop f ] if ;
-
-: single-effective-method ( obj word -- method )
-    [ [ order [ instance? ] with find-last nip ] keep method ]
-    [ "default-method" word-prop ]
-    bi or ;
-
-TUPLE: standard-combination # ;
 
 C: <standard-combination> standard-combination
 
@@ -102,79 +12,26 @@ PREDICATE: standard-generic < generic
     "combination" word-prop standard-combination? ;
 
 PREDICATE: simple-generic < standard-generic
-    "combination" word-prop #>> zero? ;
+    "combination" word-prop #>> 0 = ;
 
 CONSTANT: simple-combination T{ standard-combination f 0 }
 
 : define-simple-generic ( word effect -- )
     [ simple-combination ] dip define-generic ;
 
-: with-standard ( combination quot -- quot' )
+: (picker) ( n -- quot )
-    [ #>> (dispatch#) ] dip with-variable ; inline
+    {
+        { 0 [ [ dup ] ] }
+        { 1 [ [ over ] ] }
+        { 2 [ [ pick ] ] }
+        [ 1- (picker) [ dip swap ] curry ]
+    } case ;
 
-M: standard-generic extra-values drop 0 ;
+M: standard-combination picker
-
+    combination get #>> (picker) ;
-M: standard-combination make-default-method
-    [ error-method ] with-standard ;
-
-M: standard-combination perform-combination
-    [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
 
 M: standard-combination dispatch# #>> ;
 
-M: standard-combination method-declaration
-    dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
-
-M: standard-combination next-method-quot*
-    [
-        single-next-method-quot
-        dup [ picker prepend ] when
-    ] with-standard ;
-
-M: standard-generic effective-method
-    [ dispatch# (picker) call ] keep single-effective-method ;
-
-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#) [
-        [ hook-combination ] dip with-variable
-    ] with-variable ; inline
-
-: prepend-hook-var ( quot -- quot' )
-    hook-combination get var>> [ get ] curry prepend ;
-
-M: hook-combination dispatch# drop 0 ;
-
-M: hook-combination method-declaration 2drop [ ] ;
-
-M: hook-generic extra-values drop 1 ;
-
-M: hook-generic effective-method
-    [ "combination" word-prop var>> get ] keep
-    single-effective-method ;
-
-M: hook-combination make-default-method
-    [ error-method prepend-hook-var ] with-hook ;
-
-M: hook-combination perform-combination
-    [ drop ] [
-        [ single-combination prepend-hook-var ] with-hook
-    ] 2bi define ;
-
-M: hook-combination next-method-quot*
-    [
-        single-next-method-quot
-        dup [ prepend-hook-var ] when
-    ] with-hook ;
-
 M: simple-generic definer drop \ GENERIC: f ;
 
-M: standard-generic definer drop \ GENERIC# f ;
+M: standard-generic definer drop \ GENERIC# f ;
-
-M: hook-generic definer drop \ HOOK: f ;

core/generic/standard/summary.txt

@@ -1 +0,0 @@
-Standard method combination used for most generic words

core/syntax/syntax-docs.factor

@@ -1,7 +1,7 @@
 USING: generic help.syntax help.markup kernel math parser words
 effects classes generic.standard classes.tuple generic.math
-generic.standard arrays io.pathnames vocabs.loader io sequences
+generic.standard generic.single arrays io.pathnames vocabs.loader io
-assocs words.symbol words.alias words.constant combinators ;
+sequences assocs words.symbol words.alias words.constant combinators ;
 IN: syntax
 
 ARTICLE: "parser-algorithm" "Parser algorithm"

core/syntax/syntax.factor

@@ -4,7 +4,7 @@ USING: accessors alien arrays byte-arrays definitions generic
 hashtables kernel math namespaces parser lexer sequences strings
 strings.parser sbufs vectors words words.symbol words.constant
 words.alias quotations io assocs splitting classes.tuple
-generic.standard generic.math generic.parser classes
+generic.standard generic.hook generic.math generic.parser classes
 io.pathnames vocabs vocabs.parser classes.parser classes.union
 classes.intersection classes.mixin classes.predicate
 classes.singleton classes.tuple.parser compiler.units

core/words/words.factor

@@ -154,8 +154,15 @@ M: word reset-word
 : reset-generic ( word -- )
     [ subwords forget-all ]
     [ reset-word ]
-    [ { "methods" "combination" "default-method" } reset-props ]
+    [
-    tri ;
+        {
+            "methods"
+            "combination"
+            "default-method"
+            "engines"
+            "decision-tree"
+        } reset-props
+    ] tri ;
 
 : gensym ( -- word )
     "( gensym )" f <word> ;