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