unmaintained/alien/inline/types/types.factor

   1 ! Copyright (C) 2009 Jeremy Hughes.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types assocs combinators.short-circuit
   4 continuations effects fry kernel math memoize sequences
   5 splitting strings peg.ebnf make words ;
   6 IN: alien.inline.types
   7
   8 : cify-type ( str -- str' )
   9     dup word? [ name>> ] when
  10     H{ { CHAR: - CHAR: space } } substitute ;
  11
  12 : factorize-type ( str -- str' )
  13     cify-type
  14     "const " ?head drop
  15     "unsigned " ?head [ "u" prepend ] when
  16     "long " ?head [ "long" prepend ] when
  17     " const" ?tail drop ;
  18
  19 : const-pointer? ( str -- ? )
  20     cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
  21
  22 : pointer-to-const? ( str -- ? )
  23     cify-type "const " head? ;
  24
  25 : template-class? ( str -- ? )
  26     [ CHAR: < = ] any? ;
  27
  28 MEMO: resolved-primitives ( -- seq )
  29     primitive-types [ resolve-typedef ] map ;
  30
  31 : primitive-type? ( type -- ? )
  32     [
  33         factorize-type resolve-typedef [ resolved-primitives ] dip
  34         '[ _ = ] any?
  35     ] [ 2drop f ] recover ;
  36
  37 : pointer? ( type -- ? )
  38     factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
  39
  40 : type-sans-pointer ( type -- type' )
  41     factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
  42
  43 : pointer-to-primitive? ( type -- ? )
  44     factorize-type
  45     { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
  46
  47 : pointer-to-non-const-primitive? ( str -- ? )
  48     {
  49         [ pointer-to-const? not ]
  50         [ factorize-type pointer-to-primitive? ]
  51     } 1&& ;
  52
  53 : types-effect>params-return ( types effect -- params return )
  54     [ in>> zip ]
  55     [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
  56     2bi ;
  57
  58 : annotate-effect ( types effect -- types effect' )
  59     [ in>> ] [ out>> ] bi [
  60         zip
  61         [ over pointer-to-primitive? [ ">" prepend ] when ]
  62         assoc-map unzip
  63     ] dip <effect> ;
  64
  65 TUPLE: c++-type name params ptr ;
  66 C: <c++-type> c++-type
  67
  68 EBNF: (parse-c++-type)
  69 dig  = [0-9]
  70 alpha = [a-zA-Z]
  71 alphanum = [1-9a-zA-Z]
  72 name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
  73 ptr = [*&] => [[ empty? not ]]
  74
  75 param = "," " "* type " "* => [[ third ]]
  76
  77 params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
  78
  79 type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
  80 ;EBNF
  81
  82 : parse-c++-type ( str -- c++-type )
  83     factorize-type (parse-c++-type) ;
  84
  85 DEFER: c++-type>string
  86
  87 : params>string ( params -- str )
  88     [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
  89
  90 : c++-type>string ( c++-type -- str )
  91     [
  92         [ name>> % ]
  93         [ params>> [ params>string % ] when* ]
  94         [ ptr>> [ "*" % ] when ]
  95         tri
  96     ] "" make ;
  97
  98 GENERIC: c++-type ( obj -- c++-type/f )
  99
 100 M: object c++-type drop f ;
 101
 102 M: c++-type c-type ;