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 : ptr-array>array ( ptr c-type n -- array )
 346     [ heap-size ] [ <iota> ] bi*
 347     [
 348         * swap <displaced-alien>
 349     ] with with { } map-as ;
 350
 351 :: with-cursor-tokens ( cursor quot: ( tu token -- obj ) -- seq )
 352     cursor clang_Cursor_getTranslationUnit :> tu
 353     tu cursor clang_getCursorExtent clang-tokenize :> ( tokens ntokens )
 354     tu
 355     tokens CXToken ntokens ptr-array>array
 356     [ clang_getTokenSpelling clang-get-cstring ] with map
 357     tu tokens ntokens clang_disposeTokens ; inline
 358
 359 DEFER: cursor>c-struct
 360 DEFER: cursor>c-union
 361
 362 :: cursor-type ( cursor -- string )
 363     cursor clang_getCursorType clang_getTypeSpelling clang-get-cstring
 364
 365     "const" ?head drop
 366
 367     [ CHAR: * = ] cut-tail
 368     [ [ trim-blanks ] dip append ] when*
 369
 370     dup :> type
 371     {
 372         { [ dup "struct " head? ] [
 373             " " split1-last nip
 374             clang-state> unnamed-table>> ?at or
 375         ] }
 376
 377         ! libclang uses two forms for unnamed union (why!?)
 378         ! union (unnamed at /Users/erg/factor/elf2.h:39:3)
 379         ! union (unnamed union at /Users/erg/factor/elf2.h:39:3)
 380         { [ dup "union " head? ] [
 381             " " split1-last nip
 382             clang-state> unnamed-table>> ?at or
 383         ] }
 384         { [ dup "_Bool" = ] [ drop "bool" ] }
 385         { [ "int8_t" ?head ] [ trim-blanks "char" prepend ] }
 386         { [ "int16_t" ?head ] [ trim-blanks "short" prepend ] }
 387         { [ "int32_t" ?head ] [ trim-blanks "int" prepend ] }
 388         { [ "int64_t" ?head ] [ trim-blanks "longlong" prepend ] }
 389         { [ "uint8_t" ?head ] [ trim-blanks "uchar" prepend ] }
 390         { [ "uint16_t" ?head ] [ trim-blanks "ushort" prepend ] }
 391         { [ "uint32_t" ?head ] [ trim-blanks "uint" prepend ] }
 392         { [ "uint64_t" ?head ] [ trim-blanks "ulonglong" prepend ] }
 393         { [ "signed char" ?head ] [ trim-blanks "char" prepend ] }
 394         { [ "signed short" ?head ] [ trim-blanks "short" prepend ] }
 395         { [ "signed int" ?head ] [ trim-blanks "int" prepend ] }
 396         { [ "signed long" ?head ] [ trim-blanks "long" prepend ] }
 397         { [ "unsigned char" ?head ] [ trim-blanks "uchar" prepend ] }
 398         { [ "unsigned short" ?head ] [ trim-blanks "ushort" prepend ] }
 399         { [ "unsigned int" ?head ] [ trim-blanks "uint" prepend ] }
 400         { [ "unsigned long" ?head ] [ trim-blanks "ulong" prepend ] }
 401         { [ dup "(*)" swap subseq? ] [ drop "void*" ] }
 402         [ ]
 403     } cond ;
 404
 405 : cursor-name ( cursor -- string )
 406     clang_getCursorSpelling clang-get-cstring "Enum" ?unnamed drop ;
 407
 408 : ?cursor-name ( cursor unnamed-type -- string )
 409     [ clang_getCursorSpelling clang-get-cstring ] dip ?unnamed drop ;
 410
 411 : arg-info ( cursor -- string )
 412     [ cursor-type ] [ cursor-name [ "dummy" ] when-empty ] bi " " glue ;
 413
 414 : cursor>args ( CXCursor -- args/f )
 415     dup clang_Cursor_getNumArguments dup -1 = [
 416         2drop f
 417     ] [
 418         <iota> [
 419             clang_Cursor_getArgument
 420         ] with { } map-as
 421     ] if ;
 422
 423 : cxprimitive-type>factor ( CXType -- string )
 424     {
 425         { CXType_Bool [ "bool" ] }
 426         { CXType_Char_S [ "char" ] }
 427         { CXType_Char_U [ "uchar" ] }
 428         { CXType_SChar [ "char" ] }
 429         { CXType_UChar [ "uchar" ] }
 430         { CXType_Short [ "short" ] }
 431         { CXType_UShort [ "ushort" ] }
 432         { CXType_Int [ "int" ] }
 433         { CXType_UInt [ "uint" ] }
 434         { CXType_Long [ "long" ] }
 435         { CXType_ULong [ "ulong" ] }
 436         { CXType_LongLong [ "longlong" ] }
 437         { CXType_ULongLong [ "ulonglong" ] }
 438         { CXType_Float [ "float" ] }
 439         { CXType_Double [ "double" ] }
 440         { CXType_Void [ "void" ] }
 441         [ drop "" ]
 442     } case ;
 443
 444 : cxreturn-type>factor ( CXType -- string )
 445     {
 446         { [ dup kind>> CXType_Pointer = ] [
 447             clang_getPointeeType cxreturn-type>factor "*" append
 448         ] }
 449         { [ dup kind>> CXType_Elaborated = ] [
 450             clang_getCanonicalType cxreturn-type>factor
 451         ] }
 452         { [ dup kind>> CXType_Record = ] [
 453             clang_getTypeDeclaration cursor-name
 454         ] }
 455         { [ dup kind>> CXType_FunctionProto = ] [
 456             ! inside a CXType_Pointer, so we get `void*` from that case
 457             drop "void"
 458         ] }
 459         [ kind>> cxprimitive-type>factor ]
 460     } cond ;
 461
 462 : cursor>args-info ( CXCursor -- args-info )
 463     cursor>args [ arg-info ] map ", " join ;
 464
 465 : cursor>c-function ( CXCursor -- )
 466     [ clang_getCursorResultType cxreturn-type>factor ]
 467     [ cursor-name ]
 468     [ cursor>args-info ] tri <c-function> set-definition ;
 469
 470 : cursor>c-typedef ( CXCursor -- )
 471     [ clang_getTypedefDeclUnderlyingType cxreturn-type>factor ]
 472     [ cursor-name ] bi <c-typedef> [ set-definition ] [ set-typedef ] bi ;
 473
 474 : cursor>c-field ( CXCursor -- )
 475     [ cursor-name ] [ cursor-type ] bi <c-field> push-child-form ;
 476
 477 DEFER: cursor-visitor
 478
 479 : cursor>enum ( CXCursor -- )
 480     [
 481         [ cursor-name ] [ cursor-visitor ] bi
 482         f clang_visitChildren drop
 483     ] with-new-form <c-enum> set-definition ;
 484
 485 : cursor>c-union ( CXCursor -- )
 486     [
 487         [ "Union" ?cursor-name ] keep
 488         cursor-visitor f clang_visitChildren drop
 489     ] with-new-form
 490     <c-union> set-definition ;
 491
 492 : cursor>c-struct ( CXCursor -- )
 493     [
 494         [ "Struct" ?cursor-name ] keep
 495         cursor-visitor f clang_visitChildren drop
 496     ] with-new-form
 497     <c-struct> set-definition ;
 498
 499 : cursor-visitor ( -- callback )
 500     [
 501         2drop
 502         dup clang_getCursorKind
 503         ! dup "cursor-visitor got: " gwrite g... gflush
 504         {
 505             { CXCursor_Namespace [ drop CXChildVisit_Recurse ] }
 506             { CXCursor_FunctionDecl [ cursor>c-function CXChildVisit_Continue ] }
 507             { CXCursor_TypedefDecl [ cursor>c-typedef CXChildVisit_Continue ] }
 508             { CXCursor_UnionDecl [ cursor>c-union CXChildVisit_Continue ] }
 509             { CXCursor_StructDecl [ cursor>c-struct CXChildVisit_Continue ] }
 510             { CXCursor_EnumDecl [ cursor>enum CXChildVisit_Continue ] }
 511             { CXCursor_VarDecl [ drop CXChildVisit_Continue ] }
 512
 513             { CXCursor_FieldDecl [
 514                 cursor>c-field CXChildVisit_Continue
 515             ] }
 516             { CXCursor_EnumConstantDecl [
 517                 [
 518                     [
 519                         clang_getTokenSpelling clang-get-cstring
 520                     ] with-cursor-tokens
 521                     first
 522                 ] [
 523                     clang_getEnumConstantDeclUnsignedValue number>string
 524                 ] bi
 525                 <c-field> push-child-form
 526                 CXChildVisit_Continue
 527             ] }
 528             { CXCursor_UnexposedDecl [ drop CXChildVisit_Continue ] }
 529             [
 530                 "cursor-visitor unhandled: " gwrite dup g... gflush
 531                 2drop CXChildVisit_Recurse
 532             ]
 533         } case
 534     ] CXCursorVisitor
 535     gflush ;
 536
 537 : with-clang-index ( quot: ( index -- ) -- )
 538     [ 0 0 clang_createIndex ] dip keep clang_disposeIndex ; inline
 539
 540 : with-clang-translation-unit ( idx source-file command-line-args nargs unsaved-files nunsaved-files options quot: ( tu -- ) -- )
 541     [ enum>number clang_parseTranslationUnit ] dip
 542     keep clang_disposeTranslationUnit ; inline
 543
 544 : with-clang-default-translation-unit ( path quot: ( tu path -- ) -- )
 545     dupd '[
 546         _ f 0 f 0 CXTranslationUnit_None [
 547             _ @
 548         ] with-clang-translation-unit
 549     ] with-clang-index ; inline
 550
 551 : with-clang-cursor ( path quot: ( tu path cursor -- ) -- )
 552     dupd '[
 553         _ f 0 f 0 CXTranslationUnit_None [
 554             _ over clang_getTranslationUnitCursor @
 555         ] with-clang-translation-unit
 556     ] with-clang-index ; inline
 557
 558 : parse-c-exports ( path -- )
 559     [
 560         2nip cursor-visitor f clang_visitChildren drop
 561     ] with-clang-cursor ;
 562
 563 : write-c-defs ( clang-state -- )
 564     [
 565         c-defs-by-order>>
 566         sort-keys values
 567         [ def>out-forms ] each
 568     ] [
 569         [
 570             [ members [ length ] inv-sort-by ] assoc-map
 571         ] change-out-forms-by-name
 572         out-forms>>
 573         sort-keys values [ print ] each
 574     ] bi ;
 575
 576 : parse-include ( path -- libclang-state )
 577     <libclang-state> clang-state [
 578         normalize-path
 579         parse-c-exports
 580     ] with-output-global-variable
 581     ! dup write-c-defs
 582     ;
 583
 584 : parse-hpp-files ( path -- assoc )
 585     ?qualified-directory-files
 586     [ ".hpp" tail? ] filter
 587     [ parse-include ] zip-with ;
 588
 589 : parse-h-files ( path -- assoc )
 590     ?qualified-directory-files
 591     [ ".h" tail? ] filter
 592     [ parse-include ] zip-with ;
 593
 594 : parse-cpp-files ( path -- assoc )
 595     ?qualified-directory-files
 596     [ ".cpp" tail? ] filter
 597     [ parse-include ] zip-with ;