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