From 271ef297220202ab492fb8517bc699ebca7526c2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 30 Mar 2008 12:18:42 -0500 Subject: [PATCH 01/21] Formatting license --- license.txt | 46 ++++++++++++++++++++++------------------------ 1 file changed, 22 insertions(+), 24 deletions(-) diff --git a/license.txt b/license.txt index 87f170da8c..768c13c549 100644 --- a/license.txt +++ b/license.txt @@ -1,24 +1,22 @@ -/* - * Copyright (C) 2003, 2007 Slava Pestov and friends. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * 1. Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; - * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR - * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF - * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - */ +Copyright (C) 2003, 2008 Slava Pestov and friends. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. From 38cb4f13b682f577bd30ef27c7e6daf6fee43c6b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Apr 2008 01:40:12 -0500 Subject: [PATCH 02/21] Add 3cleave --- core/combinators/combinators.factor | 8 +++++++- core/inference/transforms/transforms.factor | 2 ++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e19847dbd4..276e4cb184 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -12,11 +12,17 @@ hashtables sorting ; [ [ keep ] curry ] map concat [ drop ] append ; : 2cleave ( x seq -- ) - [ [ call ] 3keep drop ] each 2drop ; + [ 2keep ] each 2drop ; : 2cleave>quot ( seq -- quot ) [ [ 2keep ] curry ] map concat [ 2drop ] append ; +: 3cleave ( x seq -- ) + [ 3keep ] each 3drop ; + +: 3cleave>quot ( seq -- quot ) + [ [ 3keep ] curry ] map concat [ 3drop ] append ; + : spread>quot ( seq -- quot ) [ length [ >r ] concat ] [ [ [ r> ] prepend ] map concat ] bi diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 200208c6a5..4d636c24f2 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -43,6 +43,8 @@ IN: inference.transforms \ 2cleave [ 2cleave>quot ] 1 define-transform +\ 3cleave [ 3cleave>quot ] 1 define-transform + \ spread [ spread>quot ] 1 define-transform ! Bitfields From 2223633b432cd5f103fceefcf026d2b382e71f64 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Apr 2008 01:40:30 -0500 Subject: [PATCH 03/21] Tweak --- core/generic/standard/standard.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 4447c5a264..3898150c3b 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -39,9 +39,7 @@ ERROR: no-method object generic ; ] [ ] make ; : class-predicates ( assoc -- assoc ) - [ - >r >r picker r> "predicate" word-prop append r> - ] assoc-map ; + [ >r "predicate" word-prop picker prepend r> ] assoc-map ; : (simplify-alist) ( class i assoc -- default assoc ) 2dup length 1- = [ From a2971bd3bef5ed9fb3e1b6cf66141156aafd2c43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 00:03:04 -0500 Subject: [PATCH 04/21] Improve walker: step into on an array recursively sets breakpoint on each quotation nested in the array. Useful for cond, case, cleave, ... --- extra/tools/walker/walker.factor | 44 ++++++++++++++++++++------------ 1 file changed, 28 insertions(+), 16 deletions(-) diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index d548c0a4f5..6bd8ace877 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -3,7 +3,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words -sequences.private assocs models ; +sequences.private assocs models arrays accessors ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -51,9 +51,16 @@ DEFER: start-walker-thread : walk ( quot -- quot' ) \ break prefix [ break rethrow ] recover ; -: add-breakpoint ( quot -- quot' ) +GENERIC: add-breakpoint ( quot -- quot' ) + +M: callable add-breakpoint dup [ break ] head? [ \ break prefix ] unless ; +M: array add-breakpoint + [ add-breakpoint ] map ; + +M: object add-breakpoint ; + : (step-into-quot) ( quot -- ) add-breakpoint call ; : (step-into-if) ? (step-into-quot) ; @@ -74,7 +81,7 @@ DEFER: start-walker-thread \ (step-into-execute) t "step-into?" set-word-prop : (step-into-continuation) - continuation callstack over set-continuation-call break ; + continuation callstack >>call break ; ! Messages sent to walker thread SYMBOL: step @@ -94,15 +101,18 @@ SYMBOL: +stopped+ : change-frame ( continuation quot -- continuation' ) #! Applies quot to innermost call frame of the #! continuation. - >r clone r> - over continuation-call clone - [ - dup innermost-frame-scan 1+ - swap innermost-frame-quot - rot call - ] keep - [ set-innermost-frame-quot ] keep - over set-continuation-call ; inline + >r clone r> [ + >r clone r> + [ + >r + [ innermost-frame-scan 1+ ] + [ innermost-frame-quot ] bi + r> call + ] + [ drop set-innermost-frame-quot ] + [ drop ] + 2tri + ] curry change-call ; inline : step-msg ( continuation -- continuation' ) [ @@ -143,6 +153,7 @@ SYMBOL: +stopped+ swap % unclip { { [ dup \ break eq? ] [ , ] } { [ dup quotation? ] [ add-breakpoint , \ break , ] } + { [ dup array? ] [ add-breakpoint , \ break , ] } { [ dup word? ] [ literalize , \ (step-into-execute) , ] } { [ t ] [ , \ break , ] } } cond % @@ -177,16 +188,17 @@ SYMBOL: +stopped+ { step-back [ f ] } { f [ +stopped+ set-status f ] } [ - dup walker-continuation tget set-model - step-into-msg + [ walker-continuation tget set-model ] + [ step-into-msg ] bi ] } case ] handle-synchronous ] [ ] while ; : step-back-msg ( continuation -- continuation' ) - walker-history tget dup pop* - empty? [ drop walker-history tget pop ] unless ; + walker-history tget + [ pop* ] + [ dup empty? [ drop ] [ nip pop ] if ] bi ; : walker-suspended ( continuation -- continuation' ) +suspended+ set-status From fa8b578370a8d23968225160c13634f9e95da8e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 00:28:07 -0500 Subject: [PATCH 05/21] Rewriting method dispatch to support inheritance --- core/bootstrap/layouts/layouts.factor | 4 +- core/bootstrap/primitives.factor | 23 ++- core/classes/classes.factor | 6 +- core/combinators/combinators.factor | 8 +- core/compiler/tests/intrinsics.factor | 8 - core/compiler/tests/templates.factor | 4 - core/cpu/x86/intrinsics/intrinsics.factor | 52 ------- core/generic/generic.factor | 8 +- core/generic/standard/engines/engines.factor | 49 ++++++ .../engines/predicate/predicate.factor | 28 ++++ core/generic/standard/engines/tag/tag.factor | 48 ++++++ .../standard/engines/tuple/tuple.factor | 109 ++++++++++++++ core/generic/standard/new/new-tests.factor | 141 ++++++++++++++++++ core/generic/standard/new/new.factor | 139 +++++++++++++++++ core/generic/standard/standard.factor | 24 +-- core/inference/backend/backend.factor | 15 +- core/inference/class/class-tests.factor | 2 +- core/inference/known-words/known-words.factor | 3 - core/kernel/kernel-docs.factor | 6 - core/kernel/kernel.factor | 10 +- core/layouts/layouts-docs.factor | 4 +- core/optimizer/known-words/known-words.factor | 23 --- 22 files changed, 573 insertions(+), 141 deletions(-) create mode 100644 core/generic/standard/engines/engines.factor create mode 100644 core/generic/standard/engines/predicate/predicate.factor create mode 100644 core/generic/standard/engines/tag/tag.factor create mode 100644 core/generic/standard/engines/tuple/tuple.factor create mode 100644 core/generic/standard/new/new-tests.factor create mode 100644 core/generic/standard/new/new.factor 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 From f96a43c42daaa07a4c63940f77552733e3309950 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 00:45:30 -0500 Subject: [PATCH 06/21] Getting ready to drop in new dispatch code --- core/classes/algebra/algebra-tests.factor | 2 +- core/generic/standard/engines/tag/tag.factor | 2 +- core/generic/standard/new/new.factor | 6 ++++++ core/generic/standard/standard.factor | 2 +- 4 files changed, 9 insertions(+), 3 deletions(-) diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index cdf817e31d..dc65b09579 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -96,7 +96,7 @@ UNION: z1 b1 c1 ; [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test -[ f ] [ growable hi-tag classes-intersect? ] unit-test +[ f ] [ growable \ hi-tag classes-intersect? ] unit-test [ t ] [ growable tuple sequence class-and class< diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index fd40af0e50..1bcd007d0d 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -13,7 +13,7 @@ TUPLE: hi-tag-dispatch-engine methods ; C: hi-tag-dispatch-engine : convert-hi-tag-methods ( assoc -- assoc' ) - hi-tag \ convert-methods ; + \ hi-tag \ convert-methods ; : direct-dispatch-quot ( alist n -- quot ) default get diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor index b2371cc4e5..00c33e38fd 100644 --- a/core/generic/standard/new/new.factor +++ b/core/generic/standard/new/new.factor @@ -100,6 +100,9 @@ PREDICATE: simple-generic < standard-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 ; @@ -118,6 +121,9 @@ PREDICATE: hook-generic < generic 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 ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 65b66e9538..b77c0ed9e5 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -77,7 +77,7 @@ ERROR: no-method object generic ; [ small-generic ] picker class-hash-dispatch-quot ; : vtable-class ( n -- class ) - bootstrap-type>class [ hi-tag bootstrap-word ] unless* ; + bootstrap-type>class [ \ hi-tag bootstrap-word ] unless* ; : group-methods ( assoc -- vtable ) #! Input is a predicate -> method association. From 7a596ce004972a0e8ddea4cc959ce3185f7feaa6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 02:44:10 -0500 Subject: [PATCH 07/21] Debugging inheritancE --- core/assocs/assocs.factor | 26 ++- core/classes/algebra/algebra-tests.factor | 2 +- core/classes/classes.factor | 40 ++-- core/classes/predicate/predicate.factor | 11 +- core/classes/tuple/tuple-tests.factor | 4 +- core/classes/tuple/tuple.factor | 34 ++- core/classes/union/union.factor | 28 +-- core/cpu/ppc/intrinsics/intrinsics.factor | 49 ---- core/generic/generic-docs.factor | 9 - core/generic/standard/engines/tag/tag.factor | 5 +- core/generic/standard/new/new.factor | 145 ------------ ...new-tests.factor => standard-tests.factor} | 8 +- core/generic/standard/standard.factor | 219 +++++++----------- core/mirrors/mirrors.factor | 21 -- .../specializers/specializers.factor | 3 +- 15 files changed, 177 insertions(+), 427 deletions(-) delete mode 100644 core/generic/standard/new/new.factor rename core/generic/standard/{new/new-tests.factor => standard-tests.factor} (94%) mode change 100755 => 100644 core/generic/standard/standard.factor diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index b911faf672..6b6bd3d51a 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -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 + +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 diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index dc65b09579..32664dc823 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -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 ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index d91b1bb217..914e070e03 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -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 ) diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index b2a5a03bb4..0f98f1f5c4 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -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 { diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index db0e25f091..228de8aabf 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -62,13 +62,13 @@ C: 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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 3cacef25a1..bbc221b85d 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 ; @@ -240,6 +235,9 @@ M: object construct-boa ( ... class -- tuple ) tuple-layout ; ! Deprecated +M: object get-slots ( obj slots -- ... ) + [ execute ] with each ; + M: object set-slots ( ... obj slots -- ) get-slots ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index e9b98770dc..9079974a60 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -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 ; diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 07698eaa92..d092473960 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -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 ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 56de801e7a..100475455a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -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" diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index 1bcd007d0d..3dd8b83579 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -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 ; diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor deleted file mode 100644 index 00c33e38fd..0000000000 --- a/core/generic/standard/new/new.factor +++ /dev/null @@ -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 ] 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-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 - -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 ; diff --git a/core/generic/standard/new/new-tests.factor b/core/generic/standard/standard-tests.factor similarity index 94% rename from core/generic/standard/new/new-tests.factor rename to core/generic/standard/standard-tests.factor index d372926f43..fbca22471c 100644 --- a/core/generic/standard/new/new-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -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 ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor old mode 100755 new mode 100644 index b77c0ed9e5..1de41f24ed --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -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 - -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 ] 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 ; +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; -: 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 - -: 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 [ + + ] [ + + ] if + ] bi + engine>quot + ] bi + ] with-scope ; -: define-simple-generic ( word -- ) - T{ standard-combination f 0 } define-generic ; +TUPLE: standard-combination # ; + +C: 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 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 ; diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index fde8728858..a13e1331fa 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -48,27 +48,6 @@ M: mirror assoc-size mirror-slots length ; INSTANCE: mirror assoc -TUPLE: enum seq ; - -C: 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 diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index cbdb1b9ec4..d115d0a1c6 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -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 ) From 8fde3fb914f178fbe6c2e48077a947640e98a6dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 18:50:21 -0500 Subject: [PATCH 08/21] More inheritance debugging --- core/bootstrap/image/image.factor | 1 + core/bootstrap/primitives.factor | 100 ++++++++++-------- core/bootstrap/stage1.factor | 1 - core/classes/algebra/algebra.factor | 10 +- core/classes/classes.factor | 10 +- core/classes/tuple/tuple-tests.factor | 4 +- core/generic/generic-docs.factor | 7 +- core/generic/generic-tests.factor | 31 ------ core/generic/generic.factor | 43 ++++---- core/generic/math/math.factor | 4 +- .../engines/predicate/predicate.factor | 4 + core/generic/standard/engines/tag/tag.factor | 32 ++++-- .../standard/engines/tuple/tuple.factor | 37 +++++-- core/generic/standard/standard.factor | 39 +++---- core/kernel/kernel.factor | 2 +- core/words/words.factor | 5 +- 16 files changed, 174 insertions(+), 156 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index fc963683b6..f0d9b77981 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -444,6 +444,7 @@ PRIVATE> "resource:/core/bootstrap/stage1.factor" run-file build-image write-image + \ word-props target-word ] with-scope ; : make-images ( -- ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 48a1117574..6c4462ed98 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -31,6 +31,7 @@ crossref off "syntax" vocab vocab-words bootstrap-syntax set H{ } clone dictionary set H{ } clone changed-words set +H{ } clone forgotten-definitions set H{ } clone root-cache set H{ } clone source-files set H{ } clone update-map set @@ -126,27 +127,49 @@ num-types get f builtins set : register-builtin ( class -- ) [ dup lookup-type-number "type" set-word-prop ] [ dup "type" word-prop builtins get set-nth ] - bi ; + [ f f builtin-class define-class ] + tri ; : define-builtin-slots ( symbol slotspec -- ) [ drop ] [ 1 simple-slots ] 2bi [ "slots" set-word-prop ] [ define-slots ] 2bi ; : define-builtin ( symbol slotspec -- ) - >r - { - [ register-builtin ] - [ f f builtin-class define-class ] - [ define-builtin-predicate ] - [ ] - } cleave + >r [ define-builtin-predicate ] keep r> define-builtin-slots ; -! Forward definitions -"object" "kernel" create t "class" set-word-prop -"object" "kernel" create union-class "metaclass" set-word-prop +"fixnum" "math" create register-builtin +"bignum" "math" create register-builtin +"tuple" "kernel" create register-builtin +"ratio" "math" create register-builtin +"float" "math" create register-builtin +"complex" "math" create register-builtin +"f" "syntax" lookup register-builtin +"array" "arrays" create register-builtin +"wrapper" "kernel" create register-builtin +"float-array" "float-arrays" create register-builtin +"callstack" "kernel" create register-builtin +"string" "strings" create register-builtin +"bit-array" "bit-arrays" create register-builtin +"quotation" "quotations" create register-builtin +"dll" "alien" create register-builtin +"alien" "alien" create register-builtin +"word" "words" create register-builtin +"byte-array" "byte-arrays" create register-builtin +"tuple-layout" "classes.tuple.private" create register-builtin -"null" "kernel" create drop +! Catch-all class for providing a default method. +"object" "kernel" create [ drop t ] "predicate" set-word-prop +"object" "kernel" create +f builtins get [ ] subset union-class define-class + +! Class of objects with object tag +"hi-tag" "kernel.private" create +f builtins get num-tags get tail union-class define-class + +! Empty class with no instances +"null" "kernel" create [ drop f ] "predicate" set-word-prop +"null" "kernel" create f { } union-class define-class "fixnum" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop @@ -335,23 +358,25 @@ define-builtin } } define-builtin -"tuple" "kernel" create { } define-builtin - -"tuple" "kernel" lookup -{ - { - { "object" "kernel" } - "delegate" - { "delegate" "kernel" } - { "set-delegate" "kernel" } - } -} -[ drop ] [ generate-tuple-slots ] 2bi -[ [ name>> ] map "slot-names" set-word-prop ] -[ "slots" set-word-prop ] -[ define-slots ] 2tri - -"tuple" "kernel" lookup define-tuple-layout +"tuple" "kernel" create { + [ { } define-builtin ] + [ { "delegate" } "slot-names" set-word-prop ] + [ define-tuple-layout ] + [ + { + { + { "object" "kernel" } + "delegate" + { "delegate" "kernel" } + { "set-delegate" "kernel" } + } + } + [ drop ] [ generate-tuple-slots ] 2bi + [ "slots" set-word-prop ] + [ define-slots ] + 2bi + ] +} cleave ! Define general-t type, which is any object that is not f. "general-t" "kernel" create @@ -359,23 +384,10 @@ f "f" "syntax" lookup builtins get remove [ ] subset union-class define-class "f" "syntax" create [ not ] "predicate" set-word-prop -"f?" "syntax" create "syntax" vocab-words delete-at +"f?" "syntax" vocab-words delete-at "general-t" "kernel" create [ ] "predicate" set-word-prop -"general-t?" "kernel" create "syntax" vocab-words delete-at - -! Catch-all class for providing a default method. -"object" "kernel" create [ drop t ] "predicate" set-word-prop -"object" "kernel" create -f builtins get [ ] subset union-class define-class - -! Class of objects with object tag -"hi-tag" "kernel.private" create -f builtins get num-tags get tail union-class define-class - -! Null class with no instances. -"null" "kernel" create [ drop f ] "predicate" set-word-prop -"null" "kernel" create f { } union-class define-class +"general-t?" "kernel" vocab-words delete-at ! Create special tombstone values "tombstone" "hashtables.private" create diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 34f758c9df..f99c8eb82f 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ; ! Rehash hashtables, since bootstrap.image creates them ! using the host image's hashing algorithms [ hashtable? ] instances [ rehash ] each - boot ] % diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 5d7c114cbc..97309dbea2 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel classes combinators accessors sequences arrays vectors assocs namespaces words sorting layouts math hashtables -; +kernel.private ; IN: classes.algebra : 2cache ( key1 key2 assoc quot -- value ) @@ -211,12 +211,6 @@ C: anonymous-complement : flatten-class ( class -- assoc ) [ (flatten-class) ] H{ } make-assoc ; -: class-hashes ( class -- seq ) - flatten-class keys [ - dup builtin-class? - [ "type" word-prop ] [ hashcode ] if - ] map ; - : flatten-builtin-class ( class -- assoc ) flatten-class [ dup tuple class< [ 2drop tuple tuple ] when @@ -229,5 +223,5 @@ C: anonymous-complement : class-tags ( class -- tag/f ) class-types [ dup num-tags get >= - [ drop object tag-number ] when + [ drop \ hi-tag tag-number ] when ] map prune ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 914e070e03..0baf235edb 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -25,9 +25,11 @@ SYMBOL: class-or-cache class-and-cache get clear-assoc class-or-cache get clear-assoc ; -PREDICATE: class < word ( obj -- ? ) "class" word-prop ; - SYMBOL: update-map + +PREDICATE: class < word + "class" word-prop ; + SYMBOL: builtins PREDICATE: builtin-class < class @@ -58,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ; dup class? [ "superclass" word-prop ] [ drop f ] if ; : superclasses ( class -- supers ) - [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ; + [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ; : members ( class -- seq ) #! Output f for non-classes to work with algebra code @@ -72,7 +74,7 @@ M: word reset-class drop ; ! update-map : class-uses ( class -- seq ) - dup members swap superclass [ suffix ] when* ; + [ members ] [ superclass ] bi [ suffix ] when* ; : class-usages ( class -- assoc ) [ update-map get at ] closure ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 228de8aabf..ff34c25416 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -394,7 +394,9 @@ test-server-slot-values ! Reshape crash TUPLE: test1 a ; TUPLE: test2 < test1 b ; -T{ test2 f "a" "b" } "test" set +C: test2 + +"a" "b" "test" set : test-a/b [ "a" ] [ "test" get a>> ] unit-test diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 100475455a..04252b6b3b 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -37,7 +37,6 @@ $nl { $subsection create-method } "Method definitions can be looked up:" { $subsection method } -{ $subsection methods } "A generic word contains methods; the list of methods specializing on a class can also be obtained:" { $subsection implementors } "Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:" @@ -120,10 +119,6 @@ HELP: { $values { "class" class } { "generic" generic } { "method" "a new method definition" } } { $description "Creates a new method." } ; -HELP: methods -{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } -{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ; - HELP: order { $values { "generic" generic } { "seq" "a sequence of classes" } } { $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ; @@ -151,4 +146,4 @@ HELP: forget-methods { $values { "class" class } } { $description "Remove all method definitions which specialize on the class." } ; -{ sort-classes methods order } related-words +{ sort-classes order } related-words diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 6a7f8f29fc..fd313d8165 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -171,37 +171,6 @@ M: f tag-and-f 4 ; [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test -! define-class hashing issue -TUPLE: debug-combination ; - -M: debug-combination make-default-method - 2drop [ "Oops" throw ] ; - -M: debug-combination perform-combination - drop - order [ dup class-hashes ] { } map>assoc sort-keys - 1quotation ; - -SYMBOL: redefinition-test-generic - -[ - redefinition-test-generic - T{ debug-combination } - define-generic -] with-compilation-unit - -TUPLE: redefinition-test-tuple ; - -"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval - -[ t ] [ - [ - redefinition-test-generic , - "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval - redefinition-test-generic , - ] { } make all-equal? -] unit-test - ! Issues with forget GENERIC: generic-forget-test-1 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index dc98883654..2ec285146e 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -25,8 +25,9 @@ PREDICATE: generic < word M: generic definition drop f ; : make-generic ( word -- ) - dup { "unannotated-def" } reset-props - dup dup "combination" word-prop perform-combination define ; + [ { "unannotated-def" } reset-props ] + [ dup "combination" word-prop perform-combination ] + bi ; : method ( class generic -- method/f ) "methods" word-prop at ; @@ -37,13 +38,6 @@ 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 sort-methods ; - TUPLE: check-method class generic ; : check-method ( class generic -- class generic ) @@ -64,6 +58,9 @@ PREDICATE: method-body < word M: method-body stack-effect "method-generic" word-prop stack-effect ; +M: method-body crossref? + drop t ; + : method-word-props ( class generic -- assoc ) [ "method-generic" set @@ -122,9 +119,12 @@ M: method-body definer M: method-body forget* dup "forgotten" word-prop [ drop ] [ - dup "method-class" word-prop - over "method-generic" word-prop forget-method - t "forgotten" set-word-prop + [ + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + forget-method + ] + [ t "forgotten" set-word-prop ] bi ] if ; : implementors* ( classes -- words ) @@ -137,12 +137,13 @@ M: method-body forget* dup associate implementors* ; : forget-methods ( class -- ) - [ implementors ] keep [ swap 2array ] curry map forget-all ; + [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; M: class forget* ( class -- ) - dup forget-methods - dup update-map- - forget-word ; + [ forget-methods ] + [ update-map- ] + [ forget-word ] + tri ; M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; @@ -158,11 +159,15 @@ M: assoc update-methods ( assoc -- ) ] if ; M: generic subwords - dup "methods" word-prop values - swap "default-method" word-prop suffix ; + [ + [ "default-method" word-prop , ] + [ "methods" word-prop values % ] + [ "engines" word-prop % ] + tri + ] { } make ; M: generic forget-word - dup subwords [ forget ] each (forget-word) ; + [ subwords forget-all ] [ (forget-word) ] bi ; : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 85bd736139..2fda2c9621 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -71,13 +71,15 @@ M: math-combination make-default-method M: math-combination perform-combination drop + dup \ over [ dup math-class? [ \ dup [ >r 2dup r> math-method ] math-vtable ] [ over object-method ] if nip - ] math-vtable nip ; + ] math-vtable nip + define ; PREDICATE: math-generic < generic ( word -- ? ) "combination" word-prop math-combination? ; diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index 2d43a313f0..ce7d5c6c21 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -21,6 +21,10 @@ C: predicate-dispatch-engine { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] } } cond ; +: sort-methods ( assoc -- assoc' ) + [ keys sort-classes ] + [ [ dupd at ] curry ] bi { } map>assoc ; + M: predicate-dispatch-engine engine>quot methods>> clone default get object bootstrap-word pick set-at engines>quots diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index 3dd8b83579..6344bec536 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -1,26 +1,27 @@ USING: classes.private generic.standard.engines namespaces arrays assocs sequences.private quotations kernel.private -layouts math slots.private math.private kernel accessors ; +math slots.private math.private kernel accessors words +layouts ; 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 ; +: lo-tag-number ( class -- n ) + dup \ hi-tag bootstrap-word eq? [ + drop \ hi-tag tag-number + ] [ + "type" word-prop + ] if ; + M: lo-tag-dispatch-engine engine>quot - methods>> engines>quots* [ >r tag-number r> ] assoc-map + methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map [ picker % [ tag ] % [ linear-dispatch-quot @@ -29,12 +30,21 @@ M: lo-tag-dispatch-engine engine>quot ] if-small? % ] [ ] make ; +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ convert-methods ; + : num-hi-tags num-types get num-tags get - ; -: hi-tag-number type-number num-tags get - ; +: hi-tag-number ( class -- n ) + "type" word-prop num-tags get - ; : hi-tag-quot ( -- quot ) - [ 0 slot ] num-tags get [ fixnum- ] curry compose ; + [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ; M: hi-tag-dispatch-engine engine>quot methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index ce0f50337d..510d5ef732 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -2,7 +2,7 @@ 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 ; +classes.algebra math math.private quotations arrays ; TUPLE: echelon-dispatch-engine n methods ; @@ -27,17 +27,25 @@ TUPLE: tuple-dispatch-engine echelons ; : ( methods -- engine ) echelon-sort - [ dupd ] assoc-map + [ + over zero? [ + dup assoc-empty? + [ drop f ] [ values first ] if + ] [ + dupd + ] if + ] assoc-map [ nip ] assoc-subset \ tuple-dispatch-engine construct-boa ; : convert-tuple-methods ( assoc -- assoc' ) - tuple \ convert-methods ; + tuple bootstrap-word + \ 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 + >alist V{ } clone [ hashcode 1array ] distribute-buckets [ ] map ; : class-hash-dispatch-quot ( methods -- quot ) @@ -60,12 +68,20 @@ PREDICATE: tuple-dispatch-engine-word < word M: tuple-dispatch-engine-word stack-effect "tuple-dispatch-generic" word-prop stack-effect ; +M: tuple-dispatch-engine-word crossref? + drop t ; + +: remember-engine ( word -- ) + generic get "engines" word-prop push ; + : ( engine -- word ) tuple-dispatch-engine-word-name f - [ t "tuple-dispatch-engine" set-word-prop ] - [ generic get "tuple-dispatch-generic" set-word-prop ] - [ ] - tri ; + { + [ t "tuple-dispatch-engine" set-word-prop ] + [ generic get "tuple-dispatch-generic" set-word-prop ] + [ remember-engine ] + [ ] + } cleave ; : define-tuple-dispatch-engine-word ( engine quot -- word ) >r dup r> define ; @@ -104,6 +120,9 @@ M: tuple-dispatch-engine engine>quot picker % [ 1 slot 5 slot ] % echelons>> - [ [ engine>quot dup default set ] assoc-map ] with-scope + [ + tuple assumed set + [ engine>quot dup default set ] assoc-map + ] with-scope >=-case-quot % ] [ ] make ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 1de41f24ed..0d29bdecd5 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -59,29 +59,32 @@ ERROR: no-method object generic ; : find-default ( methods -- quot ) #! Side-effects methods. - object swap delete-at* [ + object bootstrap-word swap delete-at* [ drop generic get "default-method" word-prop 1quotation ] unless ; GENERIC: mangle-method ( method generic -- quot ) -: single-combination ( words -- quot ) +: single-combination ( word -- quot ) [ - object bootstrap-word assumed set - [ generic set ] - [ - "methods" word-prop - [ generic get mangle-method ] assoc-map - [ find-default default set ] + object bootstrap-word assumed set { + [ generic set ] + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] [ - generic get "inline" word-prop [ - - ] [ - - ] if - ] bi - engine>quot - ] bi + "methods" word-prop + [ generic get mangle-method ] assoc-map + [ find-default default set ] + [ + generic get "inline" word-prop [ + + ] [ + + ] if + ] bi + engine>quot + ] + } cleave ] with-scope ; TUPLE: standard-combination # ; @@ -107,7 +110,7 @@ M: standard-combination make-default-method [ empty-method ] with-standard ; M: standard-combination perform-combination - [ single-combination ] with-standard ; + [ drop ] [ [ single-combination ] with-standard ] 2bi define ; TUPLE: hook-combination var ; @@ -128,7 +131,7 @@ M: hook-combination make-default-method [ error-method ] with-hook ; M: hook-combination perform-combination - [ single-combination ] with-hook ; + [ drop ] [ [ single-combination ] with-hook ] 2bi define ; GENERIC: dispatch# ( word -- n ) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index eed5b22e5f..ae775ec116 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -194,7 +194,7 @@ GENERIC: construct-boa ( ... class -- tuple ) Date: Wed, 2 Apr 2008 18:50:35 -0500 Subject: [PATCH 09/21] Don't JIT inside heap scan loop, too fragile --- vm/data_gc.c | 1 - vm/factor.c | 24 +++++++++++++++++++----- vm/run.c | 7 +++++-- 3 files changed, 24 insertions(+), 8 deletions(-) diff --git a/vm/data_gc.c b/vm/data_gc.c index 0a1fad575a..24f7cfecb9 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -730,7 +730,6 @@ void garbage_collection(CELL gen, /* collect objects referenced from stacks and environment */ collect_roots(); - /* collect objects referenced from older generations */ collect_cards(); diff --git a/vm/factor.c b/vm/factor.c index 20667a23f5..5825f97bdd 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -36,22 +36,36 @@ void do_stage1_init(void) fprintf(stderr,"*** Stage 2 early init... "); fflush(stderr); + GROWABLE_ARRAY(words); + begin_scan(); CELL obj; while((obj = next_object()) != F) { if(type_of(obj) == WORD_TYPE) - { - F_WORD *word = untag_object(obj); - default_word_code(word,false); - update_word_xt(word); - } + GROWABLE_ADD(words,obj); } /* End heap scan */ gc_off = false; + GROWABLE_TRIM(words); + REGISTER_ROOT(words); + + CELL i; + CELL length = array_capacity(untag_object(words)); + for(i = 0; i < length; i++) + { + F_WORD *word = untag_word(array_nth(untag_array(words),i)); + REGISTER_UNTAGGED(word); + default_word_code(word,false); + UNREGISTER_UNTAGGED(word); + update_word_xt(word); + } + + UNREGISTER_ROOT(words); + iterate_code_heap(relocate_code_block); userenv[STAGE2_ENV] = T; diff --git a/vm/run.c b/vm/run.c index d03d999ffd..cec19b5445 100755 --- a/vm/run.c +++ b/vm/run.c @@ -22,8 +22,11 @@ void fix_stacks(void) be stored in registers, so callbacks must save and restore the correct values */ void save_stacks(void) { - stack_chain->datastack = ds; - stack_chain->retainstack = rs; + if(stack_chain) + { + stack_chain->datastack = ds; + stack_chain->retainstack = rs; + } } /* called on entry into a compiled callback */ From 93ebbfb7e4e39835d06daf2582044d73facda692 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 18:50:42 -0500 Subject: [PATCH 10/21] Try to fix inotify again --- extra/io/unix/linux/linux.factor | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 2ae4065fb6..0c79ce970d 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -24,8 +24,10 @@ TUPLE: inotify watches ; : ( -- port/f ) H{ } clone - inotify_init [ io-error ] [ inotify ] bi - { set-inotify-watches set-delegate } inotify construct ; + inotify_init dup 0 < [ 2drop f ] [ + inotify + { set-inotify-watches set-delegate } inotify construct + ] if ; : inotify-fd inotify get-global handle>> ; @@ -109,9 +111,12 @@ TUPLE: inotify-task ; f inotify-task ; : init-inotify ( mx -- ) - - dup inotify set-global - swap register-io-task ; + dup [ + dup inotify set-global + swap register-io-task + ] [ + 2drop + ] if ; M: inotify-task do-io-task ( task -- ) io-task-port read-notifications f ; @@ -119,7 +124,7 @@ M: inotify-task do-io-task ( task -- ) M: linux-io init-io ( -- ) [ mx set-global ] - [ [ init-inotify ] curry ignore-errors ] bi ; + [ init-inotify ] bi ; T{ linux-io } set-io-backend From 5346e1899f2fea2bccdad4ed55adbb6cfd471160 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 21:27:49 -0500 Subject: [PATCH 11/21] Working on call-next-method, and identity-tuple --- core/bootstrap/compiler/compiler.factor | 6 --- core/bootstrap/image/image.factor | 1 - core/bootstrap/primitives.factor | 25 +++++------ core/bootstrap/syntax.factor | 1 + core/classes/algebra/algebra-tests.factor | 4 +- core/classes/classes-docs.factor | 1 - core/classes/classes-tests.factor | 9 +++- core/classes/classes.factor | 5 ++- core/classes/tuple/tuple-docs.factor | 8 ---- core/classes/tuple/tuple-tests.factor | 31 +++++++++++++ core/classes/tuple/tuple.factor | 44 ++++++++----------- core/compiler/compiler-docs.factor | 15 +++++-- core/compiler/compiler.factor | 6 +++ core/definitions/definitions-tests.factor | 2 +- core/generic/generic-tests.factor | 23 ---------- core/generic/generic.factor | 23 +++++----- core/generic/math/math.factor | 4 +- .../standard/engines/tuple/tuple.factor | 2 +- core/generic/standard/standard.factor | 37 ++++++++++++---- core/inference/class/class-tests.factor | 14 +++++- core/inference/class/class.factor | 17 +++++-- core/inference/dataflow/dataflow.factor | 9 ++-- .../transforms/transforms-tests.factor | 5 ++- core/inference/transforms/transforms.factor | 10 ++++- core/kernel/kernel-docs.factor | 40 ++++++++++------- core/kernel/kernel.factor | 44 +++++++++++-------- core/optimizer/control/control.factor | 2 +- core/optimizer/inlining/inlining.factor | 12 ++++- core/optimizer/known-words/known-words.factor | 2 +- core/optimizer/math/math.factor | 2 +- core/parser/parser.factor | 12 ++++- core/prettyprint/prettyprint-tests.factor | 2 - core/sequences/sequences.factor | 3 ++ core/syntax/syntax-docs.factor | 2 +- core/syntax/syntax.factor | 6 +++ core/vocabs/vocabs.factor | 8 +--- core/words/words.factor | 2 +- extra/io/launcher/launcher.factor | 4 +- extra/io/sockets/impl/impl.factor | 9 ++-- extra/models/models.factor | 5 +-- extra/ui/freetype/freetype.factor | 5 +-- extra/ui/gadgets/gadgets.factor | 8 ++-- extra/ui/gadgets/worlds/worlds.factor | 4 +- 43 files changed, 279 insertions(+), 195 deletions(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 7d4db3c473..035d95d3ab 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -16,12 +16,6 @@ IN: bootstrap.compiler "cpu." cpu append require -: enable-compiler ( -- ) - [ optimized-recompile-hook ] recompile-hook set-global ; - -: disable-compiler ( -- ) - [ default-recompile-hook ] recompile-hook set-global ; - enable-compiler nl diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f0d9b77981..fc963683b6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -444,7 +444,6 @@ PRIVATE> "resource:/core/bootstrap/stage1.factor" run-file build-image write-image - \ word-props target-word ] with-scope ; : make-images ( -- ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6c4462ed98..f3846de5b1 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -159,17 +159,24 @@ num-types get f builtins set "tuple-layout" "classes.tuple.private" create register-builtin ! Catch-all class for providing a default method. -"object" "kernel" create [ drop t ] "predicate" set-word-prop "object" "kernel" create -f builtins get [ ] subset union-class define-class +[ f builtins get [ ] subset union-class define-class ] +[ [ drop t ] "predicate" set-word-prop ] +bi + +"object?" "kernel" vocab-words delete-at ! Class of objects with object tag "hi-tag" "kernel.private" create -f builtins get num-tags get tail union-class define-class +builtins get num-tags get tail define-union-class ! Empty class with no instances -"null" "kernel" create [ drop f ] "predicate" set-word-prop -"null" "kernel" create f { } union-class define-class +"null" "kernel" create +[ f { } union-class define-class ] +[ [ drop f ] "predicate" set-word-prop ] +bi + +"null?" "kernel" vocab-words delete-at "fixnum" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop @@ -378,17 +385,9 @@ define-builtin ] } cleave -! Define general-t type, which is any object that is not f. -"general-t" "kernel" create -f "f" "syntax" lookup builtins get remove [ ] subset union-class -define-class - "f" "syntax" create [ not ] "predicate" set-word-prop "f?" "syntax" vocab-words delete-at -"general-t" "kernel" create [ ] "predicate" set-word-prop -"general-t?" "kernel" vocab-words delete-at - ! Create special tombstone values "tombstone" "hashtables.private" create "tuple" "kernel" lookup diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index e7e90d8dd0..b3e5cb0120 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -66,6 +66,7 @@ IN: bootstrap.syntax "CS{" "<<" ">>" + "call-next-method" } [ "syntax" create drop ] each "t" "syntax" lookup define-symbol diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 32664dc823..0f468908a9 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -23,8 +23,8 @@ random inference effects kernel.private ; [ t ] [ number object number class-and* ] unit-test [ t ] [ object number number class-and* ] unit-test [ t ] [ slice reversed null class-and* ] unit-test -[ t ] [ general-t \ f null class-and* ] unit-test -[ t ] [ general-t \ f object class-or* ] unit-test +[ t ] [ \ f class-not \ f null class-and* ] unit-test +[ t ] [ \ f class-not \ f object class-or* ] unit-test TUPLE: first-one ; TUPLE: second-one ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 9573de8949..0560a0e755 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -21,7 +21,6 @@ $nl { { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } } { { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } } { { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } } - { { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } } } "The set of class predicate words is a class:" { $subsection predicate } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index ae9e6ec154..ae19f38d14 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files -compiler.units ; +compiler.units kernel.private ; IN: classes.tests ! DEFER: bah @@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 ! Test generic see and parsing [ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] [ [ \ bah see ] with-string-writer ] unit-test + +[ t ] [ 3 object instance? ] unit-test +[ t ] [ 3 fixnum instance? ] unit-test +[ f ] [ 3 float instance? ] unit-test +[ t ] [ 3 number instance? ] unit-test +[ f ] [ 3 null instance? ] unit-test +[ t ] [ "hi" \ hi-tag instance? ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 0baf235edb..c45fd7360b 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -60,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ; dup class? [ "superclass" word-prop ] [ drop f ] if ; : superclasses ( class -- supers ) - [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ; + [ superclass ] follow reverse ; : members ( class -- seq ) #! Output f for non-classes to work with algebra code @@ -133,3 +133,6 @@ GENERIC: class ( object -- class ) M: hi-tag class hi-tag type>class ; M: object class tag type>class ; + +: instance? ( obj class -- ? ) + "predicate" word-prop call ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 18c8143654..664f0545fa 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -153,14 +153,6 @@ HELP: tuple= { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } { $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ; -HELP: removed-slots -{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } } -{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ; - -HELP: forget-removed-slots -{ $values { "class" tuple-class } { "slots" "a sequence of strings" } } -{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ; - HELP: tuple { $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class." $nl diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index ff34c25416..735f328a67 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -511,3 +511,34 @@ USE: vocabs define-tuple-class ] with-compilation-unit ] unit-test + +[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with + +! Accessors not being forgotten... +[ [ ] ] [ + "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;" + + "forget-accessors-test" parse-stream +] unit-test + +[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test + +: accessor-exists? ( class name -- ? ) + >r "forget-accessors-test" "classes.tuple.tests" lookup r> + ">>" append "accessors" lookup method >boolean ; + +[ t ] [ "x" accessor-exists? ] unit-test +[ t ] [ "y" accessor-exists? ] unit-test +[ t ] [ "z" accessor-exists? ] unit-test + +[ [ ] ] [ + "IN: classes.tuple.tests GENERIC: forget-accessors-test" + + "forget-accessors-test" parse-stream +] unit-test + +[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test + +[ f ] [ "x" accessor-exists? ] unit-test +[ f ] [ "y" accessor-exists? ] unit-test +[ f ] [ "z" accessor-exists? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index bbc221b85d..ac1a7b8849 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -19,7 +19,7 @@ ERROR: no-tuple-class class ; GENERIC: tuple-layout ( object -- layout ) -M: class tuple-layout "layout" word-prop ; +M: tuple-class tuple-layout "layout" word-prop ; M: tuple tuple-layout 1 slot ; @@ -40,7 +40,9 @@ PRIVATE> [ drop ] [ no-tuple-class ] if ; : tuple>array ( tuple -- array ) - prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ; + prepare-tuple>array + >r copy-tuple-slots r> + layout-class prefix ; : tuple-slots ( tuple -- array ) prepare-tuple>array drop copy-tuple-slots ; @@ -120,15 +122,6 @@ PRIVATE> : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: removed-slots ( class newslots -- seq ) - swap slot-names seq-diff ; - -: forget-removed-slots ( class slots -- ) - dupd removed-slots [ - [ reader-word forget-method ] - [ writer-word forget-method ] 2bi - ] with each ; - : all-slot-names ( class -- slots ) superclasses [ slot-names ] map concat \ class prefix ; @@ -189,9 +182,8 @@ M: tuple-class update-class tri ] each-subclass ] - [ nip forget-removed-slots ] [ define-new-tuple-class ] - 3tri ; + 3bi ; : tuple-class-unchanged? ( class superclass slots -- ? ) rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; @@ -213,7 +205,19 @@ M: tuple-class define-tuple-class dup [ construct-boa throw ] curry define ; M: tuple-class reset-class - { "metaclass" "superclass" "slots" "layout" } reset-props ; + [ + dup "slot-names" word-prop [ + [ reader-word forget-method ] + [ writer-word forget-method ] 2bi + ] with each + ] [ + { + "metaclass" + "superclass" + "layout" + "slots" + } reset-props + ] bi ; M: tuple clone (clone) dup delegate clone over set-delegate ; @@ -228,12 +232,6 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -M: object construct-empty ( class -- tuple ) - tuple-layout ; - -M: object construct-boa ( ... class -- tuple ) - tuple-layout ; - ! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; @@ -241,10 +239,6 @@ M: object get-slots ( obj slots -- ... ) M: object set-slots ( ... obj slots -- ) get-slots ; -M: object construct ( ... slots class -- tuple ) - construct-empty [ swap set-slots ] keep ; - -: delegates ( obj -- seq ) - [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; +: delegates ( obj -- seq ) [ delegate ] follow ; : is? ( obj quot -- ? ) >r delegates r> contains? ; inline diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 3520104e1f..341d56f1d5 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser assocs words.private sequences compiler.units ; IN: compiler +HELP: enable-compiler +{ $description "Enables the optimizing compiler." } ; + +HELP: disable-compiler +{ $description "Enables the optimizing compiler." } ; + ARTICLE: "compiler-usage" "Calling the optimizing compiler" -"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly." -$nl -"The main entry point to the optimizing compiler:" +"Normally, new word definitions are recompiled automatically. This can be changed:" +{ $subsection disable-compiler } +{ $subsection enable-compiler } +"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:" { $subsection optimized-recompile-hook } "Removing a word's optimized definition:" { $subsection decompile } -"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ; +"Higher-level words can be found in " { $link "compilation-units" } "." ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 111d84cde0..a0599f79a1 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -56,5 +56,11 @@ IN: compiler compiled get >alist ] with-scope ; +: enable-compiler ( -- ) + [ optimized-recompile-hook ] recompile-hook set-global ; + +: disable-compiler ( -- ) + [ default-recompile-hook ] recompile-hook set-global ; + : recompile-all ( -- ) forget-errors all-words compile ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index ebbce4d7e2..3dc28139ea 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -4,7 +4,7 @@ compiler.units words ; TUPLE: combination-1 ; -M: combination-1 perform-combination 2drop [ ] ; +M: combination-1 perform-combination drop [ ] define ; M: combination-1 make-default-method 2drop [ "No method" throw ] ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index fd313d8165..524835f461 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -21,19 +21,6 @@ M: word class-of drop "word" ; [ "Hello world" ] [ 4 foobar foobar ] unit-test [ "Goodbye cruel world" ] [ 4 foobar ] unit-test -GENERIC: bool>str ( x -- y ) -M: general-t bool>str drop "true" ; -M: f bool>str drop "false" ; - -: str>bool - H{ - { "true" t } - { "false" f } - } at ; - -[ t ] [ t bool>str str>bool ] unit-test -[ f ] [ f bool>str str>bool ] unit-test - ! Testing unions UNION: funnies quotation float complex ; @@ -51,16 +38,6 @@ M: very-funny gooey sq ; [ 0.25 ] [ 0.5 gooey ] unit-test -DEFER: complement-test -FORGET: complement-test -GENERIC: complement-test ( x -- y ) - -M: f complement-test drop "f" ; -M: general-t complement-test drop "general-t" ; - -[ "general-t" ] [ 5 complement-test ] unit-test -[ "f" ] [ f complement-test ] unit-test - GENERIC: empty-method-test ( x -- y ) M: object empty-method-test ; TUPLE: for-arguments-sake ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 2ec285146e..b0099f770c 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -6,16 +6,7 @@ classes.algebra quotations arrays vocabs effects ; IN: generic ! Method combination protocol -GENERIC: perform-combination ( word combination -- quot ) - -M: object perform-combination - #! We delay the invalid method combination error for a - #! reason. If we call forget-vocab on a vocabulary which - #! defines a method combination, a generic using this - #! method combination, and a method on the generic, and the - #! method combination is forgotten first, then forgetting - #! the method will throw an error. We don't want that. - nip [ "Invalid method combination" throw ] curry [ ] like ; +GENERIC: perform-combination ( word combination -- ) GENERIC: make-default-method ( generic combination -- method ) @@ -38,6 +29,18 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; +: next-method-class ( class generic -- class/f ) + order [ class< ] with subset reverse dup length 1 = + [ drop f ] [ second ] if ; + +: next-method ( class generic -- class/f ) + [ next-method-class ] keep method ; + +GENERIC: next-method-quot ( class generic -- quot ) + +: (call-next-method) ( class generic -- ) + next-method-quot call ; + TUPLE: check-method class generic ; : check-method ( class generic -- class generic ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 2fda2c9621..46208744f0 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -12,9 +12,9 @@ PREDICATE: math-class < class number bootstrap-word class< ] if ; -: last/first ( seq -- pair ) dup peek swap first 2array ; +: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ; -: math-precedence ( class -- n ) +: math-precedence ( class -- pair ) { { [ dup null class< ] [ drop { -1 -1 } ] } { [ dup math-class? ] [ class-types last/first ] } diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 510d5ef732..40e749f473 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -15,7 +15,7 @@ C: trivial-tuple-dispatch-engine TUPLE: tuple-dispatch-engine echelons ; : push-echelon ( class method assoc -- ) - >r swap dup tuple-layout layout-echelon r> + >r swap dup "layout" word-prop layout-echelon r> [ ?set-at ] change-at ; : echelon-sort ( assoc -- assoc' ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 0d29bdecd5..2b2dbd2b2d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,6 +8,10 @@ generic.standard.engines.tag generic.standard.engines.predicate generic.standard.engines.tuple accessors ; IN: generic.standard +GENERIC: dispatch# ( word -- n ) + +M: word dispatch# "combination" word-prop dispatch# ; + : unpickers { [ nip ] @@ -101,7 +105,7 @@ PREDICATE: simple-generic < standard-generic T{ standard-combination f 0 } define-generic ; : with-standard ( combination quot -- quot' ) - >r #>> (dispatch#) r> with-variable ; + >r #>> (dispatch#) r> with-variable ; inline M: standard-generic mangle-method drop 1quotation ; @@ -112,6 +116,27 @@ M: standard-combination make-default-method M: standard-combination perform-combination [ drop ] [ [ single-combination ] with-standard ] 2bi define ; +M: standard-combination dispatch# #>> ; + +ERROR: inconsistent-next-method object class generic ; + +ERROR: no-next-method class generic ; + +M: standard-generic next-method-quot + [ + [ + [ [ instance? ] curry ] + [ dispatch# (picker) ] bi* prepend % + ] + [ + 2dup next-method + [ 2nip 1quotation ] + [ [ no-next-method ] 2curry ] if* , + ] + [ [ inconsistent-next-method ] 2curry , ] + 2tri + ] [ ] make ; + TUPLE: hook-combination var ; C: hook-combination @@ -124,6 +149,8 @@ PREDICATE: hook-generic < generic dip var>> [ get ] curry prepend ] with-variable ; inline +M: hook-combination dispatch# drop 0 ; + M: hook-generic mangle-method drop 1quotation [ drop ] prepend ; @@ -133,14 +160,6 @@ M: hook-combination make-default-method M: hook-combination perform-combination [ drop ] [ [ single-combination ] with-hook ] 2bi define ; -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 ; diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 7d18aaa489..b54dbe256a 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -21,7 +21,7 @@ GENERIC: mynot ( x -- y ) M: f mynot drop t ; -M: general-t mynot drop f ; +M: object mynot drop f ; GENERIC: detect-f ( x -- y ) @@ -297,3 +297,15 @@ cell-bits 32 = [ [ t ] [ [ { vector } declare nth-unsafe ] \ nth-unsafe inlined? ] unit-test + +[ t ] [ + [ + dup integer? [ + dup fixnum? [ + 1 + + ] [ + 2 + + ] if + ] when + ] \ + inlined? +] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 4aac98ce41..8269952409 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -176,9 +176,18 @@ M: pair constraint-satisfied? : predicate-constraints ( class #call -- ) [ - 0 `input class, - general-t 0 `output class, - ] set-constraints ; + ! If word outputs true, input is an instance of class + [ + 0 `input class, + \ f class-not 0 `output class, + ] set-constraints + ] [ + ! If word outputs false, input is not an instance of class + [ + class-not 0 `input class, + \ f 0 `output class, + ] set-constraints + ] 2bi ; : compute-constraints ( #call -- ) dup node-param "constraints" word-prop [ @@ -209,7 +218,7 @@ M: #push infer-classes-before M: #if child-constraints [ - general-t 0 `input class, + \ f class-not 0 `input class, f 0 `input literal, ] make-constraints ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 7fa2fbbcd3..01c0a9c5f4 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -9,15 +9,13 @@ IN: inference.dataflow : \ counter ; ! Literal value -TUPLE: value literal uid recursion ; +TUPLE: value < identity-tuple literal uid recursion ; : ( obj -- value ) recursive-state get value construct-boa ; M: value hashcode* nip value-uid ; -M: value equal? 2drop f ; - ! Result of curry TUPLE: curried obj quot ; @@ -30,13 +28,12 @@ C: composed UNION: special curried composed ; -TUPLE: node param +TUPLE: node < identity-tuple +param in-d out-d in-r out-r classes literals intervals history successor children ; -M: node equal? 2drop f ; - M: node hashcode* drop node hashcode* ; GENERIC: flatten-curry ( value -- ) diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index cb8024d3c5..3fc8f37b4f 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,6 +1,7 @@ IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel -quotations inference accessors combinators words arrays ; +quotations inference accessors combinators words arrays +classes ; : compose-n-quot >quotation ; : compose-n compose-n-quot call ; @@ -56,3 +57,5 @@ C: color [ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test [ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test + +[ fixnum instance? ] must-infer diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 06c2a8f476..d95ff9c3bc 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -3,7 +3,7 @@ USING: arrays kernel words sequences generic math namespaces quotations assocs combinators math.bitfields inference.backend inference.dataflow inference.state classes.tuple.private effects -inspector hashtables ; +inspector hashtables classes generic ; IN: inference.transforms : pop-literals ( n -- rstate seq ) @@ -98,3 +98,11 @@ M: duplicated-slots-error summary \ construct-empty 1 1 make-call-node ] if ] "infer" set-word-prop + +\ instance? [ + [ +inlined+ depends-on ] [ "predicate" word-prop ] bi +] 1 define-transform + +\ (call-next-method) [ + [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi +] 2 define-transform diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 2df5e69998..53618d4628 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -250,8 +250,9 @@ $nl { $subsection eq? } "Value comparison:" { $subsection = } -"Generic words for custom value comparison methods:" +"Custom value comparison methods:" { $subsection equal? } +{ $subsection identity-tuple } "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":" { $subsection <=> } { $subsection compare } @@ -377,10 +378,13 @@ HELP: equal? } $nl "If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word." -} +} ; + +HELP: identity-tuple +{ $class-description "A class defining an " { $link equal? } " method which always returns f." } { $examples - "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:" - { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" } + "To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:" + { $code "TUPLE: foo < identity-tuple ;" } "By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:" { $unchecked-example "T{ foo } dup = ." "t" } { $unchecked-example "T{ foo } dup clone = ." "f" } @@ -665,6 +669,11 @@ HELP: bi@ "[ p ] bi@" ">r p r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] bi@" + "[ p ] [ p ] bi*" + } } ; HELP: 2bi@ @@ -676,6 +685,11 @@ HELP: 2bi@ "[ p ] 2bi@" ">r >r p r> r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] 2bi@" + "[ p ] [ p ] 2bi*" + } } ; HELP: tri@ @@ -687,6 +701,11 @@ HELP: tri@ "[ p ] tri@" ">r >r p r> p r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] tri@" + "[ p ] [ p ] [ p ] tri*" + } } ; HELP: if ( cond true false -- ) @@ -785,19 +804,6 @@ HELP: null "The canonical empty class with no instances." } ; -HELP: general-t -{ $class-description - "The class of all objects not equal to " { $link f } "." -} -{ $examples - "Here is an implementation of " { $link if } " using generic words:" - { $code - "GENERIC# my-if 2 ( ? true false -- )" - "M: f my-if 2nip call ;" - "M: general-t my-if drop nip call ;" - } -} ; - HELP: most { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } } { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index ae775ec116..1935c89431 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 slots.private ; +USING: kernel.private slots.private classes.tuple.private ; IN: kernel ! Stack stuff @@ -114,12 +114,6 @@ DEFER: if [ 2nip call ] if ; inline ! Object protocol -GENERIC: delegate ( obj -- delegate ) - -M: object delegate drop f ; - -GENERIC: set-delegate ( delegate tuple -- ) - GENERIC: hashcode* ( depth obj -- code ) M: object hashcode* 2drop 0 ; @@ -130,6 +124,10 @@ GENERIC: equal? ( obj1 obj2 -- ? ) M: object equal? 2drop f ; +TUPLE: identity-tuple ; + +M: identity-tuple equal? 2drop f ; + : = ( obj1 obj2 -- ? ) 2dup eq? [ 2drop t ] [ equal? ] if ; inline @@ -142,18 +140,11 @@ M: object clone ; M: callstack clone (clone) ; ! Tuple construction -GENERIC# get-slots 1 ( tuple slots -- ... ) +: construct-empty ( class -- tuple ) + tuple-layout ; -GENERIC# set-slots 1 ( ... tuple slots -- ) - -GENERIC: construct-empty ( class -- tuple ) - -GENERIC: construct ( ... slots class -- tuple ) inline - -GENERIC: construct-boa ( ... class -- tuple ) - -: construct-delegate ( delegate class -- tuple ) - >r { set-delegate } r> construct ; inline +: construct-boa ( ... class -- tuple ) + tuple-layout ; ! Quotation building : 2curry ( obj1 obj2 quot -- curry ) @@ -201,3 +192,20 @@ GENERIC: construct-boa ( ... class -- tuple ) : do-primitive ( number -- ) "Improper primitive call" throw ; PRIVATE> + +! Deprecated +GENERIC: delegate ( obj -- delegate ) + +M: object delegate drop f ; + +GENERIC: set-delegate ( delegate tuple -- ) + +GENERIC# get-slots 1 ( tuple slots -- ... ) + +GENERIC# set-slots 1 ( ... tuple slots -- ) + +: construct ( ... slots class -- tuple ) + construct-empty [ swap set-slots ] keep ; inline + +: construct-delegate ( delegate class -- tuple ) + >r { set-delegate } r> construct ; inline diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index c108e3b1a7..11228c879a 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -154,7 +154,7 @@ SYMBOL: potential-loops ] [ node-class { { [ dup null class< ] [ drop f f ] } - { [ dup general-t class< ] [ drop t t ] } + { [ dup \ f class-not class< ] [ drop t t ] } { [ dup \ f class< ] [ drop f t ] } { [ t ] [ drop f f ] } } cond diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 1f3df92421..81f53b5ace 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -70,12 +70,20 @@ DEFER: (flat-length) ] if ; ! Partial dispatch of math-generic words +: normalize-math-class ( class -- class' ) + { fixnum bignum ratio float complex } + [ class< ] with find nip object or ; + : math-both-known? ( word left right -- ? ) math-class-max swap specific-method ; : inline-math-method ( #call word -- node ) - over node-input-classes first2 3dup math-both-known? - [ math-method f splice-quot ] [ 2drop 2drop t ] if ; + over node-input-classes + [ first normalize-math-class ] + [ second normalize-math-class ] bi + 3dup math-both-known? + [ math-method f splice-quot ] + [ 2drop 2drop t ] if ; : inline-method ( #call -- node ) dup node-param { diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index a4782078ee..2bce2dc94c 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -75,7 +75,7 @@ sequences.private combinators ; dup node-in-d second dup value? [ swap [ value-literal 0 `input literal, - general-t 0 `output class, + \ f class-not 0 `output class, ] set-constraints ] [ 2drop diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index abe48ec272..4ec4bfeb36 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -269,7 +269,7 @@ generic.standard system ; : comparison-constraints ( node true false -- ) >r >r dup node set intervals dup [ 2dup - r> general-t (comparison-constraints) + r> \ f class-not (comparison-constraints) r> \ f (comparison-constraints) ] [ r> r> 2drop 2drop diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 58c68a3614..2a481d413d 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -365,7 +365,17 @@ ERROR: bad-number ; : (:) CREATE-WORD parse-definition ; -: (M:) CREATE-METHOD parse-definition ; +SYMBOL: current-class +SYMBOL: current-generic + +: (M:) + CREATE-METHOD + [ + [ "method-class" word-prop current-class set ] + [ "method-generic" word-prop current-generic set ] + [ ] tri + parse-definition + ] with-scope ; : scan-object ( -- object ) scan-word dup parsing? diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 27b63ec26f..0f384b159d 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -57,8 +57,6 @@ unit-test [ ] [ \ integer see ] unit-test -[ ] [ \ general-t see ] unit-test - [ ] [ \ generic see ] unit-test [ ] [ \ duplex-stream see ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index ca46066861..01a1cb9b6a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -416,6 +416,9 @@ PRIVATE> swap >r [ push ] curry compose r> while ] keep { } like ; inline +: follow ( obj quot -- seq ) + >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline + : index ( obj seq -- n ) [ = ] with find drop ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index bd349953df..b242e65de5 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -243,7 +243,7 @@ HELP: flushable HELP: t { $syntax "t" } { $values { "t" "the canonical truth value" } } -{ $description "The canonical instance of " { $link general-t } ". It is just a symbol." } ; +{ $class-description "The canonical truth value, which is an instance of itself." } ; HELP: f { $syntax "f" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 19fdf0e45f..df135d0c1c 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -185,4 +185,10 @@ IN: bootstrap.syntax [ \ >> parse-until >quotation ] with-compilation-unit call ] define-syntax + + "call-next-method" [ + current-class get literalize parsed + current-generic get literalize parsed + \ (call-next-method) parsed + ] define-syntax ] with-compilation-unit diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index a6a5a014a7..8ef5f6f508 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -6,13 +6,11 @@ IN: vocabs SYMBOL: dictionary -TUPLE: vocab +TUPLE: vocab < identity-tuple name words main help source-loaded? docs-loaded? ; -M: vocab equal? 2drop f ; - : ( name -- vocab ) H{ } clone { set-vocab-name set-vocab-words } @@ -92,10 +90,6 @@ TUPLE: vocab-link name ; : ( name -- vocab-link ) vocab-link construct-boa ; -M: vocab-link equal? - over vocab-link? - [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ; - M: vocab-link hashcode* vocab-link-name hashcode* ; diff --git a/core/words/words.factor b/core/words/words.factor index a45e1627e9..1232a97ddc 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -173,7 +173,7 @@ GENERIC: subwords ( word -- seq ) M: word subwords drop f ; : reset-generic ( word -- ) - dup subwords [ forget ] each + dup subwords forget-all dup reset-word { "methods" "combination" "default-method" } reset-props ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 79382091ab..20c5bb92c9 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -6,7 +6,7 @@ init threads continuations math io.encodings io.streams.duplex io.nonblocking accessors ; IN: io.launcher -TUPLE: process +TUPLE: process < identity-tuple command detached @@ -65,8 +65,6 @@ M: object register-process drop ; V{ } clone over processes get set-at register-process ; -M: process equal? 2drop f ; - M: process hashcode* process-handle hashcode* ; : pass-environment? ( process -- ? ) diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index 8480fcd856..74a84c48ff 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -96,14 +96,13 @@ M: inet6 parse-sockaddr M: f parse-sockaddr nip ; : addrinfo>addrspec ( addrinfo -- addrspec ) - dup addrinfo-addr - swap addrinfo-family addrspec-of-family + [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi parse-sockaddr ; : parse-addrinfo-list ( addrinfo -- seq ) - [ dup ] - [ dup addrinfo-next swap addrinfo>addrspec ] - [ ] unfold nip [ ] subset ; + [ addrinfo-next ] follow + [ addrinfo>addrspec ] map + [ ] subset ; : prepare-resolve-host ( host serv passive? -- host' serv' flags ) #! If the port is a number, we resolve for 'http' then diff --git a/extra/models/models.factor b/extra/models/models.factor index fd84dd248f..ffb9b1127a 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -4,13 +4,12 @@ USING: generic kernel math sequences arrays assocs alarms calendar ; IN: models -TUPLE: model value connections dependencies ref locked? ; +TUPLE: model < identity-tuple +value connections dependencies ref locked? ; : ( value -- model ) V{ } clone V{ } clone 0 f model construct-boa ; -M: model equal? 2drop f ; - M: model hashcode* drop model hashcode* ; : add-dependency ( dep model -- ) diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 1963f5670a..1c83bc9713 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -27,9 +27,8 @@ DEFER: freetype \ freetype get-global expired? [ init-freetype ] when \ freetype get-global ; -TUPLE: font ascent descent height handle widths ; - -M: font equal? 2drop f ; +TUPLE: font < identity-tuple +ascent descent height handle widths ; M: font hashcode* drop font hashcode* ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index ddcaa4b979..c4f11f2e87 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -44,14 +44,12 @@ M: array rect-dim drop { 0 0 } ; : rect-union ( rect1 rect2 -- newrect ) (rect-union) ; -TUPLE: gadget +TUPLE: gadget < identity-tuple pref-dim parent children orientation focus visible? root? clipped? layout-state graft-state graft-node interior boundary model ; -M: gadget equal? 2drop f ; - M: gadget hashcode* drop gadget hashcode* ; M: gadget model-changed 2drop ; @@ -354,7 +352,7 @@ SYMBOL: in-layout? swap [ over (add-gadget) ] each relayout ; : parents ( gadget -- seq ) - [ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ; + [ gadget-parent ] follow ; : each-parent ( gadget quot -- ? ) >r parents r> all? ; inline @@ -401,7 +399,7 @@ M: f request-focus-on 2drop ; dup focusable-child swap request-focus-on ; : focus-path ( world -- seq ) - [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ; + [ gadget-parent ] follow ; : make-gadget ( quot gadget -- gadget ) [ \ make-gadget rot with-variable ] keep ; inline diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor index a44b553858..8ee64b58be 100755 --- a/extra/ui/gadgets/worlds/worlds.factor +++ b/extra/ui/gadgets/worlds/worlds.factor @@ -5,7 +5,7 @@ namespaces opengl sequences io combinators math.vectors ui.gadgets ui.gestures ui.render ui.backend inspector ; IN: ui.gadgets.worlds -TUPLE: world +TUPLE: world < identity-tuple active? focused? glass title status @@ -46,8 +46,6 @@ M: world request-focus-on ( child gadget -- ) t over set-gadget-root? dup request-focus ; -M: world equal? 2drop f ; - M: world hashcode* drop world hashcode* ; M: world pref-dim* From 337d582a811ee6c3276942acf668eb0c5be15733 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 21:31:41 -0500 Subject: [PATCH 12/21] Fix call-next-method --- core/generic/standard/standard.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 2b2dbd2b2d..c36e5f1921 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -135,6 +135,7 @@ M: standard-generic next-method-quot ] [ [ inconsistent-next-method ] 2curry , ] 2tri + \ if , ] [ ] make ; TUPLE: hook-combination var ; From a27fa2909875b302191d8c48a073b1ead0875ccc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 2 Apr 2008 21:37:26 -0500 Subject: [PATCH 13/21] Remove type, class-hash primitives --- core/bootstrap/primitives.factor | 2 -- core/inference/known-words/known-words.factor | 3 --- vm/primitives.c | 2 -- vm/run.c | 21 ------------------- vm/run.h | 2 -- 5 files changed, 30 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f3846de5b1..6c87730278 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -656,7 +656,6 @@ define-builtin { "code-room" "memory" } { "os-env" "system" } { "millis" "system" } - { "type" "kernel.private" } { "tag" "kernel.private" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } @@ -728,7 +727,6 @@ define-builtin { "(sleep)" "threads.private" } { "" "float-arrays" } { "" "classes.tuple.private" } - { "class-hash" "kernel.private" } { "callstack>array" "kernel" } { "innermost-frame-quot" "kernel.private" } { "innermost-frame-scan" "kernel.private" } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 3cc78831a3..5092b86a4d 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -386,9 +386,6 @@ set-primitive-effect \ tag { object } { fixnum } set-primitive-effect \ tag make-foldable -\ class-hash { object } { fixnum } set-primitive-effect -\ class-hash make-foldable - \ cwd { } { string } set-primitive-effect \ cd { string } { } set-primitive-effect diff --git a/vm/primitives.c b/vm/primitives.c index 203ebb7f6b..6a6aeb9d46 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -106,7 +106,6 @@ void *primitives[] = { primitive_code_room, primitive_os_env, primitive_millis, - primitive_type, primitive_tag, primitive_modify_code_heap, primitive_dlopen, @@ -178,7 +177,6 @@ void *primitives[] = { primitive_sleep, primitive_float_array, primitive_tuple_boa, - primitive_class_hash, primitive_callstack_to_array, primitive_innermost_stack_frame_quot, primitive_innermost_stack_frame_scan, diff --git a/vm/run.c b/vm/run.c index cec19b5445..282be0a447 100755 --- a/vm/run.c +++ b/vm/run.c @@ -307,32 +307,11 @@ DEFINE_PRIMITIVE(sleep) sleep_millis(to_cell(dpop())); } -DEFINE_PRIMITIVE(type) -{ - drepl(tag_fixnum(type_of(dpeek()))); -} - DEFINE_PRIMITIVE(tag) { drepl(tag_fixnum(TAG(dpeek()))); } -DEFINE_PRIMITIVE(class_hash) -{ - CELL obj = dpeek(); - CELL tag = TAG(obj); - if(tag == TUPLE_TYPE) - { - F_TUPLE *tuple = untag_object(obj); - F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); - drepl(layout->hashcode); - } - else if(tag == OBJECT_TYPE) - drepl(get(UNTAG(obj))); - else - drepl(tag_fixnum(tag)); -} - DEFINE_PRIMITIVE(slot) { F_FIXNUM slot = untag_fixnum_fast(dpop()); diff --git a/vm/run.h b/vm/run.h index 216a00b27d..c112c5f587 100755 --- a/vm/run.h +++ b/vm/run.h @@ -253,9 +253,7 @@ DECLARE_PRIMITIVE(set_os_envs); DECLARE_PRIMITIVE(eq); DECLARE_PRIMITIVE(millis); DECLARE_PRIMITIVE(sleep); -DECLARE_PRIMITIVE(type); DECLARE_PRIMITIVE(tag); -DECLARE_PRIMITIVE(class_hash); DECLARE_PRIMITIVE(slot); DECLARE_PRIMITIVE(set_slot); From 93d9722a6bb3bc9c956f10475febcbe85ddf61fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 00:21:53 -0500 Subject: [PATCH 14/21] Fix class resetting --- core/classes/mixin/mixin.factor | 2 +- core/classes/predicate/predicate.factor | 5 ++++- core/classes/tuple/tuple.factor | 1 + core/classes/union/union.factor | 2 +- core/parser/parser.factor | 13 ++++++++----- 5 files changed, 15 insertions(+), 8 deletions(-) diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index b771aa8920..aefd522269 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -7,7 +7,7 @@ IN: classes.mixin PREDICATE: mixin-class < union-class "mixin" word-prop ; M: mixin-class reset-class - { "metaclass" "members" "mixin" } reset-props ; + { "class" "metaclass" "members" "mixin" } reset-props ; : redefine-mixin-class ( class members -- ) dupd define-union-class diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 0f98f1f5c4..4729a6dd5e 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -25,5 +25,8 @@ PREDICATE: predicate-class < class M: predicate-class reset-class { - "metaclass" "predicate-definition" "superclass" + "class" + "metaclass" + "predicate-definition" + "superclass" } reset-props ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ac1a7b8849..58c6f2c581 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -212,6 +212,7 @@ M: tuple-class reset-class ] with each ] [ { + "class" "metaclass" "superclass" "layout" diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 9079974a60..09f8f88ced 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -29,4 +29,4 @@ M: union-class update-class define-union-predicate ; 2bi ; M: union-class reset-class - { "metaclass" "members" } reset-props ; + { "class" "metaclass" "members" } reset-props ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 2a481d413d..5551ac8af0 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -505,8 +505,10 @@ SYMBOL: interactive-vocabs : fix-class-words ( -- ) #! If a class word had a compound definition which was #! removed, it must go back to being a symbol. - new-definitions get first2 diff - [ nip dup reset-generic define-symbol ] assoc-each ; + new-definitions get first2 + [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ] + [ swap diff values [ class? ] subset [ reset-class ] each ] + 2bi ; : forget-smudged ( -- ) smudged-usage forget-all @@ -515,9 +517,10 @@ SYMBOL: interactive-vocabs : finish-parsing ( lines quot -- ) file get - [ record-form ] keep - [ record-definitions ] keep - record-checksum ; + [ record-form ] + [ record-definitions ] + [ record-checksum ] + tri ; : parse-stream ( stream name -- quot ) [ From cfe1c5d39e95f111f98a72faa2936fa577219fda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 00:22:10 -0500 Subject: [PATCH 15/21] Update unit test for word removal --- core/compiler/tests/templates.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index a82208e9b9..565c045e2a 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -172,14 +172,14 @@ TUPLE: my-tuple ; [ 1 t ] [ B{ 1 2 3 4 } [ { c-ptr } declare - [ 0 alien-unsigned-1 ] keep type + [ 0 alien-unsigned-1 ] keep hi-tag ] compile-call byte-array type-number = ] unit-test [ t ] [ B{ 1 2 3 4 } [ { c-ptr } declare - 0 alien-cell type + 0 alien-cell hi-tag ] compile-call alien type-number = ] unit-test From 54265a9f4c33d2f60cf87320fe4ec530dc9a0255 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 04:58:37 -0500 Subject: [PATCH 16/21] Final inheritance fixes --- core/classes/tuple/tuple-tests.factor | 11 +++ core/generic/standard/standard-tests.factor | 98 ++++++++++++++++++++- core/inference/class/class-tests.factor | 14 +++ core/inference/class/class.factor | 31 ++++--- core/optimizer/inlining/inlining.factor | 9 +- core/parser/parser.factor | 22 +++-- 6 files changed, 159 insertions(+), 26 deletions(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 735f328a67..a8e9066f56 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -542,3 +542,14 @@ USE: vocabs [ f ] [ "x" accessor-exists? ] unit-test [ f ] [ "y" accessor-exists? ] unit-test [ f ] [ "z" accessor-exists? ] unit-test + +TUPLE: another-forget-accessors-test ; + + +[ [ ] ] [ + "IN: classes.tuple.tests GENERIC: another-forget-accessors-test" + + "another-forget-accessors-test" parse-stream +] unit-test + +[ t ] [ \ another-forget-accessors-test class? ] unit-test diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index fbca22471c..2f58770b1a 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -1,7 +1,7 @@ IN: generic.standard.tests USING: tools.test math math.functions math.constants generic.standard strings sequences arrays kernel accessors -words float-arrays byte-arrays bit-arrays parser ; +words float-arrays byte-arrays bit-arrays parser namespaces ; GENERIC: lo-tag-test @@ -137,3 +137,99 @@ 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 + +! Testing next-method +TUPLE: person ; + +TUPLE: intern < person ; + +TUPLE: employee < person ; + +TUPLE: tape-monkey < employee ; + +TUPLE: manager < employee ; + +TUPLE: junior-manager < manager ; + +TUPLE: middle-manager < manager ; + +TUPLE: senior-manager < manager ; + +TUPLE: executive < senior-manager ; + +TUPLE: ceo < executive ; + +GENERIC: salary ( person -- n ) + +M: intern salary + #! Intentional mistake. + call-next-method ; + +M: employee salary drop 24000 ; + +M: manager salary call-next-method 12000 + ; + +M: middle-manager salary call-next-method 5000 + ; + +M: senior-manager salary call-next-method 15000 + ; + +M: executive salary call-next-method 2 * ; + +M: ceo salary + #! Intentional error. + drop 5 call-next-method 3 * ; + +[ salary ] must-infer + +[ 24000 ] [ employee construct-boa salary ] unit-test + +[ 24000 ] [ tape-monkey construct-boa salary ] unit-test + +[ 36000 ] [ junior-manager construct-boa salary ] unit-test + +[ 41000 ] [ middle-manager construct-boa salary ] unit-test + +[ 51000 ] [ senior-manager construct-boa salary ] unit-test + +[ 102000 ] [ executive construct-boa salary ] unit-test + +[ ceo construct-boa salary ] +[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with + +[ intern construct-boa salary ] +[ T{ no-next-method f intern salary } = ] must-fail-with + +! Weird shit +TUPLE: a ; +TUPLE: b ; +TUPLE: c ; + +UNION: x a b ; +UNION: y a c ; + +UNION: z x y ; + +GENERIC: funky* ( obj -- ) + +M: z funky* "z" , drop ; + +M: x funky* "x" , call-next-method ; + +M: y funky* "y" , call-next-method ; + +M: a funky* "a" , call-next-method ; + +M: b funky* "b" , call-next-method ; + +M: c funky* "c" , call-next-method ; + +: funky [ funky* ] { } make ; + +[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test + +[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test + +[ t ] [ + T{ a } funky + { { "a" "x" "z" } { "a" "y" "z" } } member? +] unit-test diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index b54dbe256a..038ab1d230 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ; \ >float inlined? ] unit-test +GENERIC: detect-float ( a -- b ) + +M: float detect-float ; + +[ t ] [ + [ { real float } declare + detect-float ] + \ detect-float inlined? +] unit-test + +[ t ] [ + [ { float real } declare + detect-float ] + \ detect-float inlined? +] unit-test + [ t ] [ [ 3 + = ] \ equal? inlined? ] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 8269952409..033d2cce7a 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -274,7 +274,7 @@ DEFER: (infer-classes) (merge-intervals) r> set-intervals ; : annotate-merge ( nodes #merge/#entry -- ) - 2dup merge-classes merge-intervals ; + [ merge-classes ] [ merge-intervals ] 2bi ; : merge-children ( node -- ) dup node-successor dup #merge? [ @@ -290,28 +290,31 @@ DEFER: (infer-classes) M: #label infer-classes-before ( #label -- ) #! First, infer types under the hypothesis which hold on #! entry to the recursive label. - dup 1array swap annotate-entry ; + [ 1array ] keep annotate-entry ; M: #label infer-classes-around ( #label -- ) #! Now merge the types at every recursion point with the #! entry types. - dup annotate-node - dup infer-classes-before - dup infer-children - dup collect-recursion over suffix - pick annotate-entry - node-child (infer-classes) ; + { + [ annotate-node ] + [ infer-classes-before ] + [ infer-children ] + [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ] + [ node-child (infer-classes) ] + } cleave ; M: object infer-classes-around - dup infer-classes-before - dup annotate-node - dup infer-children - merge-children ; + { + [ infer-classes-before ] + [ annotate-node ] + [ infer-children ] + [ merge-children ] + } cleave ; : (infer-classes) ( node -- ) [ - dup infer-classes-around - node-successor (infer-classes) + [ infer-classes-around ] + [ node-successor (infer-classes) ] bi ] when* ; : infer-classes-with ( node classes literals intervals -- ) diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 81f53b5ace..9d41d6eae1 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -71,8 +71,13 @@ DEFER: (flat-length) ! Partial dispatch of math-generic words : normalize-math-class ( class -- class' ) - { fixnum bignum ratio float complex } - [ class< ] with find nip object or ; + { + fixnum bignum integer + ratio rational + float real + complex number + object + } [ class< ] with find nip ; : math-both-known? ( word left right -- ? ) math-class-max swap specific-method ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 5551ac8af0..902bae29b5 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -477,18 +477,22 @@ SYMBOL: interactive-vocabs nl ] when 2drop ; -: filter-moved ( assoc -- newassoc ) - [ +: filter-moved ( assoc1 assoc2 -- seq ) + diff [ drop where dup [ first ] when file get source-file-path = - ] assoc-subset ; + ] assoc-subset keys ; -: removed-definitions ( -- definitions ) +: removed-definitions ( -- assoc1 assoc2 ) new-definitions old-definitions - [ get first2 union ] bi@ diff ; + [ get first2 union ] bi@ ; + +: removed-classes ( -- assoc1 assoc2 ) + new-definitions old-definitions + [ get second ] bi@ ; : smudged-usage ( -- usages referenced removed ) - removed-definitions filter-moved keys [ + removed-definitions filter-moved [ outside-usages [ empty? [ drop f ] [ @@ -506,9 +510,9 @@ SYMBOL: interactive-vocabs #! If a class word had a compound definition which was #! removed, it must go back to being a symbol. new-definitions get first2 - [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ] - [ swap diff values [ class? ] subset [ reset-class ] each ] - 2bi ; + filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each + removed-classes + filter-moved [ class? ] subset [ reset-class ] each ; : forget-smudged ( -- ) smudged-usage forget-all From 45cf030cbd6ed1075e626028849457969c955ef7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 05:21:45 -0500 Subject: [PATCH 17/21] Use call-next-method --- extra/smtp/smtp-tests.factor | 6 ++++++ extra/smtp/smtp.factor | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index a705a9609e..1d22ed731a 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -3,6 +3,12 @@ smtp.server kernel sequences namespaces logging accessors assocs sorting ; IN: smtp.tests +[ t ] [ + + dup clone "a" "b" set-header drop + headers>> assoc-empty? +] unit-test + { 0 0 } [ [ ] with-smtp-connection ] must-infer-as [ "hello\nworld" validate-address ] must-fail diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 13db422621..ee2b021329 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -106,7 +106,7 @@ LOG: smtp-response DEBUG TUPLE: email from to subject headers body ; M: email clone - (clone) [ clone ] change-headers ; + call-next-method [ clone ] change-headers ; : (send) ( email -- ) [ From 1ff2eaf09c9da714cd4699cddf07fba863934abf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 05:24:04 -0500 Subject: [PATCH 18/21] Move enum docs --- core/assocs/assocs-docs.factor | 14 ++++++++++++++ core/mirrors/mirrors-docs.factor | 8 -------- extra/help/handbook/handbook.factor | 1 + 3 files changed, 15 insertions(+), 8 deletions(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index b6326e1c10..9b0922d096 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -16,6 +16,20 @@ $nl "To make an assoc into an alist:" { $subsection >alist } ; +ARTICLE: "enums" "Enumerations" +"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:" +{ $subsection enum } +{ $subsection } ; + +HELP: enum +{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence." +$nl +"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ; + +HELP: +{ $values { "seq" sequence } { "enum" enum } } +{ $description "Creates a new enumeration." } ; + ARTICLE: "assocs-protocol" "Associative mapping protocol" "All associative mappings must be instances of a mixin class:" { $subsection assoc } diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor index 725a757e61..dc4315fb39 100755 --- a/core/mirrors/mirrors-docs.factor +++ b/core/mirrors/mirrors-docs.factor @@ -7,9 +7,6 @@ $nl "A mirror provides such a view of a tuple:" { $subsection mirror } { $subsection } -"An enum provides such a view of a sequence:" -{ $subsection enum } -{ $subsection } "Utility word used by developer tools which inspect objects:" { $subsection make-mirror } { $see-also "slots" } ; @@ -44,11 +41,6 @@ HELP: >mirror< { $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } } { $description "Pushes the object being viewed in the mirror together with its slots." } ; -HELP: enum -{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence." -$nl -"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ; - HELP: make-mirror { $values { "obj" object } { "assoc" assoc } } { $description "Creates an assoc which reflects the internal structure of the object." } ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index e45c49aa25..847a5952af 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -152,6 +152,7 @@ ARTICLE: "collections" "Collections" "Implementations:" { $subsection "hashtables" } { $subsection "alists" } +{ $subsection "enums" } { $heading "Other collections" } { $subsection "boxes" } { $subsection "dlists" } From 88092f2c2ae7c86c3c831f8aaaea98e31933fa8a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 05:27:38 -0500 Subject: [PATCH 19/21] Documentation update --- core/assocs/assocs-docs.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 9b0922d096..e85789a4f2 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -19,7 +19,9 @@ $nl ARTICLE: "enums" "Enumerations" "An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:" { $subsection enum } -{ $subsection } ; +{ $subsection } +"Inverting a permutation using enumerations:" +{ $example "USING: assocs sorting prettyprint ;" ": invert >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ; HELP: enum { $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence." From 16377be935bcfb1a9346d8d78c22f486baeac2a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 05:57:20 -0500 Subject: [PATCH 20/21] Use call-next-method --- core/classes/tuple/tuple.factor | 4 ++-- core/generic/generic.factor | 21 ++++++++------------- core/words/words-docs.factor | 6 +----- core/words/words.factor | 8 +------- 4 files changed, 12 insertions(+), 27 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 58c6f2c581..b1cb3f8a66 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -207,8 +207,8 @@ M: tuple-class define-tuple-class M: tuple-class reset-class [ dup "slot-names" word-prop [ - [ reader-word forget-method ] - [ writer-word forget-method ] 2bi + [ reader-word method forget ] + [ writer-word method forget ] 2bi ] with each ] [ { diff --git a/core/generic/generic.factor b/core/generic/generic.factor index b0099f770c..72948c5473 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -106,14 +106,6 @@ M: method-spec definer M: method-spec definition first2 method definition ; -: forget-method ( class generic -- ) - dup generic? [ - [ delete-at* ] with-methods - [ forget-word ] [ drop ] if - ] [ - 2drop - ] if ; - M: method-spec forget* first2 method forget* ; @@ -123,9 +115,12 @@ M: method-body definer M: method-body forget* dup "forgotten" word-prop [ drop ] [ [ - [ "method-class" word-prop ] + [ "method-class" word-prop ] [ "method-generic" word-prop ] bi - forget-method + dup generic? [ + [ delete-at* ] with-methods + [ call-next-method ] [ drop ] if + ] [ 2drop ] if ] [ t "forgotten" set-word-prop ] bi ] if ; @@ -145,7 +140,7 @@ M: method-body forget* M: class forget* ( class -- ) [ forget-methods ] [ update-map- ] - [ forget-word ] + [ call-next-method ] tri ; M: assoc update-methods ( assoc -- ) @@ -169,8 +164,8 @@ M: generic subwords tri ] { } make ; -M: generic forget-word - [ subwords forget-all ] [ (forget-word) ] bi ; +M: generic forget* + [ subwords forget-all ] [ call-next-method ] bi ; : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index eb1bd0908a..a715aab64f 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -324,11 +324,7 @@ HELP: constructor-word { $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." } { $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "" } } ; -HELP: forget-word -{ $values { "word" word } } -{ $description "Removes a word from its vocabulary. User code should call " { $link forget } " instead, since it also does the right thing when forgetting class words." } ; - -{ POSTPONE: FORGET: forget forget-word forget-vocab } related-words +{ POSTPONE: FORGET: forget forget* forget-vocab } related-words HELP: target-word { $values { "word" word } { "target" word } } diff --git a/core/words/words.factor b/core/words/words.factor index 1232a97ddc..059815e952 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -212,9 +212,7 @@ M: word where "loc" word-prop ; M: word set-where swap "loc" set-word-prop ; -GENERIC: forget-word ( word -- ) - -: (forget-word) ( word -- ) +M: word forget* dup "forgotten" word-prop [ dup delete-xref dup delete-compiled-xref @@ -222,10 +220,6 @@ GENERIC: forget-word ( word -- ) dup t "forgotten" set-word-prop ] unless drop ; -M: word forget-word (forget-word) ; - -M: word forget* forget-word ; - M: word hashcode* nip 1 slot { fixnum } declare ; From b096395e6c1486a8de01b2d9f8a92dca32e00501 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 3 Apr 2008 06:11:18 -0500 Subject: [PATCH 21/21] Fix reports.noise load error --- extra/reports/noise/noise.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 7e9496c90d..6921d1223a 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -136,7 +136,7 @@ M: lambda-word word-noise-factor : flatten-generics ( words -- words' ) [ - dup generic? [ methods values ] [ 1array ] if + dup generic? [ "methods" word-prop values ] [ 1array ] if ] map concat ; : noisy-words ( -- alist )