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

mirrors: simplify code with fry.

db4
John Benediktsson 2013-04-22 11:48:26 -07:00
parent e3c5b53610
commit 5f543dd8af
1 changed files with 11 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
basis/mirrors/mirrors.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words USING: accessors arrays assocs byte-arrays classes
arrays classes slots slots.private classes.tuple classes.tuple classes.tuple.private combinators fry hashtables
classes.tuple.private math vectors math.vectors quotations kernel math quotations sequences slots slots.private vectors ;
accessors combinators byte-arrays vocabs vocabs.loader ;
IN: mirrors IN: mirrors
TUPLE: mirror { object read-only } ; TUPLE: mirror { object read-only } ;
@ -35,21 +34,21 @@ M: mirror delete-at ( key mirror -- )
[ f ] 2dip set-at ; [ f ] 2dip set-at ;
M: mirror clear-assoc ( mirror -- ) M: mirror clear-assoc ( mirror -- )
[ object>> ] [ object-slots ] bi [ [ object-slots ] [ object>> ] bi '[
[ initial>> ] [ offset>> ] bi swapd set-slot [ initial>> ] [ offset>> _ swap set-slot ] bi
] with each ; ] each ;
M: mirror >alist ( mirror -- alist ) M: mirror >alist ( mirror -- alist )
[ object-slots [ [ name>> ] map ] [ [ offset>> ] map ] bi ] [ object-slots ] [ object>> ] bi '[
[ object>> [ swap slot ] curry ] bi [ name>> ] [ offset>> _ swap slot ] bi
map zip ; ] { } map>assoc ;
M: mirror keys ( mirror -- keys ) M: mirror keys ( mirror -- keys )
object-slots [ name>> ] map ; object-slots [ name>> ] map ;
M: mirror values ( mirror -- values ) M: mirror values ( mirror -- values )
[ object-slots [ offset>> ] map ] [ object-slots ] [ object>> ] bi
[ object>> [ swap slot ] curry ] bi map ; '[ offset>> _ swap slot ] map ;
M: mirror assoc-size object>> layout-of second ; M: mirror assoc-size object>> layout-of second ;