Debugging inheritancE
Slava Pestov
parent
f96a43c42d
commit
7a596ce004
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
over deferred? [ over define-symbol ] when
|
||||
>r dup word-props r> union over set-word-props
|
||||
dup predicate-word 2dup 1quotation "predicate" set-word-prop
|
||||
over "predicating" set-word-prop
|
||||
t "class" set-word-prop ;
|
||||
>r
|
||||
dup reset-class
|
||||
dup deferred? [ dup define-symbol ] when
|
||||
dup word-props
|
||||
r> union over set-word-props
|
||||
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) ] [
|
||||
drop
|
||||
[ update-map+ ] [
|
||||
class-usages
|
||||
[ update-classes ]
|
||||
[ update-methods ] bi
|
||||
] bi
|
||||
] 2tri ;
|
||||
[ (define-class) ]
|
||||
[ drop update-map+ ]
|
||||
2tri ;
|
||||
|
||||
GENERIC: class ( object -- class )
|
||||
|
||||
|
|
|
|||
|
|
@ -14,9 +14,14 @@ PREDICATE: predicate-class < class
|
|||
] [ ] make ;
|
||||
|
||||
: define-predicate-class ( class superclass definition -- )
|
||||
>r dupd f predicate-class define-class
|
||||
r> dupd "predicate-definition" set-word-prop
|
||||
dup predicate-quot define-predicate ;
|
||||
[ drop f predicate-class define-class ]
|
||||
[ nip "predicate-definition" set-word-prop ]
|
||||
[
|
||||
2drop
|
||||
[ dup predicate-quot define-predicate ]
|
||||
[ update-classes ]
|
||||
bi
|
||||
] 3tri ;
|
||||
|
||||
M: predicate-class reset-class
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -161,25 +161,23 @@ PRIVATE>
|
|||
: update-tuples-after ( class -- )
|
||||
outdated-tuples get [ all-slot-names ] cache drop ;
|
||||
|
||||
: subclasses ( class -- classes )
|
||||
class-usages keys [ tuple-class? ] subset ;
|
||||
|
||||
: each-subclass ( class quot -- )
|
||||
>r subclasses r> each ; inline
|
||||
|
||||
: define-tuple-shape ( class -- )
|
||||
[ define-tuple-slots ]
|
||||
M: tuple-class update-class
|
||||
[ 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
|
||||
[ define-tuple-shape ] each-subclass
|
||||
] 3tri ;
|
||||
[ 2drop update-classes ]
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ >r "predicate" word-prop [ dup ] prepend r> ]
|
||||
assoc-map alist>quot
|
||||
] if ;
|
||||
|
||||
: 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
|
||||
unclip "predicate" word-prop swap [
|
||||
"predicate" word-prop [ dup ] prepend
|
||||
[ drop t ]
|
||||
] { } map>assoc alist>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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
USING: classes.private generic.standard.engines namespaces
|
||||
arrays mirrors assocs sequences.private quotations
|
||||
kernel.private layouts math slots.private math.private
|
||||
kernel accessors ;
|
||||
arrays assocs sequences.private quotations kernel.private
|
||||
layouts math slots.private math.private kernel accessors ;
|
||||
IN: generic.standard.engines.tag
|
||||
|
||||
TUPLE: lo-tag-dispatch-engine methods ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -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 # ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
|
||||
SYMBOL: (dispatch#)
|
||||
|
||||
: (picker) ( n -- quot )
|
||||
: unpickers
|
||||
{
|
||||
{ 0 [ [ dup ] ] }
|
||||
{ 1 [ [ over ] ] }
|
||||
{ 2 [ [ pick ] ] }
|
||||
[ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
|
||||
} case ;
|
||||
|
||||
: picker ( -- quot ) \ (dispatch#) get (picker) ;
|
||||
|
||||
: unpickers { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } ; inline
|
||||
[ 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 )
|
||||
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 )
|
||||
: push-method ( method specializer atomic assoc -- )
|
||||
[
|
||||
picker %
|
||||
\ tag ,
|
||||
group-methods build-type-vtable ,
|
||||
\ dispatch ,
|
||||
] [ ] make ;
|
||||
[ H{ } clone <predicate-dispatch-engine> ] unless*
|
||||
[ methods>> set-at ] keep
|
||||
] change-at ;
|
||||
|
||||
: flatten-method ( class body -- )
|
||||
over members pick object bootstrap-word eq? not and [
|
||||
>r members r> [ flatten-method ] curry each
|
||||
] [
|
||||
swap set
|
||||
] if ;
|
||||
: flatten-method ( class method assoc -- )
|
||||
>r >r dup flatten-class keys swap r> r> [
|
||||
>r spin r> push-method
|
||||
] 3curry each ;
|
||||
|
||||
: flatten-methods ( methods -- newmethods )
|
||||
[ [ flatten-method ] assoc-each ] V{ } make-assoc ;
|
||||
: flatten-methods ( assoc -- assoc' )
|
||||
H{ } clone [
|
||||
[
|
||||
flatten-method
|
||||
] curry assoc-each
|
||||
] keep ;
|
||||
|
||||
: dispatched-types ( methods -- seq )
|
||||
keys object bootstrap-word swap remove prune ;
|
||||
: <big-dispatch-engine> ( assoc -- engine )
|
||||
flatten-methods
|
||||
convert-tuple-methods
|
||||
convert-hi-tag-methods
|
||||
<lo-tag-dispatch-engine> ;
|
||||
|
||||
: single-combination ( methods -- quot )
|
||||
dup length 4 <= [
|
||||
small-generic
|
||||
] [
|
||||
flatten-methods
|
||||
dup dispatched-types [ number class< ] all?
|
||||
[ tag-generic ] [ big-generic ] if
|
||||
] if ;
|
||||
: find-default ( methods -- quot )
|
||||
#! Side-effects methods.
|
||||
object swap delete-at* [
|
||||
drop generic get "default-method" word-prop 1quotation
|
||||
] unless ;
|
||||
|
||||
: standard-methods ( word -- alist )
|
||||
dup methods swap default-method prefix
|
||||
[ 1quotation ] assoc-map ;
|
||||
GENERIC: mangle-method ( method generic -- quot )
|
||||
|
||||
M: standard-combination make-default-method
|
||||
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
|
||||
: single-combination ( words -- quot )
|
||||
[
|
||||
standard-methods
|
||||
[ [ drop ] prepend ] assoc-map
|
||||
single-combination
|
||||
] with-hook ;
|
||||
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 ;
|
||||
|
||||
: define-simple-generic ( word -- )
|
||||
T{ standard-combination f 0 } define-generic ;
|
||||
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 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
Loading…
Reference in New Issue