Working on slot inheritance

db4
Slava Pestov 2008-03-27 01:42:13 -05:00
parent 8903ba3a32
commit 5aae4516dd
5 changed files with 89 additions and 31 deletions

View File

@ -324,14 +324,20 @@ define-builtin
} }
} define-builtin } define-builtin
"tuple" "kernel" create { "tuple" "kernel" create { } define-builtin
"tuple" "kernel" lookup
{
{ {
{ "tuple-layout" "tuples.private" } { "object" "kernel" }
"layout" "delegate"
{ "tuple-layout" "tuples.private" } { "delegate" "kernel" }
f { "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. ! Define general-t type, which is any object that is not f.
"general-t" "kernel" create "general-t" "kernel" create

View File

@ -57,6 +57,9 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
#! Output f for non-classes to work with algebra code #! Output f for non-classes to work with algebra code
dup class? [ "superclass" word-prop ] [ drop f ] if ; dup class? [ "superclass" word-prop ] [ drop f ] if ;
: superclasses ( class -- supers )
[ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
: members ( class -- seq ) : members ( class -- seq )
#! Output f for non-classes to work with algebra code #! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ; dup class? [ "members" word-prop ] [ drop f ] if ;

View File

@ -10,7 +10,7 @@ GENERIC: object-slots ( obj -- seq )
M: object object-slots class "slots" word-prop ; M: object object-slots class "slots" word-prop ;
M: tuple object-slots M: tuple object-slots
dup class "slots" word-prop dup class superclasses [ "slots" word-prop ] map concat
swap delegate [ 1 tail-slice ] unless ; swap delegate [ 1 tail-slice ] unless ;
TUPLE: mirror object slots ; TUPLE: mirror object slots ;

View File

@ -246,6 +246,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
! Inheritance ! Inheritance
TUPLE: computer cpu ram ; TUPLE: computer cpu ram ;
C: <computer> computer
[ "TUPLE: computer cpu ram ;" ] [ [ "TUPLE: computer cpu ram ;" ] [
[ \ computer see ] with-string-writer string-lines second [ \ computer see ] with-string-writer string-lines second
@ -264,11 +265,23 @@ C: <laptop> laptop
[ t ] [ "laptop" get computer? ] unit-test [ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] 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 ;" ] [ [ "TUPLE: laptop < computer battery ;" ] [
[ \ laptop see ] with-string-writer string-lines second [ \ laptop see ] with-string-writer string-lines second
] unit-test ] unit-test
TUPLE: server < computer rackmount? ; [ { tuple computer laptop } ] [ laptop superclasses ] unit-test
TUPLE: server < computer rackmount ;
C: <server> server C: <server> server
[ t ] [ server tuple-class? ] unit-test [ t ] [ server tuple-class? ] unit-test
@ -276,11 +289,15 @@ C: <server> server
[ t ] [ server computer class< ] unit-test [ t ] [ server computer class< ] unit-test
[ t ] [ server computer classes-intersect? ] unit-test [ t ] [ server computer classes-intersect? ] unit-test
[ ] [ "Pentium" 128 "1U" <server> "server" set ] unit-test [ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
[ t ] [ "server" get server? ] unit-test [ t ] [ "server" get server? ] unit-test
[ t ] [ "server" get computer? ] unit-test [ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] 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 ] [ "server" get laptop? ] unit-test
[ f ] [ "laptop" get server? ] unit-test [ f ] [ "laptop" get server? ] unit-test
@ -288,7 +305,10 @@ C: <server> server
[ f ] [ laptop server class< ] unit-test [ f ] [ laptop server class< ] unit-test
[ f ] [ laptop server classes-intersect? ] unit-test [ f ] [ laptop server classes-intersect? ] unit-test
[ "TUPLE: server < computer rackmount? ;" ] [ [ f ] [ 1 2 <computer> laptop? ] unit-test
[ f ] [ \ + server? ] unit-test
[ "TUPLE: server < computer rackmount ;" ] [
[ \ server see ] with-string-writer string-lines second [ \ server see ] with-string-writer string-lines second
] unit-test ] unit-test

View File

@ -4,7 +4,7 @@ USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic strings vectors words quotations memory combinators generic
classes classes.private slots.deprecated slots.private slots classes classes.private slots.deprecated slots.private slots
compiler.units ; compiler.units math.private ;
IN: tuples IN: tuples
M: tuple delegate 2 slot ; M: tuple delegate 2 slot ;
@ -17,6 +17,12 @@ ERROR: no-tuple-class class ;
<PRIVATE <PRIVATE
GENERIC: tuple-layout ( object -- layout )
M: class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
: tuple-size tuple-layout layout-size ; inline : tuple-size tuple-layout layout-size ; inline
PRIVATE> PRIVATE>
@ -49,33 +55,56 @@ PRIVATE>
2drop f 2drop f
] if ; ] 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 -- ) : define-tuple-predicate ( class -- )
dup tuple-layout dup tuple-predicate-quot define-predicate ;
[ over tuple? [ swap 1 slot eq? ] [ 2drop f ] if ] curry
define-predicate ;
: delegate-slot-spec : superclass-size ( class -- n )
T{ slot-spec f superclasses 1 head-slice*
object [ "slot-names" word-prop length ] map sum ;
"delegate"
2 : generate-tuple-slots ( class slots -- slot-specs slot-names )
delegate over superclass-size 2 + simple-slots
set-delegate dup [ slot-spec-name ] map ;
} ;
: define-tuple-slots ( class slots -- ) : define-tuple-slots ( class slots -- )
dupd 3 simple-slots dupd generate-tuple-slots
2dup [ slot-spec-name ] map "slot-names" set-word-prop >r dupd "slots" set-word-prop
2dup delegate-slot-spec add* "slots" set-word-prop r> dupd "slot-names" set-word-prop
2dup define-slots dup "slots" word-prop 2dup define-slots define-accessors ;
define-accessors ;
: make-tuple-layout ( class -- layout )
dup superclass-size over "slot-names" word-prop length +
over superclasses dup length 1- <tuple-layout> ;
: define-tuple-layout ( class -- ) : define-tuple-layout ( class -- )
dup dup make-tuple-layout "layout" set-word-prop ;
dup "slot-names" word-prop length 1+ { } 0 <tuple-layout>
"layout" set-word-prop ;
: removed-slots ( class newslots -- seq ) : removed-slots ( class newslots -- seq )
swap "slot-names" word-prop seq-diff ; swap "slot-names" word-prop seq-diff ;