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.short-circuit combinators.smart discord io
   6 io.backend io.encodings.utf8 io.files.info kernel layouts libc
   7 libclang.ffi make math math.parser sequences sequences.private
   8 splitting strings ;
   9 IN: libclang
  10
  11 STRUCT: malloced
  12     { byte-array void* }
  13     { len uint }
  14     { offset uint }
  15     { marked-offset uint } ;
  16
  17 : <malloced> ( len -- malloced )
  18     malloced malloc-struct
  19         over 1 + <byte-array> malloc-byte-array >>byte-array
  20         swap >>len
  21         0 >>offset
  22         0 >>marked-offset ;
  23
  24 : mark-malloced ( malloced -- malloced )
  25     dup offset>> >>marked-offset ;
  26
  27 : since-reset ( malloced -- string )
  28     [ marked-offset>> ] [ byte-array>> ] bi
  29     <displaced-alien> utf8 alien>string ;
  30
  31 : reset-malloced ( malloced -- malloced string )
  32     [ since-reset ]
  33     [ dup marked-offset>> >>offset ] bi swap ;
  34
  35 : malloced-string ( malloced -- string )
  36     byte-array>> utf8 alien>string ;
  37
  38 : append-oom? ( malloced string -- ? )
  39     [ [ len>> ] [ offset>> ] bi - ]
  40     [ length ] bi* < ;
  41
  42 : realloc-malloced ( malloced -- malloced' )
  43     dup len>> 2 *
  44     '[ [ _ 1 + realloc ] change-byte-array ] keep >>len ;
  45
  46 : append-malloced ( malloced string -- malloced )
  47     2dup append-oom?
  48     [ [ realloc-malloced ] dip append-malloced ] [
  49         [
  50             [
  51                 [ offset>> ] [ byte-array>> ] bi <displaced-alien>
  52             ] dip [ utf8 string>alien ] [ length ] bi memcpy
  53         ] [
  54             '[ _ length + ] change-offset
  55         ] 2bi
  56     ] if ;
  57
  58 : malloced>string ( malloced -- string )
  59     [ byte-array>> utf8 alien>string ] [ free ] bi ;
  60
  61 : clang-get-cstring ( CXString -- string )
  62     clang_getCString [ utf8 alien>string ] [ clang_disposeString ] bi ;
  63
  64 : trim-blanks ( string -- string' )
  65     [ blank? ] trim ; inline
  66
  67 : cut-tail ( string quot -- before after ) (trim-tail) cut ; inline
  68
  69 : cell-bytes ( -- n )
  70     cell-bits 8 /i ; inline
  71
  72 : get-tokens ( tokens ntokens -- tokens )
  73     <iota> cell-bytes '[
  74         _ * swap <displaced-alien>
  75         clang_getTokenKind
  76     ] with { } map-as ;
  77
  78 : clang-get-file-max-range ( CXTranslationUnit path -- CXSourceRange )
  79     [ dupd clang_getFile 0 clang_getLocationForOffset ]
  80     [ dupd [ clang_getFile ] [ nip file-info size>> ] 2bi clang_getLocationForOffset ] 2bi
  81     clang_getRange ;
  82
  83 : clang-tokenize ( CXTranslationUnit CXSourceRange -- tokens ntokens )
  84     f void* <ref>
  85     0 uint <ref>
  86     [ clang_tokenize ] 2keep
  87     [ void* deref ]
  88     [ uint deref ] bi* ;
  89
  90 : tokenize-path ( tu path -- tokens ntokens )
  91     [ drop ] [ clang-get-file-max-range ] 2bi
  92     clang-tokenize ;
  93
  94 : tokenize-translation-unit ( CXTranslationUnit -- tokens ntokens )
  95     [ ] [ clang_getTranslationUnitCursor clang_getCursorExtent ] bi
  96     clang-tokenize ;
  97
  98 : tokenize-cursor ( cursor -- tokens ntokens )
  99     [ clang_Cursor_getTranslationUnit ] [ clang_getCursorExtent ] bi
 100     clang-tokenize ;
 101
 102 : dispose-tokens ( cursor tokens ntokens -- )
 103     [ clang_Cursor_getTranslationUnit ] 2dip clang_disposeTokens ;
 104
 105 :: with-cursor-tokens ( cursor quot: ( tu token -- obj ) -- )
 106     cursor clang_Cursor_getTranslationUnit :> tu
 107     cursor tokenize-cursor :> ( tokens ntokens )
 108     tokens ntokens <iota>
 109     cell-bytes :> bytesize
 110     quot
 111     '[
 112         [ tu ] 2dip bytesize * swap <displaced-alien> @
 113     ] with { } map-as
 114     tu tokens ntokens dispose-tokens ; inline
 115
 116 : clang-get-token-spelling ( CXTranslationUnit CXToken -- string )
 117     clang_getTokenSpelling clang-get-cstring ;
 118
 119 : cursor-type ( cursor -- string )
 120     clang_getCursorType
 121     clang_getTypeSpelling clang-get-cstring
 122
 123     "const" ?head drop
 124
 125     [ CHAR: * = ] cut-tail
 126     [ [ trim-blanks ] dip append ] when*
 127
 128     "struct " ?head drop
 129     {
 130         { [ dup "_Bool" = ] [ drop "bool" ] }
 131         { [ "int8_t" ?head ] [ trim-blanks "char" prepend ] }
 132         { [ "int16_t" ?head ] [ trim-blanks "short" prepend ] }
 133         { [ "int32_t" ?head ] [ trim-blanks "int" prepend ] }
 134         { [ "int64_t" ?head ] [ trim-blanks "longlong" prepend ] }
 135         { [ "uint8_t" ?head ] [ trim-blanks "uchar" prepend ] }
 136         { [ "uint16_t" ?head ] [ trim-blanks "ushort" prepend ] }
 137         { [ "uint32_t" ?head ] [ trim-blanks "uint" prepend ] }
 138         { [ "uint64_t" ?head ] [ trim-blanks "ulonglong" prepend ] }
 139         { [ "signed char" ?head ] [ trim-blanks "char" prepend ] }
 140         { [ "signed short" ?head ] [ trim-blanks "short" prepend ] }
 141         { [ "signed int" ?head ] [ trim-blanks "int" prepend ] }
 142         { [ "signed long" ?head ] [ trim-blanks "long" prepend ] }
 143         { [ "unsigned char" ?head ] [ trim-blanks "uchar" prepend ] }
 144         { [ "unsigned short" ?head ] [ trim-blanks "ushort" prepend ] }
 145         { [ "unsigned int" ?head ] [ trim-blanks "uint" prepend ] }
 146         { [ "unsigned long" ?head ] [ trim-blanks "ulong" prepend ] }
 147         { [ dup "(*)" swap subseq? ] [ drop "void*" ] }
 148         [ ]
 149     } cond ;
 150
 151 : cursor-name ( cursor -- string )
 152     clang_getCursorSpelling clang-get-cstring ;
 153
 154 : arg-info ( cursor -- string )
 155     [ cursor-type ] [ cursor-name [ "dummy" ] when-empty ] bi " " glue ;
 156
 157 : cursor>args ( CXCursor -- args/f )
 158     dup clang_Cursor_getNumArguments dup -1 = [
 159         2drop f
 160     ] [
 161         <iota> [
 162             clang_Cursor_getArgument
 163         ] with { } map-as
 164     ] if ;
 165
 166 : cxprimitive-type>factor ( CXType -- string )
 167     {
 168         { CXType_Bool [ "bool" ] }
 169         { CXType_Char_S [ "char" ] }
 170         { CXType_Char_U [ "uchar" ] }
 171         { CXType_SChar [ "char" ] }
 172         { CXType_UChar [ "uchar" ] }
 173         { CXType_Short [ "short" ] }
 174         { CXType_UShort [ "ushort" ] }
 175         { CXType_Int [ "int" ] }
 176         { CXType_UInt [ "uint" ] }
 177         { CXType_Long [ "long" ] }
 178         { CXType_ULong [ "ulong" ] }
 179         { CXType_LongLong [ "longlong" ] }
 180         { CXType_ULongLong [ "ulonglong" ] }
 181         { CXType_Float [ "float" ] }
 182         { CXType_Double [ "double" ] }
 183         { CXType_Void [ "void" ] }
 184         [ drop "" ]
 185     } case ;
 186
 187 : cxreturn-type>factor ( CXType -- string )
 188     {
 189         { [ dup kind>> CXType_Pointer = ] [
 190             clang_getPointeeType dup g... gflush cxreturn-type>factor "*" append
 191         ] }
 192         { [ dup kind>> CXType_Elaborated = ] [
 193             clang_getCanonicalType cxreturn-type>factor
 194         ] }
 195         { [ dup kind>> CXType_Record = ] [
 196             clang_getTypeDeclaration cursor-name
 197         ] }
 198         { [ dup kind>> CXType_FunctionProto = ] [
 199             ! inside a CXType_Pointer, so we get `void*` from that case
 200             drop "void"
 201         ] }
 202         [ kind>> cxprimitive-type>factor ]
 203     } cond ;
 204
 205 : cursor>args-info ( CXCursor -- args-info )
 206     cursor>args [ arg-info ] map ", " join ;
 207
 208 : function>string ( CXCursor -- string )
 209     [
 210         {
 211             [ drop "FUNCTION: " ]
 212             [ clang_getCursorResultType cxreturn-type>factor ]
 213             [ drop " " ]
 214             [ cursor-name ]
 215             [ drop " ( " ]
 216             [ cursor>args-info dup empty? ")\n" " )\n" ? ]
 217         } cleave
 218     ] "" append-outputs-as ;
 219
 220 : typedef>string ( CXCursor -- string )
 221     [ clang_getTypedefDeclUnderlyingType cxreturn-type>factor ]
 222     [ cursor-name ] bi
 223     2dup { [ and ] [ = ] } 2||
 224     [ nip "C-TYPE: " "\n" surround ] [ " " glue "TYPEDEF: " "\n" surround ] if ;
 225
 226 : field-visitor ( -- callback )
 227     [
 228         nip
 229         malloced memory>struct
 230         swap dup clang_getCursorKind
 231         {
 232             { CXCursor_FieldDecl [
 233                 [ cursor-name ] [ cursor-type ] bi " " glue
 234                 "\n  { " " }" surround
 235                 append-malloced drop
 236                 CXChildVisit_Continue
 237             ] }
 238             [ dup g...  3drop CXChildVisit_Recurse ]
 239         } case
 240         gflush
 241     ] CXCursorVisitor ;
 242
 243 : struct>string ( malloced CXCursor -- )
 244     [ mark-malloced ] dip
 245     tuck cursor-name append-malloced
 246     [ field-visitor ] dip
 247     [ clang_visitChildren drop ] keep
 248     ! hack to removev typedefs like `typedef struct foo foo;`
 249     dup malloced-string "}" tail? [
 250         reset-malloced "STRUCT: " " ;\n" surround
 251         append-malloced drop
 252     ] [
 253         reset-malloced "C-TYPE: " "\n" surround
 254         append-malloced drop
 255     ] if ;
 256
 257 : enum-visitor ( -- callback )
 258     [
 259         nip
 260         malloced memory>struct
 261         swap dup clang_getCursorKind
 262         {
 263             { CXCursor_EnumConstantDecl [
 264                 "enum" gprint
 265                 [
 266                     [ clang-get-token-spelling ] with-cursor-tokens
 267                     first
 268                 ] [
 269                     clang_getEnumConstantDeclUnsignedValue number>string
 270                 ] bi
 271                 " " glue
 272                 "\n  { " " }" surround
 273                 append-malloced drop
 274                 CXChildVisit_Continue
 275             ] }
 276             ! { CXCursor_IntegerLiteral [
 277             !     "integer" gprint
 278             !     [ clang-get-token-spelling ] with-cursor-tokens
 279             !     first " " " }" surround append-malloced drop
 280             !     CXChildVisit_Continue
 281             ! ] }
 282             [ "omg" g... 3dup [ g... ] tri@ 3drop CXChildVisit_Recurse ]
 283         } case
 284         gflush
 285     ] CXCursorVisitor ;
 286
 287 : enum>string ( malloced CXCursor -- )
 288     [ mark-malloced ] dip
 289     tuck cursor-name "ENUM: " prepend append-malloced
 290     [ enum-visitor ] dip
 291     [ clang_visitChildren drop ] keep
 292     " ;\n" append-malloced drop ;
 293
 294 : cursor-visitor ( -- callback )
 295     [
 296         nip
 297         malloced memory>struct
 298         swap dup clang_getCursorKind
 299         dup g... gflush
 300         {
 301             { CXCursor_Namespace [ 2drop CXChildVisit_Recurse ] }
 302             { CXCursor_FunctionDecl [ function>string append-malloced drop CXChildVisit_Continue ] }
 303             { CXCursor_TypedefDecl [ typedef>string append-malloced drop CXChildVisit_Continue ] }
 304             { CXCursor_StructDecl [ struct>string CXChildVisit_Continue ] }
 305             { CXCursor_EnumDecl [ enum>string CXChildVisit_Continue ] }
 306             ! { CXType_FunctionProto [ cursor-name "C-TYPE: " "\n" surround append-malloced drop CXChildVisit_Continue ] }
 307             [ dup g... 3drop CXChildVisit_Recurse ]
 308         } case
 309     ] CXCursorVisitor
 310     gflush ;
 311
 312 : with-clang-index ( quot: ( index -- string ) -- )
 313     [ 0 0 clang_createIndex ] dip keep clang_disposeIndex ; inline
 314
 315 : with-clang-translation-unit ( idx source-file command-line-args nargs unsaved-files nunsaved-files options quot: ( tu -- string ) -- )
 316     [ enum>number clang_parseTranslationUnit ] dip
 317     keep clang_disposeTranslationUnit ; inline
 318
 319 : with-clang-default-translation-unit ( path quot: ( tu path -- string ) -- )
 320     dupd '[
 321         _ f 0 f 0 CXTranslationUnit_None [
 322             _ @
 323         ] with-clang-translation-unit
 324     ] with-clang-index ; inline
 325
 326 : with-clang-cursor ( path quot: ( tu path cursor -- string ) -- )
 327     dupd '[
 328         _ f 0 f 0 CXTranslationUnit_None [
 329             _ over clang_getTranslationUnitCursor @
 330         ] with-clang-translation-unit
 331     ] with-clang-index ; inline
 332
 333 : parse-c-defines ( path -- string )
 334     [
 335         tokenize-path
 336         [
 337             ! tu void* int
 338             cell-bits 8 /i * swap <displaced-alien>
 339             clang_getTokenKind
 340         ] with { } map-as
 341     ] with-clang-default-translation-unit ;
 342
 343 : parse-c-exports ( path -- string )
 344     [
 345         nipd cursor-visitor rot file-info size>> 2 * <malloced>
 346         [ clang_visitChildren drop ] keep malloced>string
 347     ] with-clang-cursor ;
 348
 349 : parse-include ( path -- string )
 350     normalize-path
 351     {
 352         ! [ parse-c-defines ]
 353         [ parse-c-exports ]
 354     } cleave ;
 355
 356 ! "/Library/Developer/CommandLineTools/SDKs/MacOSX10.15.sdk/usr/include/php/ext/sqlite3/libsqlite/sqlite3.h" parse-include
 357
 358 ! "/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/clang/15.0.0/include"
 359