From 5aae4516dde997ff042211b9a584de02bb9db9e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 27 Mar 2008 01:42:13 -0500 Subject: [PATCH] Working on slot inheritance --- core/bootstrap/primitives.factor | 18 +++++--- core/classes/classes.factor | 3 ++ core/mirrors/mirrors.factor | 2 +- core/tuples/tuples-tests.factor | 26 ++++++++++-- core/tuples/tuples.factor | 71 ++++++++++++++++++++++---------- 5 files changed, 89 insertions(+), 31 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 3f6fedb40c..baa85032bc 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -324,14 +324,20 @@ define-builtin } } define-builtin -"tuple" "kernel" create { +"tuple" "kernel" create { } define-builtin + +"tuple" "kernel" lookup +{ { - { "tuple-layout" "tuples.private" } - "layout" - { "tuple-layout" "tuples.private" } - f + { "object" "kernel" } + "delegate" + { "delegate" "kernel" } + { "set-delegate" "kernel" } } -} define-builtin +} +define-tuple-slots + +"tuple" "kernel" lookup define-tuple-layout ! Define general-t type, which is any object that is not f. "general-t" "kernel" create diff --git a/core/classes/classes.factor b/core/classes/classes.factor index c2c19836cd..c21dd452ac 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -57,6 +57,9 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ; #! Output f for non-classes to work with algebra code dup class? [ "superclass" word-prop ] [ drop f ] if ; +: superclasses ( class -- supers ) + [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ; + : members ( class -- seq ) #! Output f for non-classes to work with algebra code dup class? [ "members" word-prop ] [ drop f ] if ; diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 8f12bbb2f4..7176076c7c 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -10,7 +10,7 @@ GENERIC: object-slots ( obj -- seq ) M: object object-slots class "slots" word-prop ; M: tuple object-slots - dup class "slots" word-prop + dup class superclasses [ "slots" word-prop ] map concat swap delegate [ 1 tail-slice ] unless ; TUPLE: mirror object slots ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 2d28697b70..e670c26c25 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -246,6 +246,7 @@ C: erg's-reshape-problem ! Inheritance TUPLE: computer cpu ram ; +C: computer [ "TUPLE: computer cpu ram ;" ] [ [ \ computer see ] with-string-writer string-lines second @@ -264,11 +265,23 @@ C: laptop [ t ] [ "laptop" get computer? ] unit-test [ t ] [ "laptop" get tuple? ] unit-test +[ "Pentium" ] [ "laptop" get cpu>> ] unit-test +[ 128 ] [ "laptop" get ram>> ] unit-test +[ t ] [ "laptop" get battery>> 3 hours = ] unit-test + +[ laptop ] [ + "laptop" get tuple-layout + dup layout-echelon swap + layout-superclasses nth +] unit-test + [ "TUPLE: laptop < computer battery ;" ] [ [ \ laptop see ] with-string-writer string-lines second ] unit-test -TUPLE: server < computer rackmount? ; +[ { tuple computer laptop } ] [ laptop superclasses ] unit-test + +TUPLE: server < computer rackmount ; C: server [ t ] [ server tuple-class? ] unit-test @@ -276,11 +289,15 @@ C: server [ t ] [ server computer class< ] unit-test [ t ] [ server computer classes-intersect? ] unit-test -[ ] [ "Pentium" 128 "1U" "server" set ] unit-test +[ ] [ "PowerPC" 64 "1U" "server" set ] unit-test [ t ] [ "server" get server? ] unit-test [ t ] [ "server" get computer? ] unit-test [ t ] [ "server" get tuple? ] unit-test +[ "PowerPC" ] [ "server" get cpu>> ] unit-test +[ 64 ] [ "server" get ram>> ] unit-test +[ "1U" ] [ "server" get rackmount>> ] unit-test + [ f ] [ "server" get laptop? ] unit-test [ f ] [ "laptop" get server? ] unit-test @@ -288,7 +305,10 @@ C: server [ f ] [ laptop server class< ] unit-test [ f ] [ laptop server classes-intersect? ] unit-test -[ "TUPLE: server < computer rackmount? ;" ] [ +[ f ] [ 1 2 laptop? ] unit-test +[ f ] [ \ + server? ] unit-test + +[ "TUPLE: server < computer rackmount ;" ] [ [ \ server see ] with-string-writer string-lines second ] unit-test diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 83f398242a..09dd03de2f 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 ; +compiler.units math.private ; IN: tuples M: tuple delegate 2 slot ; @@ -17,6 +17,12 @@ ERROR: no-tuple-class class ; @@ -49,33 +55,56 @@ PRIVATE> 2drop f ] if ; -M: tuple-class tuple-layout "layout" word-prop ; +! Predicate generation. We optimize at the expense of simplicity + +: (tuple-predicate-quot) ( class -- quot ) + #! 4 slot == layout-superclasses + #! 5 slot == layout-echelon + [ + [ 1 slot dup 5 slot ] % + dup tuple-layout layout-echelon , + [ fixnum>= ] % + [ + dup tuple-layout layout-echelon , + [ swap 4 slot array-nth ] % + literalize , + [ eq? ] % + ] [ ] make , + [ drop f ] , + \ if , + ] [ ] make ; + +: tuple-predicate-quot ( class -- quot ) + [ + [ dup tuple? ] % + (tuple-predicate-quot) , + [ drop f ] , + \ if , + ] [ ] make ; : define-tuple-predicate ( class -- ) - dup tuple-layout - [ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry - define-predicate ; + dup tuple-predicate-quot define-predicate ; -: delegate-slot-spec - T{ slot-spec f - object - "delegate" - 2 - delegate - set-delegate - } ; +: superclass-size ( class -- n ) + superclasses 1 head-slice* + [ "slot-names" word-prop length ] map sum ; + +: generate-tuple-slots ( class slots -- slot-specs slot-names ) + over superclass-size 2 + simple-slots + dup [ slot-spec-name ] map ; : define-tuple-slots ( class slots -- ) - dupd 3 simple-slots - 2dup [ slot-spec-name ] map "slot-names" set-word-prop - 2dup delegate-slot-spec add* "slots" set-word-prop - 2dup define-slots - define-accessors ; + 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 ; + +: make-tuple-layout ( class -- layout ) + dup superclass-size over "slot-names" word-prop length + + over superclasses dup length 1- ; : define-tuple-layout ( class -- ) - dup - dup "slot-names" word-prop length 1+ { } 0 - "layout" set-word-prop ; + dup make-tuple-layout "layout" set-word-prop ; : removed-slots ( class newslots -- seq ) swap "slot-names" word-prop seq-diff ;