steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

classes.tuple: use slots>tuple when possible.

db4
John Benediktsson 2014-11-29 16:54:50 -08:00
parent a65a293896
commit c0d6fdedd1
4 changed files with 12 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -26,7 +26,7 @@ IN: compiler.tree.propagation.slots
<sequence-info> 1array ; <sequence-info> 1array ;
: fold-<tuple-boa> ( values class -- info ) : fold-<tuple-boa> ( values class -- info )
[ [ literal>> ] map ] dip prefix >tuple [ [ literal>> ] map ] dip slots>tuple
<literal-info> ; <literal-info> ;
: read-only-slots ( values class -- slots ) : read-only-slots ( values class -- slots )

8
core/bootstrap/primitives.factor
View File

@ -260,12 +260,12 @@ tuple
{ "state" } define-tuple-class { "state" } define-tuple-class
"((empty))" "hashtables.private" create "((empty))" "hashtables.private" create
"tombstone" "hashtables.private" lookup-word f { f } "tombstone" "hashtables.private" lookup-word
2array >tuple 1quotation ( -- value ) define-inline slots>tuple 1quotation ( -- value ) define-inline
"((tombstone))" "hashtables.private" create "((tombstone))" "hashtables.private" create
"tombstone" "hashtables.private" lookup-word t { t } "tombstone" "hashtables.private" lookup-word
2array >tuple 1quotation ( -- value ) define-inline slots>tuple 1quotation ( -- value ) define-inline
! Some tuple classes ! Some tuple classes
"curry" "kernel" create "curry" "kernel" create

2
core/classes/tuple/parser/parser.factor
View File

@ -94,7 +94,7 @@ ERROR: bad-slot-name class slot ;
GENERIC# boa>object 1 ( class slots -- tuple ) GENERIC# boa>object 1 ( class slots -- tuple )
M: tuple-class boa>object M: tuple-class boa>object
swap prefix >tuple ; swap slots>tuple ;
: check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index ) : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
over [ drop ] [ nip nip nip bad-slot-name ] if ; over [ drop ] [ nip nip nip bad-slot-name ] if ;

14
core/classes/tuple/tuple.factor
View File

@ -56,8 +56,8 @@ M: tuple class-of layout-of 2 slot { word } declare ; inline
: check-tuple ( object -- tuple ) : check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline dup tuple? [ not-a-tuple ] unless ; inline
: prepare-tuple>array ( tuple -- n tuple layout ) : prepare-tuple-slots ( tuple -- n tuple )
check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ; check-tuple [ tuple-size iota ] keep ;
: copy-tuple-slots ( n tuple -- array ) : copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ; [ array-nth ] curry map ;
@ -78,13 +78,8 @@ M: tuple class-of layout-of 2 slot { word } declare ; inline
PRIVATE> PRIVATE>
: tuple>array ( tuple -- array )
prepare-tuple>array
[ copy-tuple-slots ] dip
first prefix ;
: tuple-slots ( tuple -- seq ) : tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ; prepare-tuple-slots copy-tuple-slots ;
GENERIC: slots>tuple ( seq class -- tuple ) GENERIC: slots>tuple ( seq class -- tuple )
@ -96,6 +91,9 @@ M: tuple-class slots>tuple ( seq class -- tuple )
bi 2each bi 2each
] keep ; ] keep ;
: tuple>array ( tuple -- array )
[ tuple-slots ] [ layout-of first prefix ] bi ;
: >tuple ( seq -- tuple ) : >tuple ( seq -- tuple )
unclip slots>tuple ; unclip slots>tuple ;