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 byte-arrays classes.struct combinators
5 combinators.smart discord io io.backend io.encodings.utf8
6 io.files.info kernel layouts libc libclang.ffi make math
7 sequences splitting strings ;
14 { latest-offset uint } ;
16 : <malloced> ( len -- malloced )
17 malloced malloc-struct
18 over 1 + <byte-array> malloc-byte-array >>byte-array
23 : mark-malloced ( malloced -- malloced )
24 dup offset>> >>latest-offset ;
26 : reset-malloced ( malloced -- malloced )
27 dup latest-offset>> >>offset ;
29 : malloced-string ( malloced -- string )
30 byte-array>> utf8 alien>string ;
32 : append-oom? ( malloced string -- ? )
33 [ [ len>> ] [ offset>> ] bi - ]
36 : realloc-malloced ( malloced -- malloced' )
38 '[ [ _ 1 + realloc ] change-byte-array ] keep >>len ;
40 : append-malloced ( malloced string -- malloced )
42 [ [ realloc-malloced ] dip append-malloced ] [
45 [ offset>> ] [ byte-array>> ] bi <displaced-alien>
46 ] dip [ utf8 string>alien ] [ length ] bi memcpy
48 '[ _ length + ] change-offset
52 : malloced>string ( malloced -- string )
53 [ byte-array>> utf8 alien>string ] [ free ] bi ;
55 : CXCursor>factor ( cursor -- string )
56 dup clang_getCursorKind {
57 { CXCursor_FunctionDecl [ drop f ] }
58 { CXType_Pointer [ drop f ] }
59 { CXType_Invalid [ drop f ] }
63 : clang-get-cstring ( CXString -- string )
64 clang_getCString [ utf8 alien>string ] [ clang_disposeString ] bi ;
66 : trim-blanks ( string -- string' )
67 [ blank? ] trim ; inline
69 : remove-const ( strinng -- string' )
70 "const" split1 [ trim-blanks ] bi@ " " glue trim-blanks ;
72 : cursor-type ( cursor -- string )
74 clang_getTypeSpelling clang-get-cstring
77 "*" ?tail [ trim-blanks "*" append ] when
78 "struct " ?head drop ! [ trim-blanks ] when
81 { [ dup "unsigned char" = ] [ drop "uchar" ] }
82 { [ "unsigned char" ?head ] [ trim-blanks "uchar" prepend ] }
83 { [ "unsigned int" ?head ] [ trim-blanks "uint" prepend ] }
84 ! { [ "*" ?tail ] [ trim-blanks "*" append ] }
85 { [ dup "(*)" swap subseq? ] [ drop "void*" ] }
89 : cursor-name ( cursor -- string )
90 clang_getCursorSpelling clang-get-cstring ;
92 : arg-info ( cursor -- string )
93 [ cursor-type ] [ cursor-name [ "dummy" ] when-empty ] bi " " glue ;
95 : cursor>args ( CXCursor -- args/f )
96 dup clang_Cursor_getNumArguments dup -1 = [
100 clang_Cursor_getArgument
104 : cxprimitive-type>factor ( CXType -- string )
106 { CXType_Bool [ "bool" ] }
107 { CXType_Char_S [ "char" ] }
108 { CXType_Char_U [ "uchar" ] }
109 { CXType_SChar [ "char" ] }
110 { CXType_UChar [ "uchar" ] }
111 { CXType_Short [ "short" ] }
112 { CXType_UShort [ "ushort" ] }
113 { CXType_Int [ "int" ] }
114 { CXType_UInt [ "uint" ] }
115 { CXType_Long [ "long" ] }
116 { CXType_ULong [ "ulong" ] }
117 { CXType_LongLong [ "longlong" ] }
118 { CXType_ULongLong [ "ulonglong" ] }
119 { CXType_Float [ "float" ] }
120 { CXType_Double [ "double" ] }
121 { CXType_Void [ "void" ] }
125 : cxreturn-type>factor ( CXType -- string )
127 { [ dup kind>> CXType_Pointer = ] [
128 clang_getPointeeType dup g... gflush cxreturn-type>factor "*" append
130 { [ dup kind>> CXType_Elaborated = ] [
131 clang_getCanonicalType cxreturn-type>factor
133 { [ dup kind>> CXType_Record = ] [
134 clang_getTypeDeclaration cursor-name
136 { [ dup kind>> CXType_FunctionProto = ] [
137 ! inside a CXType_Pointer, so we get `void*` from that case
140 [ kind>> cxprimitive-type>factor ]
143 : cursor>args-info ( CXCursor -- args-info )
144 cursor>args [ arg-info ] map ", " join ;
146 : function>string ( CXCursor -- string )
149 [ drop "FUNCTION: " ]
150 [ clang_getCursorResultType cxreturn-type>factor ]
154 [ cursor>args-info dup empty? ")\n" " )\n" ? ]
156 ] "" append-outputs-as ;
158 : typedef>string ( CXCursor -- string )
159 [ clang_getTypedefDeclUnderlyingType cxreturn-type>factor ]
164 " " glue "TYPEDEF: " "\n" surround
168 : field-visitor ( -- callback )
171 malloced memory>struct
172 swap dup clang_getCursorKind
174 { CXCursor_FieldDecl [
175 [ cursor-name ] [ cursor-type ] bi " " glue
176 "\n { " " }" surround
178 CXChildVisit_Continue
180 ! { CXCursor_TypedefDecl [ 2drop CXChildVisit_Continue ] }
181 ! { CXCursor_StructDecl [ 2drop CXChildVisit_Continue ] }
182 [ dup g... 3drop CXChildVisit_Recurse ]
187 : struct>string ( malloced CXCursor -- )
188 [ mark-malloced ] dip
189 tuck cursor-name "STRUCT: " prepend append-malloced
190 [ field-visitor ] dip
191 [ clang_visitChildren drop ] keep
192 ! hack to removev typedefs like `typedef struct foo foo;`
193 dup malloced-string "}" tail? [
194 " ;\n" append-malloced drop
199 : cursor-visitor ( -- callback )
202 malloced memory>struct
203 swap dup clang_getCursorKind
205 { CXCursor_Namespace [ 2drop CXChildVisit_Recurse ] }
206 { CXCursor_FunctionDecl [ function>string append-malloced drop CXChildVisit_Continue ] }
207 { CXCursor_TypedefDecl [ typedef>string append-malloced drop CXChildVisit_Continue ] }
208 { CXCursor_StructDecl [ struct>string CXChildVisit_Continue ] }
209 [ dup g... 3drop CXChildVisit_Recurse ]
214 : with-clang-index ( quot: ( index -- string ) -- )
215 [ 0 0 clang_createIndex ] dip keep clang_disposeIndex ; inline
217 : with-clang-translation-unit ( idx source-file command-line-args nargs unsaved-files nunsaved-files options quot: ( tu -- string ) -- )
218 [ enum>number clang_parseTranslationUnit ] dip
219 keep clang_disposeTranslationUnit ; inline
221 : with-clang-default-translation-unit ( path quot: ( path tu -- string ) -- )
223 _ f 0 f 0 CXTranslationUnit_None [
225 ] with-clang-translation-unit
226 ] with-clang-index ; inline
228 : with-clang-cursor ( path quot: ( path tu cursor -- string ) -- )
230 _ f 0 f 0 CXTranslationUnit_None [
231 [ _ ] dip dup clang_getTranslationUnitCursor @
232 ] with-clang-translation-unit
233 ] with-clang-index ; inline
235 : clang-get-file-max-range ( CXTranslationUnit path -- CXSourceRange )
236 [ dupd clang_getFile 0 clang_getLocationForOffset ]
237 [ dupd [ clang_getFile ] [ nip file-info size>> ] 2bi clang_getLocationForOffset ] 2bi
240 : parse-c-defines ( path -- string )
244 dupd clang-get-file-max-range ! tu CXRange
247 [ clang_tokenize ] 2keep
249 [ uint deref <iota> ] bi*
252 cell-bits 8 /i * swap <displaced-alien>
255 ] with-clang-default-translation-unit ;
257 : parse-c-exports ( path -- string )
259 nip cursor-visitor rot file-info size>> 2 * <malloced>
260 [ clang_visitChildren drop ] keep malloced>string
261 ] with-clang-cursor ;
263 : parse-include ( path -- string )
266 ! [ parse-c-defines ]
270 ! "/Library/Developer/CommandLineTools/SDKs/MacOSX10.15.sdk/usr/include/php/ext/sqlite3/libsqlite/sqlite3.h" parse-include
272 ! "/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/clang/15.0.0/include"