basis/alien/structs/fields/fields.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays kernel kernel.private math namespaces
   4 make sequences strings words effects combinators alien.c-types ;
   5 IN: alien.structs.fields
   6
   7 TUPLE: field-spec name offset type reader writer ;
   8
   9 : reader-effect ( type spec -- effect )
  10     [ 1array ] [ name>> 1array ] bi* <effect> ;
  11
  12 PREDICATE: slot-reader < word "reading" word-prop >boolean ;
  13
  14 : set-reader-props ( class spec -- )
  15     2dup reader-effect
  16     over reader>>
  17     swap "declared-effect" set-word-prop
  18     reader>> swap "reading" set-word-prop ;
  19
  20 : writer-effect ( type spec -- effect )
  21     name>> swap 2array 0 <effect> ;
  22
  23 PREDICATE: slot-writer < word "writing" word-prop >boolean ;
  24
  25 : set-writer-props ( class spec -- )
  26     2dup writer-effect
  27     over writer>>
  28     swap "declared-effect" set-word-prop
  29     writer>> swap "writing" set-word-prop ;
  30
  31 : reader-word ( class name vocab -- word )
  32     [ "-" glue ] dip create ;
  33
  34 : writer-word ( class name vocab -- word )
  35     [ [ swap "set-" % % "-" % % ] "" make ] dip create ;
  36
  37 : <field-spec> ( struct-name vocab type field-name -- spec )
  38     field-spec new
  39         0 >>offset
  40         swap >>name
  41         swap expand-constants >>type
  42         3dup name>> swap reader-word >>reader
  43         3dup name>> swap writer-word >>writer
  44     2nip ;
  45
  46 : align-offset ( offset type -- offset )
  47     c-type-align align ;
  48
  49 : struct-offsets ( specs -- size )
  50     0 [
  51         [ type>> align-offset ] keep
  52         [ (>>offset) ] [ type>> heap-size + ] 2bi
  53     ] reduce ;
  54
  55 : define-struct-slot-word ( word quot spec effect -- )
  56     [ offset>> prefix ] dip define-inline ;
  57
  58 : define-getter ( type spec -- )
  59     [ set-reader-props ] keep
  60     [ reader>> ]
  61     [
  62         type>>
  63         [ c-getter ] [ c-type-boxer-quot ] bi append
  64     ]
  65     [ ] tri
  66     (( c-ptr -- value )) define-struct-slot-word ;
  67
  68 : define-setter ( type spec -- )
  69     [ set-writer-props ] keep
  70     [ writer>> ] [ type>> c-setter ] [ ] tri
  71     (( value c-ptr -- )) define-struct-slot-word ;
  72
  73 : define-field ( type spec -- )
  74     [ define-getter ] [ define-setter ] 2bi ;