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
   5 sequences.private words fry memoize compiler.units ;
   6 IN: struct-arrays
   7
   8 : c-type-struct-class ( c-type -- class )
   9     c-type boxed-class>> ; foldable
  10
  11 TUPLE: struct-array
  12 { underlying c-ptr read-only }
  13 { length array-capacity read-only }
  14 { element-size array-capacity read-only }
  15 { class read-only }
  16 { ctor read-only } ;
  17
  18 M: struct-array length length>> ; inline
  19 M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
  20
  21 : (nth-ptr) ( i struct-array -- alien )
  22     [ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
  23
  24 M: struct-array nth-unsafe
  25     [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline
  26
  27 M: struct-array set-nth-unsafe
  28     [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
  29
  30 : (struct-element-constructor) ( c-type -- word )
  31     [
  32         "struct-array-ctor" f <word>
  33         [
  34             swap dup struct-class?
  35             [ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if
  36             (( alien -- object )) define-inline
  37         ] keep
  38     ] with-compilation-unit ;
  39
  40 ! Foldable memo word. This is an optimization; by precompiling a
  41 ! constructor for array elements, we avoid memory>struct's slow path.
  42 MEMO: struct-element-constructor ( c-type -- word )
  43     (struct-element-constructor) ; foldable
  44
  45 : <direct-struct-array> ( alien length c-type -- struct-array )
  46     [ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ]
  47     tri struct-array boa ; inline
  48
  49 M: struct-array new-sequence
  50     [ element-size>> * (byte-array) ] [ length>> ] [ class>> ] tri
  51     <direct-struct-array> ; inline
  52
  53 M: struct-array resize ( n seq -- newseq )
  54     [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi
  55     <direct-struct-array> ; inline
  56
  57 : <struct-array> ( length c-type -- struct-array )
  58     [ heap-size * <byte-array> ] 2keep <direct-struct-array> ; inline
  59
  60 ERROR: bad-byte-array-length byte-array ;
  61
  62 : byte-array>struct-array ( byte-array c-type -- struct-array )
  63     [
  64         heap-size
  65         [ dup length ] dip /mod 0 =
  66         [ drop bad-byte-array-length ] unless
  67     ] keep <direct-struct-array> ; inline
  68
  69 : struct-array-on ( struct length -- struct-array )
  70     [ [ >c-ptr ] [ class ] bi ] dip swap <direct-struct-array> ; inline
  71
  72 : malloc-struct-array ( length c-type -- struct-array )
  73     [ heap-size calloc ] 2keep <direct-struct-array> ; inline
  74
  75 INSTANCE: struct-array sequence
  76
  77 M: struct-type <c-array> ( len c-type -- array )
  78     dup c-array-constructor
  79     [ execute( len -- array ) ]
  80     [ <struct-array> ] ?if ; inline
  81
  82 M: struct-type <c-direct-array> ( alien len c-type -- array )
  83     dup c-direct-array-constructor
  84     [ execute( alien len -- array ) ]
  85     [ <direct-struct-array> ] ?if ; inline
  86
  87 : >struct-array ( sequence class -- struct-array )
  88     [ dup length ] dip <struct-array>
  89     [ 0 swap copy ] keep ; inline
  90
  91 SYNTAX: struct-array{
  92     \ } scan-word [ >struct-array ] curry parse-literal ;
  93
  94 SYNTAX: struct-array@
  95     scan-word [ scan-object scan-object ] dip <direct-struct-array> parsed ;
  96
  97 USING: vocabs vocabs.loader ;
  98
  99 "prettyprint" vocab [ "struct-arrays.prettyprint" require ] when