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