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

extend T{ } syntax to build structs

db4
Joe Groff 2009-08-12 15:40:06 -04:00
parent 25c3434892
commit ca592b9654
4 changed files with 27 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -87,19 +87,21 @@ ERROR: bad-literal-tuple ;
: parse-slot-values ( -- values ) : parse-slot-values ( -- values )
[ (parse-slot-values) ] { } make ; [ (parse-slot-values) ] { } make ;
: boa>tuple ( class slots -- tuple ) GENERIC# boa>object 1 ( class slots -- tuple )
M: tuple-class boa>object
swap prefix >tuple ; swap prefix >tuple ;
: assoc>tuple ( class slots -- tuple ) : assoc>object ( class slots -- tuple )
[ [ ] [ initial-values ] [ all-slots ] tri ] dip [ [ ] [ initial-values ] [ class-slots ] tri ] dip
swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map swap [ [ slot-named* drop ] curry dip ] curry assoc-map
[ dup <enum> ] dip update boa>tuple ; [ dup <enum> ] dip update boa>object ;
: parse-tuple-literal-slots ( class -- tuple ) : parse-tuple-literal-slots ( class -- tuple )
scan { scan {
{ f [ unexpected-eof ] } { f [ unexpected-eof ] }
{ "f" [ \ } parse-until boa>tuple ] } { "f" [ \ } parse-until boa>object ] }
{ "{" [ parse-slot-values assoc>tuple ] } { "{" [ parse-slot-values assoc>object ] }
{ "}" [ new ] } { "}" [ new ] }
[ bad-literal-tuple ] [ bad-literal-tuple ]
} case ; } case ;

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

@ -55,11 +55,14 @@ M: tuple class layout-of 2 slot { word } declare ;
PRIVATE> PRIVATE>
: initial-values ( class -- slots ) : tuple-initial-values ( class -- slots )
all-slots [ initial>> ] map ; all-slots [ initial>> ] map ;
: initial-values ( class -- slots )
class-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class ) : pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline [ tuple-initial-values over length tail append ] keep ; inline
: tuple>array ( tuple -- array ) : tuple>array ( tuple -- array )
prepare-tuple>array prepare-tuple>array
@ -156,7 +159,7 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ; dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype ) : tuple-prototype ( class -- prototype )
[ initial-values ] keep over [ ] any? [ tuple-initial-values ] keep over [ ] any?
[ slots>tuple ] [ 2drop f ] if ; [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- ) : define-tuple-prototype ( class -- )

5
core/slots/slots.factor
View File

@ -236,5 +236,8 @@ M: slot-spec make-slot
: finalize-slots ( specs base -- specs ) : finalize-slots ( specs base -- specs )
over length iota [ + ] with map [ >>offset ] 2map ; over length iota [ + ] with map [ >>offset ] 2map ;
: slot-named* ( name specs -- offset spec/f )
[ name>> = ] with find ;
: slot-named ( name specs -- spec/f ) : slot-named ( name specs -- spec/f )
[ name>> = ] with find nip ; slot-named* nip ;

8
extra/classes/struct/struct.factor
View File

@ -47,6 +47,14 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
M: struct-class boa M: struct-class boa
<struct-boa> ; inline <struct-boa> ; inline
: pad-struct-slots ( slots class -- slots' class )
[ class-slots [ initial>> ] map over length tail append ] keep ;
M: struct-class boa>object
swap pad-struct-slots
[ <struct> swap ] [ "struct-slots" word-prop ] bi
[ name>> setter-word execute( struct value -- struct ) ] 2each ;
! Struct slot accessors ! Struct slot accessors
M: struct-class reader-quot M: struct-class reader-quot