basis/alien/structs/structs.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs generic hashtables kernel kernel.private
   4 math namespaces parser sequences strings words libc fry
   5 alien.c-types alien.structs.fields cpu.architecture math.order
   6 quotations byte-arrays ;
   7 IN: alien.structs
   8
   9 TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
  10
  11 INSTANCE: struct-type value-type
  12
  13 M: struct-type c-type ;
  14
  15 M: struct-type c-type-stack-align? drop f ;
  16
  17 : if-value-struct ( ctype true false -- )
  18     [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
  19
  20 M: struct-type unbox-parameter
  21     [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
  22
  23 M: struct-type box-parameter
  24     [ %box-large-struct ] [ box-parameter ] if-value-struct ;
  25
  26 : if-small-struct ( c-type true false -- ? )
  27     [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
  28
  29 M: struct-type unbox-return
  30     [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
  31
  32 M: struct-type box-return
  33     [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
  34
  35 M: struct-type stack-size
  36     [ heap-size ] [ stack-size ] if-value-struct ;
  37
  38 M: struct-type c-struct? drop t ;
  39
  40 : (define-struct) ( name size align fields class -- )
  41     [ [ align ] keep ] 2dip new
  42         byte-array >>class
  43         byte-array >>boxed-class
  44         swap >>fields
  45         swap >>align
  46         swap >>size
  47         swap typedef ;
  48
  49 : make-fields ( name vocab fields -- fields )
  50     [ first2 <field-spec> ] with with map ;
  51
  52 : compute-struct-align ( types -- n )
  53     [ c-type-align ] [ max ] map-reduce ;
  54
  55 : define-struct ( name vocab fields -- )
  56     [ 2drop ] [ make-fields ] 3bi
  57     [ struct-offsets ] keep
  58     [ [ type>> ] map compute-struct-align ] keep
  59     [ struct-type (define-struct) ] keep
  60     [ define-field ] each ; deprecated
  61
  62 : define-union ( name members -- )
  63     [ [ heap-size ] [ max ] map-reduce ] keep
  64     compute-struct-align f struct-type (define-struct) ; deprecated
  65
  66 : offset-of ( field struct -- offset )
  67     c-types get at fields>>
  68     [ name>> = ] with find nip offset>> ;
  69
  70 USE: vocabs.loader
  71 "specialized-arrays" require