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