diff --git a/core/classes/classes.factor b/core/classes/classes.factor index ccb735f392..435c7413a3 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -101,12 +101,12 @@ M: word reset-class drop ; PRIVATE> -GENERIC: update-predicate ( class -- ) +GENERIC: update-class ( class -- ) -M: class update-predicate drop ; +M: class update-class drop ; -: update-predicates ( assoc -- ) - [ drop update-predicate ] assoc-each ; +: update-classes ( assoc -- ) + [ drop update-class ] assoc-each ; GENERIC: update-methods ( assoc -- ) @@ -114,10 +114,15 @@ GENERIC: update-methods ( assoc -- ) #! If it was already a class, update methods after. reset-caches define-class-props - over update-map- - dupd (define-class) - dup update-map+ - class-usages dup update-predicates update-methods ; + [ drop update-map- ] + [ (define-class) ] [ + drop + [ update-map+ ] [ + class-usages + [ update-classes ] + [ update-methods ] bi + ] bi + ] 2tri ; GENERIC: class ( object -- class ) inline diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 814ab0e838..e9b98770dc 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -33,10 +33,10 @@ PREDICATE: union-class < class : define-union-predicate ( class -- ) dup members union-predicate-quot define-predicate ; -M: union-class update-predicate define-union-predicate ; +M: union-class update-class define-union-predicate ; : define-union-class ( class members -- ) - >r dup f r> union-class define-class define-union-predicate ; + f swap union-class define-class ; M: union-class reset-class { "metaclass" "members" } reset-props ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 7b8c8f2997..675841816f 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -260,7 +260,7 @@ M: tuple-class see-class* dup superclass tuple eq? [ "<" text dup superclass pprint-word ] unless - "slot-names" word-prop [ text ] each + slot-names [ text ] each pprint-; block> ; M: word see-class* drop ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 09795888a8..2ae53ee05d 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -343,7 +343,7 @@ TUPLE: electronic-device ; ! Hardcore unit tests USE: threads -\ thread "slot-names" word-prop "slot-names" set +\ thread slot-names "slot-names" set [ ] [ [ @@ -361,7 +361,7 @@ USE: threads USE: vocabs -\ vocab "slot-names" word-prop "slot-names" set +\ vocab slot-names "slot-names" set [ ] [ [ diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 60606357d3..f4ab215bf0 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic classes classes.private slots.deprecated slots.private slots -compiler.units math.private ; +compiler.units math.private accessors ; IN: tuples M: tuple delegate 2 slot ; @@ -44,6 +44,9 @@ PRIVATE> 2each ] keep ; +: slot-names ( class -- seq ) + "slots" word-prop [ name>> ] map ; + : superclass-size ( class -- n ) superclasses 1 head-slice* - [ "slot-names" word-prop length ] map sum ; + [ slot-names length ] map sum ; -: generate-tuple-slots ( class slots -- slot-specs slot-names ) - over superclass-size 2 + simple-slots - dup [ slot-spec-name ] map ; +: generate-tuple-slots ( class slots -- slots ) + over superclass-size 2 + simple-slots ; : define-tuple-slots ( class slots -- ) dupd generate-tuple-slots - >r dupd "slots" set-word-prop - r> dupd "slot-names" set-word-prop - dup "slots" word-prop 2dup define-slots define-accessors ; + [ "slots" set-word-prop ] + [ define-accessors ] + [ define-slots ] 2tri ; : make-tuple-layout ( class -- layout ) - dup superclass-size over "slot-names" word-prop length + - over superclasses dup length 1- ; + [ ] + [ [ superclass-size ] [ "slots" word-prop length ] bi + ] + [ superclasses dup length 1- ] tri + ; : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; : removed-slots ( class newslots -- seq ) - swap "slot-names" word-prop seq-diff ; + swap slot-names seq-diff ; -: forget-slots ( class newslots -- ) +: forget-slots ( class slots -- ) dupd removed-slots [ - 2dup - reader-word forget-method - writer-word forget-method + [ reader-word forget-method ] + [ writer-word forget-method ] 2bi ] with each ; : permutation ( seq1 seq2 -- permutation ) @@ -126,28 +129,29 @@ PRIVATE> : reshape-tuples ( class superclass newslots -- ) nip - >r dup "slot-names" word-prop r> permutation + >r dup slot-names r> permutation [ - >r [ swap class eq? ] curry instances dup r> - [ reshape-tuple ] curry map + >r "predicate" word-prop instances dup + r> [ reshape-tuple ] curry map become ] 2curry after-compilation ; : define-new-tuple-class ( class superclass slots -- ) [ drop f tuple-class define-class ] - [ nip define-tuple-slots ] - [ + [ nip define-tuple-slots ] [ 2drop - [ define-tuple-layout ] - [ define-tuple-predicate ] - bi - ] - 3tri ; + class-usages [ + drop + [ define-tuple-layout ] + [ define-tuple-predicate ] + bi + ] assoc-each + ] 3tri ; : redefine-tuple-class ( class superclass slots -- ) [ reshape-tuples ] [ - drop + nip [ forget-slots ] [ drop changed-word ] [ drop redefined ] @@ -157,9 +161,7 @@ PRIVATE> 3tri ; : tuple-class-unchanged? ( class superclass slots -- ? ) - rot tuck - [ "superclass" word-prop = ] - [ "slot-names" word-prop = ] 2bi* and ; + rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; PRIVATE> @@ -199,9 +201,7 @@ M: tuple hashcode* ! Definition protocol M: tuple-class reset-class - { - "metaclass" "superclass" "slot-names" "slots" "layout" - } reset-props ; + { "metaclass" "superclass" "slots" "layout" } reset-props ; M: object get-slots ( obj slots -- ... ) [ execute ] with each ; diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor index 4f3bd09613..110e9b843c 100644 --- a/extra/json/writer/writer.factor +++ b/extra/json/writer/writer.factor @@ -42,7 +42,7 @@ M: sequence json-print ( array -- string ) : slots ( object -- values names ) #! Given an object return an array of slots names and a sequence of slot values #! the slot name and the slot value. - [ tuple-slots ] keep class "slot-names" word-prop ; + [ tuple-slots ] keep class slot-names ; : slots>fields ( values names -- array ) #! Convert the arrays containing the slot names and values