From d8abb49a9b68f8b3b8fe3f72da9bfd3a107e0a3e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 28 Mar 2008 22:59:48 -0500 Subject: [PATCH] Working on classes --- core/bootstrap/primitives.factor | 8 ++-- core/classes/classes.factor | 15 ++++--- core/classes/predicate/predicate.factor | 4 +- core/classes/union/union.factor | 2 +- core/tuples/tuples.factor | 60 ++++++++++++++----------- 5 files changed, 50 insertions(+), 39 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index baa85032bc..50dea27e7b 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -341,7 +341,7 @@ define-tuple-slots ! Define general-t type, which is any object that is not f. "general-t" "kernel" create -"f" "syntax" lookup builtins get remove [ ] subset f union-class +f "f" "syntax" lookup builtins get remove [ ] subset union-class define-class "f" "syntax" create [ not ] "predicate" set-word-prop @@ -353,15 +353,15 @@ define-class ! Catch-all class for providing a default method. "object" "kernel" create [ drop t ] "predicate" set-word-prop "object" "kernel" create -builtins get [ ] subset f union-class define-class +f builtins get [ ] subset union-class define-class ! Class of objects with object tag "hi-tag" "classes.private" create -builtins get num-tags get tail f union-class define-class +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 +"null" "kernel" create f { } union-class define-class ! Create special tombstone values "tombstone" "hashtables.private" create diff --git a/core/classes/classes.factor b/core/classes/classes.factor index c21dd452ac..ccb735f392 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -83,13 +83,12 @@ M: word reset-class drop ; : update-map- ( class -- ) dup class-uses update-map get remove-vertex ; -PRIVATE> - -: define-class-props ( members superclass metaclass -- assoc ) +: define-class-props ( superclass members metaclass -- assoc ) [ - "metaclass" set - dup [ bootstrap-word ] when "superclass" set - [ bootstrap-word ] map "members" set + [ dup [ bootstrap-word ] when "superclass" set ] + [ [ bootstrap-word ] map "members" set ] + [ "metaclass" set ] + tri* ] H{ } make-assoc ; : (define-class) ( word props -- ) @@ -100,6 +99,8 @@ PRIVATE> over "predicating" set-word-prop t "class" set-word-prop ; +PRIVATE> + GENERIC: update-predicate ( class -- ) M: class update-predicate drop ; @@ -109,7 +110,7 @@ M: class update-predicate drop ; GENERIC: update-methods ( assoc -- ) -: define-class ( word members superclass metaclass -- ) +: define-class ( word superclass members metaclass -- ) #! If it was already a class, update methods after. reset-caches define-class-props diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 9f5961895a..b2a5a03bb4 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -14,8 +14,8 @@ PREDICATE: predicate-class < class ] [ ] make ; : define-predicate-class ( class superclass definition -- ) - >r >r dup f r> predicate-class define-class r> - dupd "predicate-definition" set-word-prop + >r dupd f predicate-class define-class + r> dupd "predicate-definition" set-word-prop dup predicate-quot define-predicate ; M: predicate-class reset-class diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 3a791c22d0..814ab0e838 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -36,7 +36,7 @@ PREDICATE: union-class < class M: union-class update-predicate define-union-predicate ; : define-union-class ( class members -- ) - dupd f union-class define-class define-union-predicate ; + >r dup f r> union-class define-class define-union-predicate ; M: union-class reset-class { "metaclass" "members" } reset-props ; diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 89aff6f185..60606357d3 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -124,7 +124,8 @@ PRIVATE> [ [ swap ?nth ] [ drop f ] if* ] with map append >tuple ; -: reshape-tuples ( class newslots -- ) +: reshape-tuples ( class superclass newslots -- ) + nip >r dup "slot-names" word-prop r> permutation [ >r [ swap class eq? ] curry instances dup r> @@ -132,36 +133,45 @@ PRIVATE> become ] 2curry after-compilation ; -: tuple-class-unchanged ( class superclass slots -- ) 3drop ; - -: prepare-tuple-class ( class slots -- ) - dupd define-tuple-slots - dup define-tuple-layout - define-tuple-predicate ; - -: change-superclass "not supported" throw ; +: define-new-tuple-class ( class superclass slots -- ) + [ drop f tuple-class define-class ] + [ nip define-tuple-slots ] + [ + 2drop + [ define-tuple-layout ] + [ define-tuple-predicate ] + bi + ] + 3tri ; : redefine-tuple-class ( class superclass slots -- ) - >r 2dup swap superclass eq? - [ drop ] [ dupd change-superclass ] if r> - 2dup forget-slots - 2dup reshape-tuples - over changed-word - over redefined - prepare-tuple-class ; + [ reshape-tuples ] + [ + drop + [ forget-slots ] + [ drop changed-word ] + [ drop redefined ] + 2tri + ] + [ define-new-tuple-class ] + 3tri ; -: define-new-tuple-class ( class superclass slots -- ) - >r dupd f swap tuple-class define-class r> - prepare-tuple-class ; +: tuple-class-unchanged? ( class superclass slots -- ? ) + rot tuck + [ "superclass" word-prop = ] + [ "slot-names" word-prop = ] 2bi* and ; PRIVATE> -: define-tuple-class ( class superclass slots -- ) - { - { [ pick tuple-class? not ] [ define-new-tuple-class ] } - { [ pick "slot-names" word-prop over = ] [ tuple-class-unchanged ] } - { [ t ] [ redefine-tuple-class ] } - } cond ; +GENERIC# define-tuple-class 2 ( class superclass slots -- ) + +M: word define-tuple-class + define-new-tuple-class ; + +M: tuple-class define-tuple-class + 3dup tuple-class-unchanged? + [ 3dup redefine-tuple-class ] unless + 3drop ; : define-error-class ( class superclass slots -- ) pick >r define-tuple-class r>