diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 846cce153b..ceb011d52b 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -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 } diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index bc876c2dec..48a1117574 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -101,17 +101,24 @@ num-types get f 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. diff --git a/core/classes/classes.factor b/core/classes/classes.factor index d6d1a72121..d91b1bb217 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -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 ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index f9ed219d7b..139c6d8fdf 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -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 ] concat ] [ [ [ r> ] prepend ] map concat ] bi - append ; + append [ ] like ; : spread ( objs... seq -- ) spread>quot call ; diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index 7a8fe5d735..fadc57dc8d 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -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 3 100000 pick set-nth diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 081a8fd47c..a82208e9b9 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -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 diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 261ada025b..80a786c9fa 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -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 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 7dba7eb709..dc98883654 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -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 ; diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor new file mode 100644 index 0000000000..bf8d4fb67a --- /dev/null +++ b/core/generic/standard/engines/engines.factor @@ -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) ; diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor new file mode 100644 index 0000000000..2d43a313f0 --- /dev/null +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -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 + +: 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 ; diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor new file mode 100644 index 0000000000..fd40af0e50 --- /dev/null +++ b/core/generic/standard/engines/tag/tag.factor @@ -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 + +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + hi-tag \ convert-methods ; + +: direct-dispatch-quot ( alist n -- quot ) + default get + [ 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 ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor new file mode 100644 index 0000000000..ce0f50337d --- /dev/null +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -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 + +TUPLE: trivial-tuple-dispatch-engine methods ; + +C: 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 ; + +: ( methods -- engine ) + echelon-sort + [ dupd ] assoc-map + \ tuple-dispatch-engine construct-boa ; + +: convert-tuple-methods ( assoc -- assoc' ) + tuple \ 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 + [ ] 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 ; + +: ( engine -- word ) + tuple-dispatch-engine-word-name f + [ 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 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>> [ + 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 ; diff --git a/core/generic/standard/new/new-tests.factor b/core/generic/standard/new/new-tests.factor new file mode 100644 index 0000000000..d372926f43 --- /dev/null +++ b/core/generic/standard/new/new-tests.factor @@ -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 + +TUPLE: parallelogram < abstract-rectangle skew ; + +C: parallelogram + +TUPLE: circle < shape radius ; + +C: circle + +GENERIC: area + +M: abstract-rectangle area [ width>> ] [ height>> ] bi * ; + +M: circle area radius>> sq pi * ; + +[ 12 ] [ 4 3 area ] unit-test +[ 12 ] [ 4 3 2 area ] unit-test +[ t ] [ 2 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 perimiter ] unit-test +[ 30 ] [ 10 4 3 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 big-mix-test ] unit-test +[ "parallelogram" ] [ 10 4 3 big-mix-test ] unit-test +[ "circle" ] [ 100 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 diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor new file mode 100644 index 0000000000..b2371cc4e5 --- /dev/null +++ b/core/generic/standard/new/new.factor @@ -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 ] 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 ; + +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; + +: 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 [ + + ] [ + + ] if + ] bi + engine>quot + ] bi + ] with-scope ; + +TUPLE: standard-combination # ; + +C: 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 + +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 ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 4ed883dad5..65b66e9538 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -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 diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 5ca9b1b2e7..61412ccf9f 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -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 diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 67b8616c61..7d18aaa489 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -120,7 +120,7 @@ M: object xyz ; [ [ no-cond ] 1 [ 1array dup quotation? [ >quotation ] unless ] times - ] \ type inlined? + ] \ quotation? inlined? ] unit-test [ f ] [ [ length ] \ slot inlined? ] unit-test diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 79e41c8ae4..3cc78831a3 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -383,9 +383,6 @@ set-primitive-effect \ millis { } { integer } set-primitive-effect \ millis make-flushable -\ type { object } { fixnum } set-primitive-effect -\ type make-foldable - \ tag { object } { fixnum } set-primitive-effect \ tag make-foldable diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index b1120de8e6..2df5e69998 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -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" } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index ab42a1b903..eed5b22e5f 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -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 ) class } { $subsection type-number } diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 108c715ef0..a4782078ee 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -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