extra/libclang/libclang.factor

   1 ! Copyright (C) 2022 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.data alien.enums
   4 alien.strings ascii byte-arrays classes.struct combinators
   5 combinators.smart discord io io.backend io.encodings.utf8
   6 io.files.info kernel layouts libc libclang.ffi make math
   7 sequences splitting strings ;
   8 IN: libclang
   9
  10 STRUCT: malloced
  11     { byte-array void* }
  12     { len uint }
  13     { offset uint } ;
  14
  15 : <malloced> ( len -- malloced )
  16     malloced malloc-struct
  17         over 1 + <byte-array> malloc-byte-array >>byte-array
  18         swap >>len
  19         0 >>offset ;
  20
  21 : append-oom? ( malloced string -- ? )
  22     [ [ len>> ] [ offset>> ] bi - ]
  23     [ length ] bi* < ;
  24
  25 : realloc-malloced ( malloced -- malloced' )
  26     dup len>> 2 *
  27     '[ [ _ 1 + realloc ] change-byte-array ] keep >>len ;
  28
  29 : append-malloced ( malloced string -- )
  30     2dup append-oom?
  31     [ [ realloc-malloced ] dip append-malloced ] [
  32         [
  33             [
  34                 [ offset>> ] [ byte-array>> ] bi <displaced-alien>
  35             ] dip [ utf8 string>alien ] [ length ] bi memcpy
  36         ] [
  37             '[ _ length + ] change-offset drop
  38         ] 2bi
  39     ] if ;
  40
  41 : malloced>string ( malloced -- string )
  42     [ byte-array>> utf8 alien>string ] [ free ] bi ;
  43
  44 : CXCursor>factor ( cursor -- string )
  45     dup clang_getCursorKind {
  46         { CXCursor_FunctionDecl [ drop f ] }
  47         { CXType_Pointer [ drop f ] }
  48         { CXType_Invalid [ drop f ] }
  49         [ 2drop f ]
  50     } case ;
  51
  52 : clang-get-cstring ( CXString -- string )
  53     clang_getCString [ utf8 alien>string ] [ clang_disposeString ] bi ;
  54
  55 : remove-const ( strinng -- string' )
  56     "const" split1 [ [ blank? ] trim ] bi@ " " glue [ blank? ] trim ;
  57
  58 : cursor-type ( cursor -- string )
  59     ! [ "cursor display name" g... clang_getCursorDisplayName g... ] keep
  60     clang_getCursorType
  61     clang_getTypeSpelling clang-get-cstring ! "type spelling c string" g... dup g...
  62     remove-const ;
  63
  64 : cursor-name ( cursor -- string )
  65     clang_getCursorSpelling clang-get-cstring ;
  66
  67 : arg-info ( cursor -- string )
  68     [ cursor-type ] [ cursor-name [ "dummy" ] when-empty ] bi " " glue ;
  69
  70 : cursor>args ( CXCursor -- args/f )
  71     dup clang_Cursor_getNumArguments dup -1 = [
  72         2drop f
  73     ] [
  74         <iota> [
  75             clang_Cursor_getArgument
  76         ] with { } map-as
  77     ] if ;
  78
  79 : cxprimitive-type>factor ( CXType -- string )
  80     {
  81         { CXType_Bool [ "bool" ] }
  82         { CXType_Char_S [ "char" ] }
  83         { CXType_Char_U [ "uchar" ] }
  84         { CXType_SChar [ "char" ] }
  85         { CXType_UChar [ "uchar" ] }
  86         { CXType_Short [ "short" ] }
  87         { CXType_UShort [ "ushort" ] }
  88         { CXType_Int [ "int" ] }
  89         { CXType_UInt [ "uint" ] }
  90         { CXType_Long [ "long" ] }
  91         { CXType_ULong [ "ulong" ] }
  92         { CXType_LongLong [ "longlong" ] }
  93         { CXType_ULongLong [ "ulonglong" ] }
  94         { CXType_Float [ "float" ] }
  95         { CXType_Double [ "double" ] }
  96         { CXType_Void [ "void" ] }
  97         [ drop "" ]
  98     } case ;
  99
 100 : cxreturn-type>factor ( CXType -- string )
 101     {
 102         { [ dup kind>> CXType_Pointer = ] [
 103             clang_getPointeeType cxreturn-type>factor "*" append
 104         ] }
 105         { [ dup kind>> CXType_Elaborated = ] [
 106             clang_getCanonicalType cxreturn-type>factor
 107         ] }
 108         { [ dup kind>> CXType_Record = ] [
 109             clang_getTypeDeclaration clang_getCursorSpelling clang-get-cstring
 110         ] }
 111         [ kind>> cxprimitive-type>factor ]
 112     } cond ;
 113
 114 : cursor>args-info ( CXCursor -- args-info )
 115     cursor>args [ arg-info ] map ", " join ;
 116
 117 : function>string ( CXCursor -- string )
 118     [
 119         {
 120             [ drop "FUNCTION: " ]
 121             [ clang_getCursorResultType cxreturn-type>factor ]
 122             [ drop " " ]
 123             [ clang_getCursorSpelling clang-get-cstring ]
 124             [ drop " ( " ]
 125             [ cursor>args-info dup empty? ")\n" " )\n" ? ]
 126         } cleave
 127     ] "" append-outputs-as ;
 128
 129 : typedef>string ( CXCursor -- string )
 130     [ clang_getTypedefDeclUnderlyingType cxreturn-type>factor ]
 131     [ clang_getCursorSpelling clang-get-cstring ] bi
 132     2dup = [
 133         2drop ""
 134     ] [
 135         " " glue "TYPEDEF: " "\n" surround
 136     ] if ;
 137
 138 : struct>string ( CXCursor -- string )
 139     clang_getCursorSpelling clang-get-cstring "STRUCT: " "\n" surround   ;
 140
 141 : cursor-visitor ( -- callback )
 142     [
 143         nip
 144         malloced memory>struct
 145         swap dup clang_getCursorKind
 146         {
 147             { CXCursor_FunctionDecl [ function>string append-malloced CXChildVisit_Continue ] }
 148             { CXCursor_TypedefDecl [ typedef>string append-malloced CXChildVisit_Continue ] }
 149             { CXCursor_StructDecl [ struct>string append-malloced CXChildVisit_Continue ] }
 150             [ dup g... gflush 3drop CXChildVisit_Recurse ]
 151         } case
 152     ] CXCursorVisitor ;
 153
 154 : with-clang-index ( quot: ( index -- string ) -- )
 155     [ 0 0 clang_createIndex ] dip keep clang_disposeIndex ; inline
 156
 157 : with-clang-translation-unit ( idx source-file command-line-args nargs unsaved-files nunsaved-files options quot: ( tu -- string ) -- )
 158     [ enum>number clang_parseTranslationUnit ] dip
 159     keep clang_disposeTranslationUnit ; inline
 160
 161 : with-clang-default-translation-unit ( path quot: ( path tu -- string ) -- )
 162     dupd '[
 163         _ f 0 f 0 CXTranslationUnit_None [
 164             [ _ ] dip @
 165         ] with-clang-translation-unit
 166     ] with-clang-index ; inline
 167
 168 : with-clang-cursor ( path quot: ( path tu cursor -- string ) -- )
 169     dupd '[
 170         _ f 0 f 0 CXTranslationUnit_None [
 171             [ _ ] dip dup clang_getTranslationUnitCursor @
 172         ] with-clang-translation-unit
 173     ] with-clang-index ; inline
 174
 175 : clang-get-file-max-range ( CXTranslationUnit path -- CXSourceRange )
 176     [ dupd clang_getFile 0 clang_getLocationForOffset ]
 177     [ dupd [ clang_getFile ] [ nip file-info size>> ] 2bi clang_getLocationForOffset ] 2bi
 178     clang_getRange ;
 179
 180 : parse-c-defines ( path -- string )
 181     [
 182         swap
 183         ! tu path
 184         dupd clang-get-file-max-range ! tu CXRange
 185         f void* <ref>
 186         0 uint <ref>
 187         [ clang_tokenize ] 2keep
 188         [ void* deref ]
 189         [ uint deref <iota> ] bi*
 190         [
 191             ! tu void* int
 192             cell-bits 8 /i * swap <displaced-alien>
 193             clang_getTokenKind
 194         ] with { } map-as
 195     ] with-clang-default-translation-unit ;
 196
 197 : parse-c-exports ( path -- string )
 198     [
 199         nip cursor-visitor rot file-info size>> 2 * <malloced>
 200         [ clang_visitChildren drop ] keep malloced>string
 201     ] with-clang-cursor ;
 202
 203 : parse-include ( path -- string )
 204     normalize-path
 205     {
 206         ! [ parse-c-defines ]
 207         [ parse-c-exports ]
 208     } cleave ;
 209
 210 ! "/Library/Developer/CommandLineTools/SDKs/MacOSX10.15.sdk/usr/include/php/ext/sqlite3/libsqlite/sqlite3.h" parse-include