Cleaning up tuples

db4
Slava Pestov 2008-03-30 17:23:42 -05:00
parent 71283f7fc5
commit cd85b545bd
2 changed files with 59 additions and 43 deletions

View File

@ -23,8 +23,15 @@ M: class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
M: tuple-layout tuple-layout ;
: tuple-size tuple-layout layout-size ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
[ tuple-size ] [ ] [ tuple-layout ] tri ;
: copy-tuple-slots ( n tuple first -- array )
[ array-nth ] curry map r> add* ;
PRIVATE>
: check-tuple ( class -- )
@ -32,28 +39,29 @@ PRIVATE>
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
dup tuple-layout
[ layout-size swap [ array-nth ] curry map ] keep
layout-class add* ;
prepare-tuple>array >r copy-tuple-slots r> layout-class add* ;
: >tuple ( seq -- tuple )
dup first tuple-layout <tuple> [
>r 1 tail-slice dup length r>
[ tuple-size min ] keep
[ set-array-nth ] curry
2each
: tuple-slots ( tuple -- array )
prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( tuple class -- array )
tuple-layout <tuple> [
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
] keep ;
: >tuple ( tuple -- array )
unclip slots>tuple ;
: slot-names ( class -- seq )
"slots" word-prop [ name>> ] map ;
"slot-names" word-prop ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
over tuple-layout over tuple-layout eq? [
dup tuple-size -rot
[ >r over r> array-nth >r array-nth r> = ] 2curry
all-integers?
2dup [ tuple-layout ] bi@ eq? [
[ drop tuple-size ]
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
2bi all-integers?
] [
2drop f
] if ;
@ -92,18 +100,19 @@ PRIVATE>
superclasses 1 head-slice*
[ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slots )
: generate-tuple-slots ( class slots -- slot-specs )
over superclass-size 2 + simple-slots ;
: define-tuple-slots ( class slots -- )
dupd generate-tuple-slots
: define-tuple-slots ( class -- )
dup dup slot-names generate-tuple-slots
[ "slots" set-word-prop ]
[ define-accessors ]
[ define-slots ] 2tri ;
[ define-accessors ] ! new
[ define-slots ] ! old
2tri ;
: make-tuple-layout ( class -- layout )
[ ]
[ [ superclass-size ] [ "slots" word-prop length ] bi + ]
[ [ superclass-size ] [ slot-names length ] bi + ]
[ superclasses dup length 1- ] tri
<tuple-layout> ;
@ -113,7 +122,7 @@ PRIVATE>
: removed-slots ( class newslots -- seq )
swap slot-names seq-diff ;
: forget-slots ( class slots -- )
: forget-removed-slots ( class slots -- )
dupd removed-slots [
[ reader-word forget-method ]
[ writer-word forget-method ] 2bi
@ -122,36 +131,48 @@ PRIVATE>
: permutation ( seq1 seq2 -- permutation )
swap [ index ] curry map ;
: reshape-tuple ( oldtuple permutation -- newtuple )
>r tuple>array 2 cut r>
[ [ swap ?nth ] [ drop f ] if* ] with map
append >tuple ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class add* ;
: reshape-tuples ( class superclass newslots -- )
nip
>r dup slot-names r> permutation
[
>r "predicate" word-prop instances dup
r> [ reshape-tuple ] curry map
become
] 2curry after-compilation ;
: slot-permutation ( class superclass newslots -- n permutation )
[ all-slot-names ] [ all-slot-names ] [ ] tri* append
[ drop length ] [ permutation ] 2bi ;
: permute-direct-slots ( oldslots permutation -- newslots )
[ [ swap ?nth ] [ drop f ] if* ] with map ;
: permute-all-slots ( oldslots n permutation -- newslots )
[ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ;
: change-tuple ( tuple quot -- newtuple )
>r tuple>array r> call >tuple ; inline
: update-tuples ( predicate n permutation -- )
[ permute-all-slots ] 2curry [ change-tuple ] curry
>r "predicate" word-prop instances dup r> map
become ; inline
: update-tuples-after ( class superclass newslots -- )
[ 2drop ] [ slot-permutation ] 3bi
[ update-tuples ] 3curry after-compilation ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
[ nip define-tuple-slots ] [
[ nip "slot-names" set-word-prop ] [
2drop
class-usages keys [ tuple-class? ] subset [
[ define-tuple-slots ]
[ define-tuple-layout ]
[ define-tuple-predicate ]
bi
tri
] each
] 3tri ;
: redefine-tuple-class ( class superclass slots -- )
[ reshape-tuples ]
[ update-tuples-after ]
[
nip
[ forget-slots ]
[ forget-removed-slots ]
[ drop changed-word ]
[ drop redefined ]
2tri
@ -175,7 +196,7 @@ M: tuple-class define-tuple-class
3drop ;
: define-error-class ( class superclass slots -- )
pick >r define-tuple-class r>
[ define-tuple-class ] [ 2drop ] 3bi
dup [ construct-boa throw ] curry define ;
M: tuple clone
@ -196,8 +217,6 @@ M: tuple hashcode*
] 2curry reduce
] recursive-hashcode ;
: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
! Definition protocol
M: tuple-class reset-class
{ "metaclass" "superclass" "slots" "layout" } reset-props ;

View File

@ -23,9 +23,6 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;
: create-accessor ( name effect -- word )
>r "accessors" create dup r>
"declared-effect" set-word-prop ;