1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes.tuple classes.tuple.private
4 combinators combinators.smart fry functors kernel macros math parser
5 sequences sequences.private ;
6 FROM: inverse => undo ;
9 ERROR: not-final class ;
13 MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
15 : tuple-arity ( class -- quot ) '[ _ boa ] inputs ; inline
17 : tuple-slice ( n seq -- slice )
18 [ n>> [ * dup ] keep + ] [ seq>> ] bi <slice-unsafe> ; inline
20 : read-tuple ( slice class -- tuple )
21 '[ _ boa-unsafe ] input<sequence-unsafe ; inline
23 MACRO: write-tuple ( class -- quot )
24 [ '[ [ _ boa ] undo ] ]
25 [ tuple-arity <iota> <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
28 : check-final ( class -- )
29 tuple-class check-instance
30 final-class check-instance
35 <FUNCTOR: define-tuple-array ( CLASS -- )
39 CLASS-array DEFINES-CLASS ${CLASS}-array
40 CLASS-array? IS ${CLASS-array}?
42 <CLASS-array> DEFINES <${CLASS}-array>
43 >CLASS-array DEFINES >${CLASS}-array
50 { seq array read-only }
51 { n array-capacity read-only }
52 { length array-capacity read-only } ;
54 : <CLASS-array> ( length -- tuple-array )
55 [ \ CLASS [ initial-values <repetition> concat ] [ tuple-arity ] bi ] keep
56 \ CLASS-array boa ; inline
58 M: CLASS-array length length>> ; inline
60 M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline
62 M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline
64 M: CLASS-array new-sequence drop <CLASS-array> ; inline
66 : >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
68 M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline
70 INSTANCE: CLASS-array sequence
74 SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ;