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     { latest-offset uint } ;
  15
  16 : <malloced> ( len -- malloced )
  17     malloced malloc-struct
  18         over 1 + <byte-array> malloc-byte-array >>byte-array
  19         swap >>len
  20         0 >>offset
  21         0 >>latest-offset ;
  22
  23 : mark-malloced ( malloced -- malloced )
  24     dup offset>> >>latest-offset ;
  25
  26 : reset-malloced ( malloced -- malloced )
  27     dup latest-offset>> >>offset ;
  28
  29 : malloced-string ( malloced -- string )
  30     byte-array>> utf8 alien>string ;
  31
  32 : append-oom? ( malloced string -- ? )
  33     [ [ len>> ] [ offset>> ] bi - ]
  34     [ length ] bi* < ;
  35
  36 : realloc-malloced ( malloced -- malloced' )
  37     dup len>> 2 *
  38     '[ [ _ 1 + realloc ] change-byte-array ] keep >>len ;
  39
  40 : append-malloced ( malloced string -- malloced )
  41     2dup append-oom?
  42     [ [ realloc-malloced ] dip append-malloced ] [
  43         [
  44             [
  45                 [ offset>> ] [ byte-array>> ] bi <displaced-alien>
  46             ] dip [ utf8 string>alien ] [ length ] bi memcpy
  47         ] [
  48             '[ _ length + ] change-offset
  49         ] 2bi
  50     ] if ;
  51
  52 : malloced>string ( malloced -- string )
  53     [ byte-array>> utf8 alien>string ] [ free ] bi ;
  54
  55 : CXCursor>factor ( cursor -- string )
  56     dup clang_getCursorKind {
  57         { CXCursor_FunctionDecl [ drop f ] }
  58         { CXType_Pointer [ drop f ] }
  59         { CXType_Invalid [ drop f ] }
  60         [ 2drop f ]
  61     } case ;
  62
  63 : clang-get-cstring ( CXString -- string )
  64     clang_getCString [ utf8 alien>string ] [ clang_disposeString ] bi ;
  65
  66 : trim-blanks ( string -- string' )
  67     [ blank? ] trim ; inline
  68
  69 : remove-const ( strinng -- string' )
  70     "const" split1 [ trim-blanks ] bi@ " " glue trim-blanks ;
  71
  72 : cursor-type ( cursor -- string )
  73     clang_getCursorType
  74     clang_getTypeSpelling clang-get-cstring
  75     ! remove-const
  76     "const" ?head drop
  77     "*" ?tail [ trim-blanks "*" append ] when
  78     "struct " ?head drop ! [ trim-blanks ] when
  79
  80     {
  81         { [ dup "unsigned char" = ] [ drop "uchar" ] }
  82         { [ "unsigned char" ?head ] [ trim-blanks "uchar" prepend ] }
  83         { [ "unsigned int" ?head ] [ trim-blanks "uint" prepend ] }
  84         ! { [ "*" ?tail ] [ trim-blanks "*" append ] }
  85         { [ dup "(*)" swap subseq? ] [ drop "void*" ] }
  86         [ ]
  87     } cond ;
  88
  89 : cursor-name ( cursor -- string )
  90     clang_getCursorSpelling clang-get-cstring ;
  91
  92 : arg-info ( cursor -- string )
  93     [ cursor-type ] [ cursor-name [ "dummy" ] when-empty ] bi " " glue ;
  94
  95 : cursor>args ( CXCursor -- args/f )
  96     dup clang_Cursor_getNumArguments dup -1 = [
  97         2drop f
  98     ] [
  99         <iota> [
 100             clang_Cursor_getArgument
 101         ] with { } map-as
 102     ] if ;
 103
 104 : cxprimitive-type>factor ( CXType -- string )
 105     {
 106         { CXType_Bool [ "bool" ] }
 107         { CXType_Char_S [ "char" ] }
 108         { CXType_Char_U [ "uchar" ] }
 109         { CXType_SChar [ "char" ] }
 110         { CXType_UChar [ "uchar" ] }
 111         { CXType_Short [ "short" ] }
 112         { CXType_UShort [ "ushort" ] }
 113         { CXType_Int [ "int" ] }
 114         { CXType_UInt [ "uint" ] }
 115         { CXType_Long [ "long" ] }
 116         { CXType_ULong [ "ulong" ] }
 117         { CXType_LongLong [ "longlong" ] }
 118         { CXType_ULongLong [ "ulonglong" ] }
 119         { CXType_Float [ "float" ] }
 120         { CXType_Double [ "double" ] }
 121         { CXType_Void [ "void" ] }
 122         [ drop "" ]
 123     } case ;
 124
 125 : cxreturn-type>factor ( CXType -- string )
 126     {
 127         { [ dup kind>> CXType_Pointer = ] [
 128             clang_getPointeeType dup g... gflush cxreturn-type>factor "*" append
 129         ] }
 130         { [ dup kind>> CXType_Elaborated = ] [
 131             clang_getCanonicalType cxreturn-type>factor
 132         ] }
 133         { [ dup kind>> CXType_Record = ] [
 134             clang_getTypeDeclaration cursor-name
 135         ] }
 136         { [ dup kind>> CXType_FunctionProto = ] [
 137             ! inside a CXType_Pointer, so we get `void*` from that case
 138             drop "void"
 139         ] }
 140         [ kind>> cxprimitive-type>factor ]
 141     } cond ;
 142
 143 : cursor>args-info ( CXCursor -- args-info )
 144     cursor>args [ arg-info ] map ", " join ;
 145
 146 : function>string ( CXCursor -- string )
 147     [
 148         {
 149             [ drop "FUNCTION: " ]
 150             [ clang_getCursorResultType cxreturn-type>factor ]
 151             [ drop " " ]
 152             [ cursor-name ]
 153             [ drop " ( " ]
 154             [ cursor>args-info dup empty? ")\n" " )\n" ? ]
 155         } cleave
 156     ] "" append-outputs-as ;
 157
 158 : typedef>string ( CXCursor -- string )
 159     [ clang_getTypedefDeclUnderlyingType cxreturn-type>factor ]
 160     [ cursor-name ] bi
 161     2dup = [
 162         2drop ""
 163     ] [
 164         " " glue "TYPEDEF: " "\n" surround
 165     ] if ;
 166
 167
 168 : field-visitor ( -- callback )
 169     [
 170         nip
 171         malloced memory>struct
 172         swap dup clang_getCursorKind
 173         {
 174             { CXCursor_FieldDecl [
 175                 [ cursor-name ] [ cursor-type ] bi " " glue
 176                 "\n  { " " }" surround
 177                 append-malloced drop
 178                 CXChildVisit_Continue
 179             ] }
 180             ! { CXCursor_TypedefDecl [ 2drop CXChildVisit_Continue ] }
 181             ! { CXCursor_StructDecl [ 2drop CXChildVisit_Continue ] }
 182             [ dup g...  3drop CXChildVisit_Recurse ]
 183         } case
 184         gflush
 185     ] CXCursorVisitor ;
 186
 187 : struct>string ( malloced CXCursor -- )
 188     [ mark-malloced ] dip
 189     tuck cursor-name "STRUCT: " prepend append-malloced
 190     [ field-visitor ] dip
 191     [ clang_visitChildren drop ] keep
 192     ! hack to removev typedefs like `typedef struct foo foo;`
 193     dup malloced-string "}" tail? [
 194         " ;\n" append-malloced drop
 195     ] [
 196         reset-malloced drop
 197     ] if ;
 198
 199 : cursor-visitor ( -- callback )
 200     [
 201         nip
 202         malloced memory>struct
 203         swap dup clang_getCursorKind
 204         {
 205             { CXCursor_Namespace [ 2drop CXChildVisit_Recurse ] }
 206             { CXCursor_FunctionDecl [ function>string append-malloced drop CXChildVisit_Continue ] }
 207             { CXCursor_TypedefDecl [ typedef>string append-malloced drop CXChildVisit_Continue ] }
 208             { CXCursor_StructDecl [ struct>string CXChildVisit_Continue ] }
 209             [ dup g... 3drop CXChildVisit_Recurse ]
 210         } case
 211     ] CXCursorVisitor
 212     gflush ;
 213
 214 : with-clang-index ( quot: ( index -- string ) -- )
 215     [ 0 0 clang_createIndex ] dip keep clang_disposeIndex ; inline
 216
 217 : with-clang-translation-unit ( idx source-file command-line-args nargs unsaved-files nunsaved-files options quot: ( tu -- string ) -- )
 218     [ enum>number clang_parseTranslationUnit ] dip
 219     keep clang_disposeTranslationUnit ; inline
 220
 221 : with-clang-default-translation-unit ( path quot: ( path tu -- string ) -- )
 222     dupd '[
 223         _ f 0 f 0 CXTranslationUnit_None [
 224             [ _ ] dip @
 225         ] with-clang-translation-unit
 226     ] with-clang-index ; inline
 227
 228 : with-clang-cursor ( path quot: ( path tu cursor -- string ) -- )
 229     dupd '[
 230         _ f 0 f 0 CXTranslationUnit_None [
 231             [ _ ] dip dup clang_getTranslationUnitCursor @
 232         ] with-clang-translation-unit
 233     ] with-clang-index ; inline
 234
 235 : clang-get-file-max-range ( CXTranslationUnit path -- CXSourceRange )
 236     [ dupd clang_getFile 0 clang_getLocationForOffset ]
 237     [ dupd [ clang_getFile ] [ nip file-info size>> ] 2bi clang_getLocationForOffset ] 2bi
 238     clang_getRange ;
 239
 240 : parse-c-defines ( path -- string )
 241     [
 242         swap
 243         ! tu path
 244         dupd clang-get-file-max-range ! tu CXRange
 245         f void* <ref>
 246         0 uint <ref>
 247         [ clang_tokenize ] 2keep
 248         [ void* deref ]
 249         [ uint deref <iota> ] bi*
 250         [
 251             ! tu void* int
 252             cell-bits 8 /i * swap <displaced-alien>
 253             clang_getTokenKind
 254         ] with { } map-as
 255     ] with-clang-default-translation-unit ;
 256
 257 : parse-c-exports ( path -- string )
 258     [
 259         nip cursor-visitor rot file-info size>> 2 * <malloced>
 260         [ clang_visitChildren drop ] keep malloced>string
 261     ] with-clang-cursor ;
 262
 263 : parse-include ( path -- string )
 264     normalize-path
 265     {
 266         ! [ parse-c-defines ]
 267         [ parse-c-exports ]
 268     } cleave ;
 269
 270 ! "/Library/Developer/CommandLineTools/SDKs/MacOSX10.15.sdk/usr/include/php/ext/sqlite3/libsqlite/sqlite3.h" parse-include
 271
 272 ! "/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/clang/15.0.0/include"
 273