Rewriting method dispatch to support inheritance
parent
a2971bd3be
commit
fa8b578370
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces math words kernel alien byte-arrays
|
||||
hashtables vectors strings sbufs arrays bit-arrays
|
||||
float-arrays quotations assocs layouts classes.tuple.private ;
|
||||
float-arrays quotations assocs layouts classes.tuple.private
|
||||
kernel.private ;
|
||||
|
||||
BIN: 111 tag-mask set
|
||||
8 num-tags set
|
||||
|
@ -15,6 +16,7 @@ H{
|
|||
{ bignum BIN: 001 }
|
||||
{ tuple BIN: 010 }
|
||||
{ object BIN: 011 }
|
||||
{ hi-tag BIN: 011 }
|
||||
{ ratio BIN: 100 }
|
||||
{ float BIN: 101 }
|
||||
{ complex BIN: 110 }
|
||||
|
|
|
@ -101,17 +101,24 @@ num-types get f <array> builtins set
|
|||
} [ create-vocab drop ] each
|
||||
|
||||
! Builtin classes
|
||||
: builtin-predicate-quot ( class -- quot )
|
||||
: lo-tag-eq-quot ( n -- quot )
|
||||
[ \ tag , , \ eq? , ] [ ] make ;
|
||||
|
||||
: hi-tag-eq-quot ( n -- quot )
|
||||
[
|
||||
"type" word-prop
|
||||
[ tag-mask get < \ tag \ type ? , ] [ , ] bi
|
||||
\ eq? ,
|
||||
[ dup tag ] % \ hi-tag tag-number , \ eq? ,
|
||||
[ [ hi-tag ] % , \ eq? , ] [ ] make ,
|
||||
[ drop f ] ,
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: builtin-predicate-quot ( class -- quot )
|
||||
"type" word-prop
|
||||
dup tag-mask get <
|
||||
[ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
|
||||
|
||||
: define-builtin-predicate ( class -- )
|
||||
[ dup builtin-predicate-quot define-predicate ]
|
||||
[ predicate-word make-inline ]
|
||||
bi ;
|
||||
dup builtin-predicate-quot define-predicate ;
|
||||
|
||||
: lookup-type-number ( word -- n )
|
||||
global [ target-word ] bind type-number ;
|
||||
|
@ -363,7 +370,7 @@ define-class
|
|||
f builtins get [ ] subset union-class define-class
|
||||
|
||||
! Class of objects with object tag
|
||||
"hi-tag" "classes.private" create
|
||||
"hi-tag" "kernel.private" create
|
||||
f builtins get num-tags get tail union-class define-class
|
||||
|
||||
! Null class with no instances.
|
||||
|
|
|
@ -124,6 +124,8 @@ GENERIC: update-methods ( assoc -- )
|
|||
] bi
|
||||
] 2tri ;
|
||||
|
||||
GENERIC: class ( object -- class ) inline
|
||||
GENERIC: class ( object -- class )
|
||||
|
||||
M: object class type type>class ;
|
||||
M: hi-tag class hi-tag type>class ;
|
||||
|
||||
M: object class tag type>class ;
|
||||
|
|
|
@ -9,24 +9,24 @@ hashtables sorting ;
|
|||
[ call ] with each ;
|
||||
|
||||
: cleave>quot ( seq -- quot )
|
||||
[ [ keep ] curry ] map concat [ drop ] append ;
|
||||
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
|
||||
|
||||
: 2cleave ( x seq -- )
|
||||
[ 2keep ] each 2drop ;
|
||||
|
||||
: 2cleave>quot ( seq -- quot )
|
||||
[ [ 2keep ] curry ] map concat [ 2drop ] append ;
|
||||
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
|
||||
|
||||
: 3cleave ( x seq -- )
|
||||
[ 3keep ] each 3drop ;
|
||||
|
||||
: 3cleave>quot ( seq -- quot )
|
||||
[ [ 3keep ] curry ] map concat [ 3drop ] append ;
|
||||
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
|
||||
|
||||
: spread>quot ( seq -- quot )
|
||||
[ length [ >r ] <repetition> concat ]
|
||||
[ [ [ r> ] prepend ] map concat ] bi
|
||||
append ;
|
||||
append [ ] like ;
|
||||
|
||||
: spread ( objs... seq -- )
|
||||
spread>quot call ;
|
||||
|
|
|
@ -174,11 +174,6 @@ sequences.private ;
|
|||
[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
|
||||
[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
|
||||
[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
|
||||
[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
|
||||
[ t ] [ f type f [ type ] compile-call eq? ] unit-test
|
||||
|
||||
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
|
||||
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
|
||||
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
|
||||
|
@ -223,9 +218,6 @@ sequences.private ;
|
|||
|
||||
[ t ] [ f [ f eq? ] compile-call ] unit-test
|
||||
|
||||
! regression
|
||||
[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
|
||||
|
||||
! regression
|
||||
[ 3 ] [
|
||||
100001 f <array> 3 100000 pick set-nth
|
||||
|
|
|
@ -26,10 +26,6 @@ IN: compiler.tests
|
|||
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
|
||||
unit-test
|
||||
|
||||
[ { 1 2 3 } { 1 4 3 } 8 8 ]
|
||||
[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
|
||||
unit-test
|
||||
|
||||
! Test literals in either side of a shuffle
|
||||
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
|
||||
|
||||
|
|
|
@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
|
|||
{ +output+ { "in" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ type [
|
||||
"end" define-label
|
||||
! Make a copy
|
||||
"x" operand "obj" operand MOV
|
||||
! Get the tag
|
||||
"x" operand tag-mask get AND
|
||||
! Tag the tag
|
||||
"x" operand %tag-fixnum
|
||||
! Compare with object tag number (3).
|
||||
"x" operand object tag-number tag-fixnum CMP
|
||||
"end" get JNE
|
||||
! If we have equality, load type from header
|
||||
"x" operand "obj" operand -3 [+] MOV
|
||||
"end" resolve-label
|
||||
] H{
|
||||
{ +input+ { { f "obj" } } }
|
||||
{ +scratch+ { { f "x" } } }
|
||||
{ +output+ { "x" } }
|
||||
} define-intrinsic
|
||||
|
||||
\ class-hash [
|
||||
"end" define-label
|
||||
"tuple" define-label
|
||||
"object" define-label
|
||||
! Make a copy
|
||||
"x" operand "obj" operand MOV
|
||||
! Get the tag
|
||||
"x" operand tag-mask get AND
|
||||
! Tag the tag
|
||||
"x" operand %tag-fixnum
|
||||
! Compare with tuple tag number (2).
|
||||
"x" operand tuple tag-number tag-fixnum CMP
|
||||
"tuple" get JE
|
||||
! Compare with object tag number (3).
|
||||
"x" operand object tag-number tag-fixnum CMP
|
||||
"object" get JE
|
||||
"end" get JMP
|
||||
"object" get resolve-label
|
||||
! Load header type
|
||||
"x" operand "obj" operand header-offset [+] MOV
|
||||
"end" get JMP
|
||||
"tuple" get resolve-label
|
||||
! Load class hash
|
||||
"x" operand "obj" operand tuple-class-offset [+] MOV
|
||||
"x" operand dup class-hash-offset [+] MOV
|
||||
"end" resolve-label
|
||||
] H{
|
||||
{ +input+ { { f "obj" } } }
|
||||
{ +scratch+ { { f "x" } } }
|
||||
{ +output+ { "x" } }
|
||||
} define-intrinsic
|
||||
|
||||
! Slots
|
||||
: %slot-literal-known-tag
|
||||
"obj" operand
|
||||
|
|
|
@ -37,10 +37,12 @@ PREDICATE: method-spec < pair
|
|||
: order ( generic -- seq )
|
||||
"methods" word-prop keys sort-classes ;
|
||||
|
||||
: sort-methods ( assoc -- assoc' )
|
||||
[ keys sort-classes ]
|
||||
[ [ dupd at ] curry ] bi { } map>assoc ;
|
||||
|
||||
: methods ( word -- assoc )
|
||||
"methods" word-prop
|
||||
[ keys sort-classes ] keep
|
||||
[ dupd at ] curry { } map>assoc ;
|
||||
"methods" word-prop sort-methods ;
|
||||
|
||||
TUPLE: check-method class generic ;
|
||||
|
||||
|
|
|
@ -0,0 +1,49 @@
|
|||
USING: assocs kernel namespaces quotations generic math
|
||||
sequences combinators words classes.algebra ;
|
||||
IN: generic.standard.engines
|
||||
|
||||
SYMBOL: default
|
||||
SYMBOL: assumed
|
||||
|
||||
GENERIC: engine>quot ( engine -- quot )
|
||||
|
||||
M: quotation engine>quot ;
|
||||
|
||||
M: method-body engine>quot 1quotation ;
|
||||
|
||||
: 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 -- )
|
||||
>r >r dup assoc-size 4 <= r> r> if ; inline
|
||||
|
||||
: linear-dispatch-quot ( alist -- quot )
|
||||
default get [ drop ] prepend swap
|
||||
[ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
|
||||
alist>quot ;
|
||||
|
||||
: split-methods ( assoc class -- first second )
|
||||
[ [ nip class< not ] curry assoc-subset ]
|
||||
[ [ nip class< ] curry assoc-subset ] 2bi ;
|
||||
|
||||
: convert-methods ( assoc class word -- assoc' )
|
||||
over >r >r split-methods dup assoc-empty? [
|
||||
r> r> 3drop
|
||||
] [
|
||||
r> execute r> pick set-at
|
||||
] if ; inline
|
||||
|
||||
SYMBOL: (dispatch#)
|
||||
|
||||
: (picker) ( n -- quot )
|
||||
{
|
||||
{ 0 [ [ dup ] ] }
|
||||
{ 1 [ [ over ] ] }
|
||||
{ 2 [ [ pick ] ] }
|
||||
[ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
|
||||
} case ;
|
||||
|
||||
: picker ( -- quot ) \ (dispatch#) get (picker) ;
|
|
@ -0,0 +1,28 @@
|
|||
USING: generic.standard.engines generic namespaces kernel
|
||||
sequences classes.algebra accessors words combinators
|
||||
assocs ;
|
||||
IN: generic.standard.engines.predicate
|
||||
|
||||
TUPLE: predicate-dispatch-engine methods ;
|
||||
|
||||
C: <predicate-dispatch-engine> predicate-dispatch-engine
|
||||
|
||||
: class-predicates ( assoc -- assoc )
|
||||
[ >r "predicate" word-prop picker prepend r> ] 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? ] [ 1 tail-slice prune-redundant-predicates ] }
|
||||
{ [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
|
||||
} cond ;
|
||||
|
||||
M: predicate-dispatch-engine engine>quot
|
||||
methods>> clone
|
||||
default get object bootstrap-word pick set-at engines>quots
|
||||
sort-methods prune-redundant-predicates
|
||||
class-predicates alist>quot ;
|
|
@ -0,0 +1,48 @@
|
|||
USING: classes.private generic.standard.engines namespaces
|
||||
arrays mirrors 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 ;
|
||||
|
||||
C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
|
||||
|
||||
TUPLE: hi-tag-dispatch-engine methods ;
|
||||
|
||||
C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
|
||||
|
||||
: convert-hi-tag-methods ( assoc -- assoc' )
|
||||
hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
|
||||
|
||||
: direct-dispatch-quot ( alist n -- quot )
|
||||
default get <array>
|
||||
[ <enum> swap update ] keep
|
||||
[ dispatch ] curry >quotation ;
|
||||
|
||||
M: lo-tag-dispatch-engine engine>quot
|
||||
methods>> engines>quots* [ >r tag-number r> ] assoc-map
|
||||
[
|
||||
picker % [ tag ] % [
|
||||
linear-dispatch-quot
|
||||
] [
|
||||
num-tags get direct-dispatch-quot
|
||||
] if-small? %
|
||||
] [ ] make ;
|
||||
|
||||
: num-hi-tags num-types get num-tags get - ;
|
||||
|
||||
: hi-tag-number type-number num-tags get - ;
|
||||
|
||||
: hi-tag-quot ( -- quot )
|
||||
[ 0 slot ] num-tags get [ fixnum- ] curry compose ;
|
||||
|
||||
M: hi-tag-dispatch-engine engine>quot
|
||||
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
|
||||
[
|
||||
picker % hi-tag-quot % [
|
||||
linear-dispatch-quot
|
||||
] [
|
||||
num-hi-tags direct-dispatch-quot
|
||||
] if-small? %
|
||||
] [ ] make ;
|
|
@ -0,0 +1,109 @@
|
|||
IN: generic.standard.engines.tuple
|
||||
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 ;
|
||||
|
||||
TUPLE: echelon-dispatch-engine n methods ;
|
||||
|
||||
C: <echelon-dispatch-engine> echelon-dispatch-engine
|
||||
|
||||
TUPLE: trivial-tuple-dispatch-engine methods ;
|
||||
|
||||
C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
|
||||
|
||||
TUPLE: tuple-dispatch-engine echelons ;
|
||||
|
||||
: push-echelon ( class method assoc -- )
|
||||
>r swap dup tuple-layout layout-echelon r>
|
||||
[ ?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 construct-boa ;
|
||||
|
||||
: convert-tuple-methods ( assoc -- assoc' )
|
||||
tuple \ <tuple-dispatch-engine> convert-methods ;
|
||||
|
||||
M: trivial-tuple-dispatch-engine engine>quot
|
||||
methods>> engines>quots* linear-dispatch-quot ;
|
||||
|
||||
: hash-methods ( methods -- buckets )
|
||||
>alist V{ } clone [ class-hashes ] distribute-buckets
|
||||
[ <trivial-tuple-dispatch-engine> ] map ;
|
||||
|
||||
: class-hash-dispatch-quot ( methods -- quot )
|
||||
#! 1 slot == word hashcode
|
||||
[
|
||||
[ dup 1 slot ] %
|
||||
hash-methods [ engine>quot ] map hash-dispatch-quot %
|
||||
] [ ] make ;
|
||||
|
||||
: tuple-dispatch-engine-word-name ( engine -- string )
|
||||
[
|
||||
generic get word-name %
|
||||
"/tuple-dispatch-engine/" %
|
||||
n>> #
|
||||
] "" make ;
|
||||
|
||||
PREDICATE: tuple-dispatch-engine-word < word
|
||||
"tuple-dispatch-engine" word-prop ;
|
||||
|
||||
M: tuple-dispatch-engine-word stack-effect
|
||||
"tuple-dispatch-generic" word-prop stack-effect ;
|
||||
|
||||
: <tuple-dispatch-engine-word> ( engine -- word )
|
||||
tuple-dispatch-engine-word-name f <word>
|
||||
[ t "tuple-dispatch-engine" set-word-prop ]
|
||||
[ generic get "tuple-dispatch-generic" set-word-prop ]
|
||||
[ ]
|
||||
tri ;
|
||||
|
||||
: define-tuple-dispatch-engine-word ( engine quot -- word )
|
||||
>r <tuple-dispatch-engine-word> dup r> define ;
|
||||
|
||||
: tuple-dispatch-engine-body ( engine -- quot )
|
||||
#! 1 slot == tuple-layout
|
||||
#! 2 slot == 0 array-nth
|
||||
#! 4 slot == layout-superclasses
|
||||
[
|
||||
picker %
|
||||
[ 1 slot 4 slot ] %
|
||||
[ n>> 2 + , [ slot ] % ]
|
||||
[
|
||||
methods>> [
|
||||
<trivial-tuple-dispatch-engine> engine>quot
|
||||
] [
|
||||
class-hash-dispatch-quot
|
||||
] if-small? %
|
||||
] bi
|
||||
] [ ] make ;
|
||||
|
||||
M: echelon-dispatch-engine engine>quot
|
||||
dup tuple-dispatch-engine-body
|
||||
define-tuple-dispatch-engine-word
|
||||
1quotation ;
|
||||
|
||||
: >=-case-quot ( alist -- quot )
|
||||
default get [ drop ] prepend swap
|
||||
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
|
||||
alist>quot ;
|
||||
|
||||
M: tuple-dispatch-engine engine>quot
|
||||
#! 1 slot == tuple-layout
|
||||
#! 5 slot == layout-echelon
|
||||
[
|
||||
picker %
|
||||
[ 1 slot 5 slot ] %
|
||||
echelons>>
|
||||
[ [ engine>quot dup default set ] assoc-map ] with-scope
|
||||
>=-case-quot %
|
||||
] [ ] make ;
|
|
@ -0,0 +1,141 @@
|
|||
IN: generic.standard.new.tests
|
||||
USING: tools.test math math.functions math.constants
|
||||
generic.standard.new 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 + ;
|
||||
|
||||
M: float lo-tag-test 4 - ;
|
||||
|
||||
M: rational lo-tag-test 2 - ;
|
||||
|
||||
M: complex lo-tag-test sq ;
|
||||
|
||||
[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
|
||||
[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
|
||||
[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
|
||||
[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
|
||||
|
||||
GENERIC: hi-tag-test
|
||||
|
||||
M: string hi-tag-test ", in bed" append ;
|
||||
|
||||
M: number hi-tag-test 3 + ;
|
||||
|
||||
M: array hi-tag-test [ hi-tag-test ] map ;
|
||||
|
||||
M: sequence hi-tag-test reverse ;
|
||||
|
||||
[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
|
||||
|
||||
[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
|
||||
|
||||
[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
|
||||
|
||||
TUPLE: shape ;
|
||||
|
||||
TUPLE: abstract-rectangle < shape width height ;
|
||||
|
||||
TUPLE: rectangle < abstract-rectangle ;
|
||||
|
||||
C: <rectangle> rectangle
|
||||
|
||||
TUPLE: parallelogram < abstract-rectangle skew ;
|
||||
|
||||
C: <parallelogram> parallelogram
|
||||
|
||||
TUPLE: circle < shape radius ;
|
||||
|
||||
C: <circle> circle
|
||||
|
||||
GENERIC: area
|
||||
|
||||
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
|
||||
|
||||
M: circle area radius>> sq pi * ;
|
||||
|
||||
[ 12 ] [ 4 3 <rectangle> area ] unit-test
|
||||
[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
|
||||
[ t ] [ 2 <circle> area 4 pi * = ] unit-test
|
||||
|
||||
GENERIC: perimiter
|
||||
|
||||
: rectangle-perimiter + 2 * ;
|
||||
|
||||
M: rectangle perimiter
|
||||
[ width>> ] [ height>> ] bi
|
||||
rectangle-perimiter ;
|
||||
|
||||
: hypotenuse [ sq ] bi@ + sqrt ;
|
||||
|
||||
M: parallelogram perimiter
|
||||
[ width>> ]
|
||||
[ [ height>> ] [ skew>> ] bi hypotenuse ] bi
|
||||
rectangle-perimiter ;
|
||||
|
||||
M: circle perimiter 2 * pi * ;
|
||||
|
||||
[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
|
||||
[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
|
||||
|
||||
GENERIC: big-mix-test
|
||||
|
||||
M: object big-mix-test drop "object" ;
|
||||
|
||||
M: tuple big-mix-test drop "tuple" ;
|
||||
|
||||
M: integer big-mix-test drop "integer" ;
|
||||
|
||||
M: float big-mix-test drop "float" ;
|
||||
|
||||
M: complex big-mix-test drop "complex" ;
|
||||
|
||||
M: string big-mix-test drop "string" ;
|
||||
|
||||
M: array big-mix-test drop "array" ;
|
||||
|
||||
M: sequence big-mix-test drop "sequence" ;
|
||||
|
||||
M: rectangle big-mix-test drop "rectangle" ;
|
||||
|
||||
M: parallelogram big-mix-test drop "parallelogram" ;
|
||||
|
||||
M: circle big-mix-test drop "circle" ;
|
||||
|
||||
[ "integer" ] [ 3 big-mix-test ] unit-test
|
||||
[ "float" ] [ 5.0 big-mix-test ] unit-test
|
||||
[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
|
||||
[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
|
||||
[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
|
||||
[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
|
||||
[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
|
||||
[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
|
||||
[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
|
||||
[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
|
||||
[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
|
||||
[ "string" ] [ "hello" big-mix-test ] unit-test
|
||||
[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
|
||||
[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
|
||||
[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
|
||||
[ "tuple" ] [ H{ } big-mix-test ] unit-test
|
||||
[ "object" ] [ \ + big-mix-test ] unit-test
|
||||
|
||||
GENERIC: small-lo-tag
|
||||
|
||||
M: fixnum small-lo-tag drop "fixnum" ;
|
||||
|
||||
M: string small-lo-tag drop "string" ;
|
||||
|
||||
M: array small-lo-tag drop "array" ;
|
||||
|
||||
M: float-array small-lo-tag drop "float-array" ;
|
||||
|
||||
M: byte-array small-lo-tag drop "byte-array" ;
|
||||
|
||||
[ "fixnum" ] [ 3 small-lo-tag ] unit-test
|
||||
|
||||
[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
|
|
@ -0,0 +1,139 @@
|
|||
! 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-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-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 ;
|
|
@ -41,23 +41,13 @@ ERROR: no-method object generic ;
|
|||
: class-predicates ( assoc -- assoc )
|
||||
[ >r "predicate" word-prop picker prepend r> ] assoc-map ;
|
||||
|
||||
: (simplify-alist) ( class i assoc -- default assoc )
|
||||
2dup length 1- = [
|
||||
nth second { } rot drop
|
||||
] [
|
||||
3dup >r 1+ r> nth first class< [
|
||||
>r 1+ r> (simplify-alist)
|
||||
] [
|
||||
[ nth second ] 2keep swap 1+ tail rot drop
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: simplify-alist ( class assoc -- default assoc )
|
||||
dup empty? [
|
||||
2drop [ "Unreachable" throw ] { }
|
||||
] [
|
||||
0 swap (simplify-alist)
|
||||
] if ;
|
||||
: 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
|
||||
|
|
|
@ -3,14 +3,23 @@
|
|||
USING: inference.dataflow inference.state arrays generic io
|
||||
io.streams.string kernel math namespaces parser prettyprint
|
||||
sequences strings vectors words quotations effects classes
|
||||
continuations debugger assocs combinators compiler.errors ;
|
||||
continuations debugger assocs combinators compiler.errors
|
||||
generic.standard.engines.tuple ;
|
||||
IN: inference.backend
|
||||
|
||||
: recursive-label ( word -- label/f )
|
||||
recursive-state get at ;
|
||||
|
||||
: inline? ( word -- ? )
|
||||
dup "method-generic" word-prop swap or "inline" word-prop ;
|
||||
GENERIC: inline? ( word -- ? )
|
||||
|
||||
M: method-body inline?
|
||||
"method-generic" word-prop inline? ;
|
||||
|
||||
M: tuple-dispatch-engine-word inline?
|
||||
"tuple-dispatch-generic" word-prop inline? ;
|
||||
|
||||
M: word inline?
|
||||
"inline" word-prop ;
|
||||
|
||||
: local-recursive-state ( -- assoc )
|
||||
recursive-state get dup keys
|
||||
|
|
|
@ -120,7 +120,7 @@ M: object xyz ;
|
|||
[
|
||||
[ no-cond ] 1
|
||||
[ 1array dup quotation? [ >quotation ] unless ] times
|
||||
] \ type inlined?
|
||||
] \ quotation? inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
|
||||
|
|
|
@ -383,9 +383,6 @@ set-primitive-effect
|
|||
\ millis { } { integer } <effect> set-primitive-effect
|
||||
\ millis make-flushable
|
||||
|
||||
\ type { object } { fixnum } <effect> set-primitive-effect
|
||||
\ type make-foldable
|
||||
|
||||
\ tag { object } { fixnum } <effect> set-primitive-effect
|
||||
\ tag make-foldable
|
||||
|
||||
|
|
|
@ -413,12 +413,6 @@ HELP: clone
|
|||
{ $values { "obj" object } { "cloned" "a new object" } }
|
||||
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
|
||||
|
||||
HELP: type ( object -- n )
|
||||
{ $values { "object" object } { "n" "a type number" } }
|
||||
{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
|
||||
|
||||
{ type tag type>class } related-words
|
||||
|
||||
HELP: ? ( ? true false -- true/false )
|
||||
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
|
||||
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel.private ;
|
||||
USING: kernel.private slots.private ;
|
||||
IN: kernel
|
||||
|
||||
! Stack stuff
|
||||
|
@ -99,14 +99,14 @@ DEFER: if
|
|||
|
||||
! Appliers
|
||||
: bi@ ( x y quot -- )
|
||||
tuck 2slip call ; inline
|
||||
dup bi* ; inline
|
||||
|
||||
: tri@ ( x y z quot -- )
|
||||
tuck >r bi@ r> call ; inline
|
||||
dup dup tri* ; inline
|
||||
|
||||
! Double appliers
|
||||
: 2bi@ ( w x y z quot -- )
|
||||
dup -roll 3slip call ; inline
|
||||
dup 2bi* ; inline
|
||||
|
||||
: while ( pred body tail -- )
|
||||
>r >r dup slip r> r> roll
|
||||
|
@ -194,6 +194,8 @@ GENERIC: construct-boa ( ... class -- tuple )
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: hi-tag ( obj -- n ) 0 slot ;
|
||||
|
||||
: declare ( spec -- ) drop ;
|
||||
|
||||
: do-primitive ( number -- ) "Improper primitive call" throw ;
|
||||
|
|
|
@ -14,7 +14,7 @@ HELP: tag-mask
|
|||
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
|
||||
|
||||
HELP: num-types
|
||||
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ;
|
||||
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
|
||||
|
||||
HELP: tag-number
|
||||
{ $values { "class" class } { "n" "an integer or " { $link f } } }
|
||||
|
@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits
|
|||
|
||||
ARTICLE: "layouts-types" "Type numbers"
|
||||
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
|
||||
{ $subsection type }
|
||||
{ $subsection hi-tag }
|
||||
"Built-in type numbers can be converted to classes, and vice versa:"
|
||||
{ $subsection type>class }
|
||||
{ $subsection type-number }
|
||||
|
|
|
@ -87,29 +87,6 @@ sequences.private combinators ;
|
|||
{ { @ @ } [ 2drop t ] }
|
||||
} define-identities
|
||||
|
||||
! type applied to an object of a known type can be folded
|
||||
: known-type? ( node -- ? )
|
||||
node-class-first class-types length 1 number= ;
|
||||
|
||||
: fold-known-type ( node -- node )
|
||||
dup node-class-first class-types inline-literals ;
|
||||
|
||||
\ type [
|
||||
{ [ dup known-type? ] [ fold-known-type ] }
|
||||
] define-optimizers
|
||||
|
||||
! if the result of type is n, then the object has type n
|
||||
{ tag type } [
|
||||
[
|
||||
num-types get swap [
|
||||
[
|
||||
[ type>class object or 0 `input class, ] keep
|
||||
0 `output literal,
|
||||
] set-constraints
|
||||
] curry each
|
||||
] "constraints" set-word-prop
|
||||
] each
|
||||
|
||||
! Specializers
|
||||
{ 1+ 1- sq neg recip sgn } [
|
||||
{ number } "specializer" set-word-prop
|
||||
|
|
Loading…
Reference in New Issue