/core/generic/standard/standard.factor

 1! Copyright (C) 2009 Slava Pestov.
 2! See http://factorcode.org/license.txt for BSD license.
 3USING: accessors arrays combinators definitions generic
 4generic.single generic.single.private kernel layouts make math
 5namespaces quotations sequences words ;
 6IN: generic.standard
 7
 8ERROR: bad-dispatch-position # ;
 9
10TUPLE: standard-combination < single-combination # ;
11
12: <standard-combination> ( # -- standard-combination )
13    dup 0 < [ bad-dispatch-position ] when
14    standard-combination boa ;
15
16PREDICATE: standard-generic < generic
17    "combination" word-prop standard-combination? ;
18
19PREDICATE: simple-generic < standard-generic
20    "combination" word-prop #>> 0 = ;
21
22CONSTANT: simple-combination T{ standard-combination f 0 }
23
24: define-simple-generic ( word effect -- )
25    [ simple-combination ] dip define-generic ;
26
27: (picker) ( n -- quot )
28    {
29        { 0 [ [ dup ] ] }
30        { 1 [ [ over ] ] }
31        { 2 [ [ pick ] ] }
32        [ 1 - (picker) [ dip swap ] curry ]
33    } case ;
34
35M: standard-combination picker
36    combination get #>> (picker) ;
37
38M: standard-combination dispatch# #>> ;
39
40M: standard-generic effective-method
41    [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
42    method-for-object ;
43
44: inline-cache-quot ( word methods miss-word -- quot )
45    [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
46
47M: standard-combination inline-cache-quots
48    #! Direct calls to the generic word (not tail calls or indirect calls)
49    #! will jump to the inline cache entry point instead of the megamorphic
50    #! dispatch entry point.
51    [ \ inline-cache-miss inline-cache-quot ]
52    [ \ inline-cache-miss-tail inline-cache-quot ]
53    2bi ;
54
55: make-empty-cache ( -- array )
56    mega-cache-size get f <array> ;
57
58M: standard-combination mega-cache-quot
59    combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ;
60
61M: standard-generic definer drop \ GENERIC# f ;
62
63M: simple-generic definer drop \ GENERIC: f ;