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