basis/gobject-introspection/types/types.factor

   1 ! Copyright (C) 2010 Anton Gorenko.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types assocs combinators.short-circuit
   4 gobject-introspection.common gobject-introspection.repository
   5 kernel namespaces parser sequences sets ;
   6 IN: gobject-introspection.types
   7
   8 SYMBOL: type-infos
   9 type-infos [ H{ } ] initialize
  10
  11 SYMBOL: standard-types
  12 standard-types [ V{ } ] initialize
  13
  14 TUPLE: type-info c-type ;
  15
  16 TUPLE: atomic-info < type-info ;
  17 TUPLE: enum-info < type-info ;
  18 TUPLE: bitfield-info < type-info ;
  19 TUPLE: record-info < type-info ;
  20 TUPLE: union-info < type-info ;
  21 TUPLE: boxed-info < type-info ;
  22 TUPLE: callback-info < type-info ;
  23 TUPLE: class-info < type-info ;
  24 TUPLE: interface-info < type-info ;
  25
  26 DEFER: find-type-info
  27
  28 PREDICATE: none-type < simple-type
  29     name>> "none" = ;
  30
  31 PREDICATE: atomic-type < simple-type
  32     find-type-info atomic-info? ;
  33
  34 PREDICATE: utf8-type < atomic-type
  35     name>> "utf8" = ;
  36
  37 PREDICATE: enum-type < simple-type
  38     find-type-info enum-info? ;
  39
  40 PREDICATE: bitfield-type < simple-type
  41     find-type-info bitfield-info? ;
  42
  43 PREDICATE: record-type < simple-type
  44     find-type-info record-info? ;
  45
  46 PREDICATE: union-type < simple-type
  47     find-type-info union-info? ;
  48
  49 PREDICATE: boxed-type < simple-type
  50     find-type-info boxed-info? ;
  51
  52 PREDICATE: callback-type < simple-type
  53     find-type-info callback-info? ;
  54
  55 PREDICATE: class-type < simple-type
  56     find-type-info class-info? ;
  57
  58 PREDICATE: interface-type < simple-type
  59     find-type-info interface-info? ;
  60
  61 PREDICATE: boxed-array-type < array-type name>> >boolean ;
  62 PREDICATE: c-array-type < array-type name>> not ;
  63 PREDICATE: fixed-size-array-type < c-array-type fixed-size>> >boolean ;
  64
  65 : standard-type? ( data-type -- ? )
  66     name>> standard-types get-global in? ;
  67
  68 : qualified-name ( name -- qualified-name )
  69     current-namespace-name get-global swap "." glue ;
  70
  71 : qualified-type-name ( data-type -- name )
  72     [ name>> ] keep {
  73         [ name>> CHAR: . swap member? ]
  74         [ none-type? ]
  75         [ standard-type? ]
  76     } 1|| [ qualified-name ] unless ;
  77
  78 ERROR: unknown-type-error type ;
  79
  80 : get-type-info ( data-type -- info )
  81     qualified-type-name dup type-infos get-global at
  82     [ ] [ unknown-type-error ] ?if ;
  83
  84 : find-type-info ( data-type -- info/f )
  85     qualified-type-name type-infos get-global at ;
  86
  87 :: register-type ( c-type type-info name -- )
  88     type-info c-type >>c-type name
  89     type-infos get-global set-at ;
  90
  91 : register-standard-type ( c-type name -- )
  92     dup standard-types get-global adjoin
  93     atomic-info new swap register-type ;
  94
  95 : register-atomic-type ( c-type name -- )
  96     atomic-info new swap register-type ;
  97
  98 : register-enum-type ( c-type name -- )
  99     enum-info new swap register-type ;
 100
 101 : register-record-type ( c-type name -- )
 102     record-info new swap register-type ;
 103
 104 ERROR: deferred-type-error ;
 105
 106 <<
 107 void* lookup-c-type clone
 108     [ drop deferred-type-error ] >>unboxer-quot
 109     [ drop deferred-type-error ] >>boxer-quot
 110     object >>boxed-class
 111 "deferred-type" create-word-in typedef
 112 >>