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 assocs byte-arrays classes classes.struct
   5 combinators combinators.extras combinators.short-circuit
   6 combinators.smart discord io io.backend io.encodings.utf8
   7 io.files.info kernel layouts libc libclang.ffi make math
   8 math.parser multiline namespaces prettyprint sequences
   9 sequences.private sets sorting splitting strings ;
  10 IN: libclang
  11
  12 SYMBOL: clang-state
  13 : clang-state> ( -- clang-state ) clang-state get-global ;
  14
  15 ! todo: typedefs
  16 TUPLE: libclang-state
  17     defs-counter c-defs-by-name c-defs-by-order
  18     c-forms child-forms
  19     unnamed-table unnamed-counter
  20     out-forms-counter out-forms out-forms-written ;
  21
  22 : <libclang-state> ( -- state )
  23     libclang-state new
  24         0 >>defs-counter
  25         H{ } clone >>c-defs-by-name
  26         H{ } clone >>c-defs-by-order
  27         V{ } clone >>c-forms
  28         H{ } clone >>child-forms
  29         0 >>unnamed-counter
  30         H{ } clone >>unnamed-table
  31         0 >>out-forms-counter
  32         H{ } clone >>out-forms
  33         HS{ } clone >>out-forms-written ;
  34
  35 GENERIC: def>out-form ( obj -- string )
  36
  37 : save-out-form ( string -- )
  38     [
  39         dup clang-state> out-forms-written>> in? [
  40             drop
  41         ] [
  42             clang-state>
  43             [
  44                 [ out-forms-counter>> counter ]
  45                 [ out-forms>> set-at ] bi
  46             ]
  47             [ out-forms-written>> adjoin ] 2bi
  48         ] if
  49     ] unless-empty ;
  50
  51 ! some forms must be defined out of order, e.g. anonymous unions/structs
  52 : def>out-forms ( obj -- )
  53     def>out-form save-out-form ;
  54
  55 : peek-current-form ( -- n )
  56     clang-state> c-forms>> ?last ; inline
  57
  58 SLOT: parent-order
  59 SLOT: order
  60
  61 : push-child-form ( form -- )
  62     ! dup order>> c-defs-by-order get-global set-at ; inline
  63     dup parent-order>> clang-state> child-forms>> push-at ; inline
  64
  65 : with-new-form ( quot -- n )
  66     clang-state> [ defs-counter>> counter ] [ c-forms>> ] bi push
  67     call
  68     clang-state> c-forms>> pop ; inline
  69
  70 ERROR: unknown-form name ;
  71 GENERIC: print-deferred ( obj -- )
  72 M: object print-deferred
  73     type>> clang-state> c-defs-by-name>> ?at [ def>out-forms ] [ unknown-form ] if ;
  74
  75 : unnamed? ( string -- ? ) "(unnamed" swap subseq? ; inline
  76 : append-counter ( string counter -- string' ) counter number>string append ; inline
  77 : unnamed-exists? ( string -- value/key ? ) clang-state> unnamed-table>> ?at ; inline
  78 : lookup-unnamed ( type string -- type-name )
  79     unnamed-exists? [
  80         nip
  81     ] [
  82         [ clang-state> unnamed-counter>> append-counter ] dip
  83         " " split1-last nip
  84         "RECORDING: " gwrite dup g... gflush
  85         [ clang-state> unnamed-table>> set-at ] keepd
  86     ] if ; inline
  87
  88 : ?unnamed ( string type -- string' ? )
  89     over unnamed? [
  90         swap lookup-unnamed t
  91     ] [
  92         drop f
  93     ] if ;
  94
  95 TUPLE: c-function
  96     { return-type string }
  97     { name string }
  98     { args string }
  99     { order integer } ;
 100
 101 : <c-function> ( return-type name args -- c-function )
 102     c-function new
 103         swap >>args
 104         swap >>name
 105         swap >>return-type
 106         clang-state> defs-counter>> counter >>order ;
 107
 108
 109 TUPLE: c-struct
 110     { name string }
 111     { order integer } ;
 112
 113 : <c-struct> ( name order -- c-struct )
 114     c-struct new
 115         swap >>order
 116         swap >>name ;
 117
 118
 119 TUPLE: c-union
 120     { name string }
 121     { order integer } ;
 122
 123 : <c-union> ( name order -- c-union )
 124     c-union new
 125         swap >>order
 126         swap >>name ;
 127
 128
 129 TUPLE: c-enum
 130     { name string }
 131     slots
 132     { order integer } ;
 133
 134 : <c-enum> ( name order -- c-enum )
 135     c-enum new
 136         swap >>order
 137         swap >>name ;
 138
 139
 140 TUPLE: c-arg
 141     { name string }
 142     { type string }
 143     { parent-order integer }
 144     { order integer } ;
 145
 146 : <c-arg> ( name type -- c-arg )
 147     c-arg new
 148         swap >>type
 149         swap >>name
 150         peek-current-form >>parent-order
 151         clang-state> defs-counter>> counter >>order ;
 152
 153
 154 TUPLE: c-field
 155     { name string }
 156     { type string }
 157     { parent-order integer }
 158     { order integer } ;
 159
 160 : <c-field> ( name type -- c-field )
 161     c-field new
 162         swap >>type
 163         swap >>name
 164         peek-current-form >>parent-order
 165         clang-state> defs-counter>> counter >>order ;
 166
 167
 168 TUPLE: c-typedef
 169     { type string }
 170     { name string }
 171     { order integer } ;
 172
 173 : <c-typedef> ( type name -- c-typedef )
 174     c-typedef new
 175         swap >>name
 176         swap >>type
 177         clang-state> defs-counter>> counter >>order ;
 178
 179 M: c-function def>out-form
 180     [
 181         {
 182             [ drop "FUNCTION: " ]
 183             [ return-type>> " " ]
 184             [ name>> " ( " ]
 185             [ args>> dup empty? ")\n" " )\n" ? ]
 186         } cleave
 187     ] "" append-outputs-as ;
 188
 189 : ignore-typedef? ( typedef -- ? )
 190     [ type>> ] [ name>> ] bi
 191     { [ = ] [ [ empty? ] either? ] } 2|| ;
 192
 193 M: c-typedef def>out-form
 194     dup ignore-typedef? [
 195         drop ""
 196     ] [
 197         [
 198             {
 199                 [ drop "TYPEDEF: " ]
 200                 [ type>> " " ]
 201                 [ name>> ]
 202             } cleave
 203         ] "" append-outputs-as
 204     ] if ;
 205
 206 ERROR: unknown-child-forms order ;
 207 M: c-field def>out-form
 208     [
 209         {
 210             [ drop "  { " ]
 211             [ name>> " " ]
 212             [ type>> " }" ]
 213         } cleave
 214     ] "" append-outputs-as ;
 215
 216 : lookup-order ( obj -- order )
 217     type>> clang-state> c-defs-by-name>> at [ order>> ] ?call -1 or ;
 218
 219 : print-defers ( current-order slots -- )
 220     [
 221         tuck lookup-order < [
 222             print-deferred
 223         ] [
 224             drop
 225         ] if
 226     ] with each ;
 227
 228 : empty-struct? ( c-struct -- ? )
 229     order>> clang-state> child-forms>> key? not ;
 230
 231 M: c-struct def>out-form
 232     dup empty-struct? [
 233         name>> "C-TYPE: " prepend
 234     ] [
 235         [
 236             {
 237                 [ drop "STRUCT: " ]
 238                 [ name>> "\n" ]
 239                 [
 240                     order>> dup clang-state> child-forms>> ?at [ drop { } ] unless
 241                     [ print-defers ]
 242                     [ nip [ def>out-form ] map "\n" join " ;\n" append ] 2bi
 243                 ]
 244             } cleave
 245         ] "" append-outputs-as
 246     ] if ;
 247
 248 M: c-enum def>out-form
 249     [
 250         {
 251             [ drop "ENUM: " ]
 252             [ name>> "\n" ]
 253             [
 254                 order>> dup clang-state> child-forms>> ?at [ drop { } ] unless
 255                 [ print-defers ]
 256                 [ nip [ def>out-form ] map "\n" join " ;\n" append ] 2bi
 257             ]
 258         } cleave
 259     ] "" append-outputs-as ;
 260
 261 M: c-union def>out-form
 262     [
 263         {
 264             [ drop "UNION-STRUCT: " ]
 265             [ name>> "\n" ]
 266             [
 267                 order>> dup clang-state> child-forms>> ?at [ drop { } ] unless
 268                 [ print-defers ]
 269                 [ nip [ def>out-form ] map "\n" join " ;\n" append ] 2bi
 270             ]
 271         } cleave
 272     ] "" append-outputs-as ;
 273
 274 M: object def>out-form
 275     class-of name>> "unknown object: " prepend ;
 276
 277 : set-definition ( named -- )
 278     [ dup name>> clang-state> c-defs-by-name>> set-at ]
 279     [ dup order>> clang-state> c-defs-by-order>> set-at ] bi ;
 280
 281 : clang-get-cstring ( CXString -- string )
 282     clang_getCString [ utf8 alien>string ] [ clang_disposeString ] bi ;
 283
 284 : trim-blanks ( string -- string' )
 285     [ blank? ] trim ; inline
 286
 287 : cut-tail ( string quot -- before after ) (trim-tail) cut ; inline
 288
 289 : cell-bytes ( -- n )
 290     cell-bits 8 /i ; inline
 291
 292 : get-tokens ( tokens ntokens -- tokens )
 293     <iota> cell-bytes '[
 294         _ * swap <displaced-alien>
 295         clang_getTokenKind
 296     ] with { } map-as ;
 297
 298 : clang-get-file-max-range ( CXTranslationUnit path -- CXSourceRange )
 299     [ dupd clang_getFile 0 clang_getLocationForOffset ]
 300     [ dupd [ clang_getFile ] [ nip file-info size>> ] 2bi clang_getLocationForOffset ] 2bi
 301     clang_getRange ;
 302
 303 : clang-tokenize ( CXTranslationUnit CXSourceRange -- tokens ntokens )
 304     f void* <ref>
 305     0 uint <ref>
 306     [ clang_tokenize ] 2keep
 307     [ void* deref ]
 308     [ uint deref ] bi* ;
 309
 310 : tokenize-path ( tu path -- tokens ntokens )
 311     [ drop ] [ clang-get-file-max-range ] 2bi
 312     clang-tokenize ;
 313
 314 : tokenize-translation-unit ( CXTranslationUnit -- tokens ntokens )
 315     [ ] [ clang_getTranslationUnitCursor clang_getCursorExtent ] bi
 316     clang-tokenize ;
 317
 318 : tokenize-cursor ( cursor -- tokens ntokens )
 319     [ clang_Cursor_getTranslationUnit ] [ clang_getCursorExtent ] bi
 320     clang-tokenize ;
 321
 322 : dispose-tokens ( cursor tokens ntokens -- )
 323     [ clang_Cursor_getTranslationUnit ] 2dip clang_disposeTokens ;
 324
 325 :: with-cursor-tokens ( cursor quot: ( tu token -- obj ) -- )
 326     cursor clang_Cursor_getTranslationUnit :> tu
 327     cursor tokenize-cursor :> ( tokens ntokens )
 328     tokens ntokens <iota>
 329     cell-bytes :> bytesize
 330     quot
 331     '[
 332         [ tu ] 2dip bytesize * swap <displaced-alien> @
 333     ] with { } map-as
 334     tu tokens ntokens dispose-tokens ; inline
 335
 336 : clang-get-token-spelling ( CXTranslationUnit CXToken -- string )
 337     clang_getTokenSpelling clang-get-cstring ;
 338
 339 DEFER: cursor>c-struct
 340 DEFER: cursor>c-union
 341
 342 :: cursor-type ( cursor -- string )
 343     cursor clang_getCursorType clang_getTypeSpelling clang-get-cstring
 344
 345     "const" ?head drop
 346
 347     [ CHAR: * = ] cut-tail
 348     [ [ trim-blanks ] dip append ] when*
 349
 350     dup :> type
 351     {
 352         { [ dup "struct " head? ] [
 353             " " split1-last nip
 354             clang-state> unnamed-table>> ?at or
 355         ] }
 356
 357         ! libclang uses two forms for unnamed union (why!?)
 358         ! union (unnamed at /Users/erg/factor/elf2.h:39:3)
 359         ! union (unnamed union at /Users/erg/factor/elf2.h:39:3)
 360         { [ dup "union " head? ] [
 361             " " split1-last nip
 362             clang-state> unnamed-table>> ?at or
 363         ] }
 364         { [ dup "_Bool" = ] [ drop "bool" ] }
 365         { [ "int8_t" ?head ] [ trim-blanks "char" prepend ] }
 366         { [ "int16_t" ?head ] [ trim-blanks "short" prepend ] }
 367         { [ "int32_t" ?head ] [ trim-blanks "int" prepend ] }
 368         { [ "int64_t" ?head ] [ trim-blanks "longlong" prepend ] }
 369         { [ "uint8_t" ?head ] [ trim-blanks "uchar" prepend ] }
 370         { [ "uint16_t" ?head ] [ trim-blanks "ushort" prepend ] }
 371         { [ "uint32_t" ?head ] [ trim-blanks "uint" prepend ] }
 372         { [ "uint64_t" ?head ] [ trim-blanks "ulonglong" prepend ] }
 373         { [ "signed char" ?head ] [ trim-blanks "char" prepend ] }
 374         { [ "signed short" ?head ] [ trim-blanks "short" prepend ] }
 375         { [ "signed int" ?head ] [ trim-blanks "int" prepend ] }
 376         { [ "signed long" ?head ] [ trim-blanks "long" prepend ] }
 377         { [ "unsigned char" ?head ] [ trim-blanks "uchar" prepend ] }
 378         { [ "unsigned short" ?head ] [ trim-blanks "ushort" prepend ] }
 379         { [ "unsigned int" ?head ] [ trim-blanks "uint" prepend ] }
 380         { [ "unsigned long" ?head ] [ trim-blanks "ulong" prepend ] }
 381         { [ dup "(*)" swap subseq? ] [ drop "void*" ] }
 382         [ ]
 383     } cond ;
 384
 385 : cursor-name ( cursor -- string )
 386     clang_getCursorSpelling clang-get-cstring "" ?unnamed drop ;
 387
 388 : ?cursor-name ( cursor unnamed-type -- string )
 389     [ clang_getCursorSpelling clang-get-cstring ] dip ?unnamed drop ;
 390
 391 : arg-info ( cursor -- string )
 392     [ cursor-type ] [ cursor-name [ "dummy" ] when-empty ] bi " " glue ;
 393
 394 : cursor>args ( CXCursor -- args/f )
 395     dup clang_Cursor_getNumArguments dup -1 = [
 396         2drop f
 397     ] [
 398         <iota> [
 399             clang_Cursor_getArgument
 400         ] with { } map-as
 401     ] if ;
 402
 403 : cxprimitive-type>factor ( CXType -- string )
 404     {
 405         { CXType_Bool [ "bool" ] }
 406         { CXType_Char_S [ "char" ] }
 407         { CXType_Char_U [ "uchar" ] }
 408         { CXType_SChar [ "char" ] }
 409         { CXType_UChar [ "uchar" ] }
 410         { CXType_Short [ "short" ] }
 411         { CXType_UShort [ "ushort" ] }
 412         { CXType_Int [ "int" ] }
 413         { CXType_UInt [ "uint" ] }
 414         { CXType_Long [ "long" ] }
 415         { CXType_ULong [ "ulong" ] }
 416         { CXType_LongLong [ "longlong" ] }
 417         { CXType_ULongLong [ "ulonglong" ] }
 418         { CXType_Float [ "float" ] }
 419         { CXType_Double [ "double" ] }
 420         { CXType_Void [ "void" ] }
 421         [ drop "" ]
 422     } case ;
 423
 424 : cxreturn-type>factor ( CXType -- string )
 425     {
 426         { [ dup kind>> CXType_Pointer = ] [
 427             clang_getPointeeType dup g... gflush cxreturn-type>factor "*" append
 428         ] }
 429         { [ dup kind>> CXType_Elaborated = ] [
 430             clang_getCanonicalType cxreturn-type>factor
 431         ] }
 432         { [ dup kind>> CXType_Record = ] [
 433             clang_getTypeDeclaration cursor-name
 434         ] }
 435         { [ dup kind>> CXType_FunctionProto = ] [
 436             ! inside a CXType_Pointer, so we get `void*` from that case
 437             drop "void"
 438         ] }
 439         [ kind>> cxprimitive-type>factor ]
 440     } cond ;
 441
 442 : cursor>args-info ( CXCursor -- args-info )
 443     cursor>args [ arg-info ] map ", " join ;
 444
 445 : cursor>c-function ( CXCursor -- )
 446     [ clang_getCursorResultType cxreturn-type>factor ]
 447     [ cursor-name ]
 448     [ cursor>args-info ] tri <c-function> set-definition ;
 449
 450 : cursor>c-typedef ( CXCursor -- )
 451     [ clang_getTypedefDeclUnderlyingType cxreturn-type>factor ]
 452     [ cursor-name ] bi <c-typedef> set-definition ;
 453
 454 : cursor>c-field ( CXCursor -- )
 455     [ cursor-name ] [ cursor-type ] bi <c-field> dup g... gflush push-child-form ;
 456
 457 DEFER: cursor-visitor
 458
 459 : cursor>enum ( CXCursor -- )
 460     [
 461         [ cursor-name ] [ cursor-visitor ] bi
 462         f clang_visitChildren drop
 463     ] with-new-form <c-enum> set-definition ;
 464
 465 : cursor>c-union ( CXCursor -- )
 466     [
 467         "cursor>union start" g...
 468         peek-current-form g... gflush
 469
 470         [ "Union" ?cursor-name "name: " gwrite dup g... gflush ] keep
 471         cursor-visitor f clang_visitChildren drop
 472
 473         "cursor>union finish" g... gflush
 474         peek-current-form g... gflush
 475     ] with-new-form
 476     <c-union> dup g... gflush set-definition ;
 477
 478 : cursor>c-struct ( CXCursor -- )
 479     [
 480         "cursor>c-struct start" g...
 481         peek-current-form g... gflush
 482
 483         [ "Struct" ?cursor-name ] keep
 484         cursor-visitor f clang_visitChildren drop
 485
 486         "cursor>c-struct finish" g... gflush
 487         peek-current-form g... gflush
 488     ] with-new-form
 489     <c-struct> dup g... gflush set-definition ;
 490
 491 : cursor-visitor ( -- callback )
 492     [
 493         2drop
 494         dup clang_getCursorKind
 495         dup "cursor-visitor got: " gwrite g... gflush
 496         {
 497             { CXCursor_Namespace [ drop CXChildVisit_Recurse ] }
 498             { CXCursor_FunctionDecl [ cursor>c-function CXChildVisit_Continue ] }
 499             { CXCursor_TypedefDecl [ cursor>c-typedef CXChildVisit_Continue ] }
 500             { CXCursor_UnionDecl [ cursor>c-union CXChildVisit_Continue ] }
 501             { CXCursor_StructDecl [ cursor>c-struct CXChildVisit_Continue ] }
 502             { CXCursor_EnumDecl [ cursor>enum CXChildVisit_Continue ] }
 503             { CXCursor_VarDecl [ drop CXChildVisit_Continue ] }
 504
 505             { CXCursor_FieldDecl [
 506                 cursor>c-field CXChildVisit_Continue
 507             ] }
 508             { CXCursor_EnumConstantDecl [
 509                 [
 510                     [ clang-get-token-spelling ] with-cursor-tokens
 511                     first
 512                 ] [
 513                     clang_getEnumConstantDeclUnsignedValue number>string
 514                 ] bi
 515                 <c-field> push-child-form
 516                 CXChildVisit_Continue
 517             ] }
 518             [
 519                 "cursor-visitor unhandled: " gwrite dup g... gflush
 520                 2drop CXChildVisit_Recurse
 521             ]
 522         } case
 523     ] CXCursorVisitor
 524     gflush ;
 525
 526 : with-clang-index ( quot: ( index -- ) -- )
 527     [ 0 0 clang_createIndex ] dip keep clang_disposeIndex ; inline
 528
 529 : with-clang-translation-unit ( idx source-file command-line-args nargs unsaved-files nunsaved-files options quot: ( tu -- ) -- )
 530     [ enum>number clang_parseTranslationUnit ] dip
 531     keep clang_disposeTranslationUnit ; inline
 532
 533 : with-clang-default-translation-unit ( path quot: ( tu path -- ) -- )
 534     dupd '[
 535         _ f 0 f 0 CXTranslationUnit_None [
 536             _ @
 537         ] with-clang-translation-unit
 538     ] with-clang-index ; inline
 539
 540 : with-clang-cursor ( path quot: ( tu path cursor -- ) -- )
 541     dupd '[
 542         _ f 0 f 0 CXTranslationUnit_None [
 543             _ over clang_getTranslationUnitCursor @
 544         ] with-clang-translation-unit
 545     ] with-clang-index ; inline
 546
 547 ! : parse-c-defines ( path -- )
 548 !     [
 549 !         tokenize-path
 550 !         [
 551 !             ! tu void* int
 552 !             cell-bits 8 /i * swap <displaced-alien>
 553 !             clang_getTokenKind
 554 !         ] with { } map-as
 555 !     ] with-clang-default-translation-unit ;
 556
 557 : parse-c-exports ( path -- )
 558     [
 559         2nip cursor-visitor f clang_visitChildren drop
 560     ] with-clang-cursor ;
 561
 562 : write-c-defs ( -- )
 563     clang-state> c-defs-by-order>>
 564     sort-keys values
 565     [ def>out-forms ] each
 566     clang-state> out-forms>>
 567     sort-keys values [ print ] each ;
 568
 569 : parse-include ( path -- libclang-state )
 570     <libclang-state> clang-state [
 571         normalize-path
 572         ! reset-c-defs
 573         {
 574             ! [ parse-c-defines ]
 575             [ parse-c-exports ]
 576         } cleave
 577         write-c-defs
 578     ] with-output-global-variable ; inline
 579
 580
 581
 582 ! "/Library/Developer/CommandLineTools/SDKs/MacOSX10.15.sdk/usr/include/php/ext/sqlite3/libsqlite/sqlite3.h" parse-include
 583
 584 ! "/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/clang/15.0.0/include"
 585
 586 ! "resource:elf.h" parse-include
 587
 588 ![[
 589 "resource:elf.h" parse-include
 590 c-defs-by-order get-global write-c-defs
 591
 592 "resource:elf2.h" parse-include
 593
 594 ]]