basis/alien/structs/structs.factor

   1 ! Copyright (C) 2004, 2007 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 slots
   5 slots.deprecated alien.c-types cpu.architecture ;
   6 IN: alien.structs
   7
   8 : align-offset ( offset type -- offset )
   9     c-type c-type-align align ;
  10
  11 : struct-offsets ( specs -- size )
  12     0 [
  13         [ class>> align-offset ] keep
  14         [ set-slot-spec-offset ] 2keep
  15         class>> heap-size +
  16     ] reduce ;
  17
  18 : define-struct-slot-word ( spec word quot -- )
  19     rot slot-spec-offset prefix define-inline ;
  20
  21 : define-getter ( type spec -- )
  22     [ set-reader-props ] keep
  23     [ ]
  24     [ slot-spec-reader ]
  25     [
  26         class>>
  27         [ c-getter ] [ c-type c-type-boxer-quot ] bi append
  28     ] tri
  29     define-struct-slot-word ;
  30
  31 : define-setter ( type spec -- )
  32     [ set-writer-props ] keep
  33     [ ]
  34     [ slot-spec-writer ]
  35     [ class>> c-setter ] tri
  36     define-struct-slot-word ;
  37
  38 : define-field ( type spec -- )
  39     2dup define-getter define-setter ;
  40
  41 : if-value-structs? ( ctype true false -- )
  42     value-structs?
  43     [ drop call ] [ >r 2drop "void*" r> call ] if ; inline
  44
  45 TUPLE: struct-type size align fields ;
  46
  47 M: struct-type heap-size struct-type-size ;
  48
  49 M: struct-type c-type-align struct-type-align ;
  50
  51 M: struct-type c-type-stack-align? drop f ;
  52
  53 M: struct-type unbox-parameter
  54     [ heap-size %unbox-struct ]
  55     [ unbox-parameter ]
  56     if-value-structs? ;
  57
  58 M: struct-type unbox-return
  59     f swap heap-size %unbox-struct ;
  60
  61 M: struct-type box-parameter
  62     [ heap-size %box-struct ]
  63     [ box-parameter ]
  64     if-value-structs? ;
  65
  66 M: struct-type box-return
  67     f swap heap-size %box-struct ;
  68
  69 M: struct-type stack-size
  70     [ heap-size ] [ stack-size ] if-value-structs? ;
  71
  72 : c-struct? ( type -- ? ) (c-type) struct-type? ;
  73
  74 : (define-struct) ( name vocab size align fields -- )
  75     >r [ align ] keep r>
  76     struct-type boa
  77     -rot define-c-type ;
  78
  79 : make-field ( struct-name vocab type field-name -- spec )
  80     <slot-spec>
  81         0 >>offset
  82         swap >>name
  83         swap expand-constants >>class
  84         3dup name>> swap reader-word >>reader
  85         3dup name>> swap writer-word >>writer
  86     2nip ;
  87
  88 : define-struct-early ( name vocab fields -- fields )
  89     -rot [ rot first2 make-field ] 2curry map ;
  90
  91 : compute-struct-align ( types -- n )
  92     [ c-type-align ] map supremum ;
  93
  94 : define-struct ( name vocab fields -- )
  95     pick >r
  96     [ struct-offsets ] keep
  97     [ [ class>> ] map compute-struct-align ] keep
  98     [ (define-struct) ] keep
  99     r> [ swap define-field ] curry each ;
 100
 101 : define-union ( name vocab members -- )
 102     [ expand-constants ] map
 103     [ [ heap-size ] map supremum ] keep
 104     compute-struct-align f (define-struct) ;