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 fry
   5 alien.c-types alien.structs.fields cpu.architecture ;
   6 IN: alien.structs
   7
   8 TUPLE: struct-type size align fields ;
   9
  10 M: struct-type heap-size size>> ;
  11
  12 M: struct-type c-type-class drop object ;
  13
  14 M: struct-type c-type-align align>> ;
  15
  16 M: struct-type c-type-stack-align? drop f ;
  17
  18 : if-value-struct ( ctype true false -- )
  19     [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
  20
  21 M: struct-type unbox-parameter
  22     [ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
  23
  24 M: struct-type box-parameter
  25     [ %box-large-struct ] [ box-parameter ] if-value-struct ;
  26
  27 : if-small-struct ( c-type true false -- ? )
  28     [ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
  29
  30 M: struct-type unbox-return
  31     [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
  32
  33 M: struct-type box-return
  34     [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
  35
  36 M: struct-type stack-size
  37     [ heap-size ] [ stack-size ] if-value-struct ;
  38
  39 : c-struct? ( type -- ? ) (c-type) struct-type? ;
  40
  41 : (define-struct) ( name vocab size align fields -- )
  42     [ [ align ] keep ] dip
  43     struct-type boa
  44     -rot define-c-type ;
  45
  46 : define-struct-early ( name vocab fields -- fields )
  47     [ first2 <field-spec> ] with with map ;
  48
  49 : compute-struct-align ( types -- n )
  50     [ c-type-align ] map supremum ;
  51
  52 : define-struct ( name vocab fields -- )
  53     pick [
  54         [ struct-offsets ] keep
  55         [ [ type>> ] map compute-struct-align ] keep
  56         [ (define-struct) ] keep
  57     ] dip [ swap define-field ] curry each ;
  58
  59 : define-union ( name vocab members -- )
  60     [ expand-constants ] map
  61     [ [ heap-size ] map supremum ] keep
  62     compute-struct-align f (define-struct) ;