basis/struct-arrays/struct-arrays.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.structs byte-arrays
   4 classes.struct kernel libc math parser sequences sequences.private ;
   5 IN: struct-arrays
   6
   7 : c-type-struct-class ( c-type -- class )
   8     c-type boxed-class>> ; foldable
   9
  10 TUPLE: struct-array
  11 { underlying c-ptr read-only }
  12 { length array-capacity read-only }
  13 { element-size array-capacity read-only }
  14 { class read-only } ;
  15
  16 M: struct-array length length>> ; inline
  17 M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
  18
  19 : (nth-ptr) ( i struct-array -- alien )
  20     [ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
  21
  22 M: struct-array nth-unsafe
  23     [ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline
  24
  25 M: struct-array set-nth-unsafe
  26     [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
  27
  28 M: struct-array new-sequence
  29     [ element-size>> [ * (byte-array) ] 2keep ]
  30     [ class>> ] bi struct-array boa ; inline
  31
  32 M: struct-array resize ( n seq -- newseq )
  33     [ [ element-size>> * ] [ underlying>> ] bi resize ]
  34     [ [ element-size>> ] [ class>> ] bi ] 2bi
  35     struct-array boa ;
  36
  37 : <struct-array> ( length c-type -- struct-array )
  38     [ heap-size [ * <byte-array> ] 2keep ]
  39     [ c-type-struct-class ] bi struct-array boa ; inline
  40
  41 ERROR: bad-byte-array-length byte-array ;
  42
  43 : byte-array>struct-array ( byte-array c-type -- struct-array )
  44     [ heap-size [
  45         [ dup length ] dip /mod 0 =
  46         [ drop bad-byte-array-length ] unless
  47     ] keep ] [ c-type-struct-class ] bi struct-array boa ; inline
  48
  49 : <direct-struct-array> ( alien length c-type -- struct-array )
  50     [ heap-size ] [ c-type-struct-class ] bi struct-array boa ; inline
  51
  52 : struct-array-on ( struct length -- struct-array )
  53     [ [ >c-ptr ] [ class ] bi ] dip swap <direct-struct-array> ; inline
  54
  55 : malloc-struct-array ( length c-type -- struct-array )
  56     [ heap-size calloc ] 2keep <direct-struct-array> ; inline
  57
  58 INSTANCE: struct-array sequence
  59
  60 M: struct-type <c-array> ( len c-type -- array )
  61     dup c-array-constructor
  62     [ execute( len -- array ) ]
  63     [ <struct-array> ] ?if ; inline
  64
  65 M: struct-type <c-direct-array> ( alien len c-type -- array )
  66     dup c-direct-array-constructor
  67     [ execute( alien len -- array ) ]
  68     [ <direct-struct-array> ] ?if ; inline
  69
  70 : >struct-array ( sequence class -- struct-array )
  71     [ dup length ] dip <struct-array>
  72     [ 0 swap copy ] keep ; inline
  73
  74 SYNTAX: struct-array{
  75     \ } scan-word [ >struct-array ] curry parse-literal ;
  76
  77 SYNTAX: struct-array@
  78     scan-word [ scan-object scan-object ] dip <direct-struct-array> parsed ;
  79
  80 USING: vocabs vocabs.loader ;
  81
  82 "prettyprint" vocab [ "struct-arrays.prettyprint" require ] when