basis/alien/structs/structs.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays generic hashtables kernel kernel.private
   4 math namespaces parser sequences strings words libc
   5 alien.c-types alien.structs.fields cpu.architecture ;
   6 IN: alien.structs
   7
   8 : if-value-structs? ( ctype true false -- )
   9     value-structs?
  10     [ drop call ] [ >r 2drop "void*" r> call ] if ; inline
  11
  12 TUPLE: struct-type size align fields ;
  13
  14 M: struct-type heap-size size>> ;
  15
  16 M: struct-type c-type-align align>> ;
  17
  18 M: struct-type c-type-stack-align? drop f ;
  19
  20 M: struct-type unbox-parameter
  21     [ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
  22
  23 M: struct-type unbox-return
  24     f swap %unbox-struct ;
  25
  26 M: struct-type box-parameter
  27     [ %box-struct ] [ box-parameter ] if-value-structs? ;
  28
  29 M: struct-type box-return
  30     f swap %box-struct ;
  31
  32 M: struct-type stack-size
  33     [ heap-size ] [ stack-size ] if-value-structs? ;
  34
  35 : c-struct? ( type -- ? ) (c-type) struct-type? ;
  36
  37 : (define-struct) ( name vocab size align fields -- )
  38     >r [ align ] keep r>
  39     struct-type boa
  40     -rot define-c-type ;
  41
  42 : define-struct-early ( name vocab fields -- fields )
  43     -rot [ rot first2 <field-spec> ] 2curry map ;
  44
  45 : compute-struct-align ( types -- n )
  46     [ c-type-align ] map supremum ;
  47
  48 : define-struct ( name vocab fields -- )
  49     pick >r
  50     [ struct-offsets ] keep
  51     [ [ type>> ] map compute-struct-align ] keep
  52     [ (define-struct) ] keep
  53     r> [ swap define-field ] curry each ;
  54
  55 : define-union ( name vocab members -- )
  56     [ expand-constants ] map
  57     [ [ heap-size ] map supremum ] keep
  58     compute-struct-align f (define-struct) ;