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.short-circuit combinators.smart discord io
6 io.backend io.encodings.utf8 io.files.info kernel layouts libc
7 libclang.ffi make math math.parser sequences sequences.private
15 { marked-offset uint } ;
17 : <malloced> ( len -- malloced )
18 malloced malloc-struct
19 over 1 + <byte-array> malloc-byte-array >>byte-array
24 : mark-malloced ( malloced -- malloced )
25 dup offset>> >>marked-offset ;
27 : since-reset ( malloced -- string )
28 [ marked-offset>> ] [ byte-array>> ] bi
29 <displaced-alien> utf8 alien>string ;
31 : reset-malloced ( malloced -- malloced string )
33 [ dup marked-offset>> >>offset ] bi swap ;
35 : malloced-string ( malloced -- string )
36 byte-array>> utf8 alien>string ;
38 : append-oom? ( malloced string -- ? )
39 [ [ len>> ] [ offset>> ] bi - ]
42 : realloc-malloced ( malloced -- malloced' )
44 '[ [ _ 1 + realloc ] change-byte-array ] keep >>len ;
46 : append-malloced ( malloced string -- malloced )
48 [ [ realloc-malloced ] dip append-malloced ] [
51 [ offset>> ] [ byte-array>> ] bi <displaced-alien>
52 ] dip [ utf8 string>alien ] [ length ] bi memcpy
54 '[ _ length + ] change-offset
58 : malloced>string ( malloced -- string )
59 [ byte-array>> utf8 alien>string ] [ free ] bi ;
61 : clang-get-cstring ( CXString -- string )
62 clang_getCString [ utf8 alien>string ] [ clang_disposeString ] bi ;
64 : trim-blanks ( string -- string' )
65 [ blank? ] trim ; inline
67 : cut-tail ( string quot -- before after ) (trim-tail) cut ; inline
70 cell-bits 8 /i ; inline
72 : get-tokens ( tokens ntokens -- tokens )
74 _ * swap <displaced-alien>
78 : clang-get-file-max-range ( CXTranslationUnit path -- CXSourceRange )
79 [ dupd clang_getFile 0 clang_getLocationForOffset ]
80 [ dupd [ clang_getFile ] [ nip file-info size>> ] 2bi clang_getLocationForOffset ] 2bi
83 : clang-tokenize ( CXTranslationUnit CXSourceRange -- tokens ntokens )
86 [ clang_tokenize ] 2keep
90 : tokenize-path ( tu path -- tokens ntokens )
91 [ drop ] [ clang-get-file-max-range ] 2bi
94 : tokenize-translation-unit ( CXTranslationUnit -- tokens ntokens )
95 [ ] [ clang_getTranslationUnitCursor clang_getCursorExtent ] bi
98 : tokenize-cursor ( cursor -- tokens ntokens )
99 [ clang_Cursor_getTranslationUnit ] [ clang_getCursorExtent ] bi
102 : dispose-tokens ( cursor tokens ntokens -- )
103 [ clang_Cursor_getTranslationUnit ] 2dip clang_disposeTokens ;
105 :: with-cursor-tokens ( cursor quot: ( tu token -- obj ) -- )
106 cursor clang_Cursor_getTranslationUnit :> tu
107 cursor tokenize-cursor :> ( tokens ntokens )
108 tokens ntokens <iota>
109 cell-bytes :> bytesize
112 [ tu ] 2dip bytesize * swap <displaced-alien> @
114 tu tokens ntokens dispose-tokens ; inline
116 : clang-get-token-spelling ( CXTranslationUnit CXToken -- string )
117 clang_getTokenSpelling clang-get-cstring ;
119 : cursor-type ( cursor -- string )
121 clang_getTypeSpelling clang-get-cstring
125 [ CHAR: * = ] cut-tail
126 [ [ trim-blanks ] dip append ] when*
130 { [ dup "_Bool" = ] [ drop "bool" ] }
131 { [ "int8_t" ?head ] [ trim-blanks "char" prepend ] }
132 { [ "int16_t" ?head ] [ trim-blanks "short" prepend ] }
133 { [ "int32_t" ?head ] [ trim-blanks "int" prepend ] }
134 { [ "int64_t" ?head ] [ trim-blanks "longlong" prepend ] }
135 { [ "uint8_t" ?head ] [ trim-blanks "uchar" prepend ] }
136 { [ "uint16_t" ?head ] [ trim-blanks "ushort" prepend ] }
137 { [ "uint32_t" ?head ] [ trim-blanks "uint" prepend ] }
138 { [ "uint64_t" ?head ] [ trim-blanks "ulonglong" prepend ] }
139 { [ "signed char" ?head ] [ trim-blanks "char" prepend ] }
140 { [ "signed short" ?head ] [ trim-blanks "short" prepend ] }
141 { [ "signed int" ?head ] [ trim-blanks "int" prepend ] }
142 { [ "signed long" ?head ] [ trim-blanks "long" prepend ] }
143 { [ "unsigned char" ?head ] [ trim-blanks "uchar" prepend ] }
144 { [ "unsigned short" ?head ] [ trim-blanks "ushort" prepend ] }
145 { [ "unsigned int" ?head ] [ trim-blanks "uint" prepend ] }
146 { [ "unsigned long" ?head ] [ trim-blanks "ulong" prepend ] }
147 { [ dup "(*)" swap subseq? ] [ drop "void*" ] }
151 : cursor-name ( cursor -- string )
152 clang_getCursorSpelling clang-get-cstring ;
154 : arg-info ( cursor -- string )
155 [ cursor-type ] [ cursor-name [ "dummy" ] when-empty ] bi " " glue ;
157 : cursor>args ( CXCursor -- args/f )
158 dup clang_Cursor_getNumArguments dup -1 = [
162 clang_Cursor_getArgument
166 : cxprimitive-type>factor ( CXType -- string )
168 { CXType_Bool [ "bool" ] }
169 { CXType_Char_S [ "char" ] }
170 { CXType_Char_U [ "uchar" ] }
171 { CXType_SChar [ "char" ] }
172 { CXType_UChar [ "uchar" ] }
173 { CXType_Short [ "short" ] }
174 { CXType_UShort [ "ushort" ] }
175 { CXType_Int [ "int" ] }
176 { CXType_UInt [ "uint" ] }
177 { CXType_Long [ "long" ] }
178 { CXType_ULong [ "ulong" ] }
179 { CXType_LongLong [ "longlong" ] }
180 { CXType_ULongLong [ "ulonglong" ] }
181 { CXType_Float [ "float" ] }
182 { CXType_Double [ "double" ] }
183 { CXType_Void [ "void" ] }
187 : cxreturn-type>factor ( CXType -- string )
189 { [ dup kind>> CXType_Pointer = ] [
190 clang_getPointeeType dup g... gflush cxreturn-type>factor "*" append
192 { [ dup kind>> CXType_Elaborated = ] [
193 clang_getCanonicalType cxreturn-type>factor
195 { [ dup kind>> CXType_Record = ] [
196 clang_getTypeDeclaration cursor-name
198 { [ dup kind>> CXType_FunctionProto = ] [
199 ! inside a CXType_Pointer, so we get `void*` from that case
202 [ kind>> cxprimitive-type>factor ]
205 : cursor>args-info ( CXCursor -- args-info )
206 cursor>args [ arg-info ] map ", " join ;
208 : function>string ( CXCursor -- string )
211 [ drop "FUNCTION: " ]
212 [ clang_getCursorResultType cxreturn-type>factor ]
216 [ cursor>args-info dup empty? ")\n" " )\n" ? ]
218 ] "" append-outputs-as ;
220 : typedef>string ( CXCursor -- string )
221 [ clang_getTypedefDeclUnderlyingType cxreturn-type>factor ]
223 2dup { [ and ] [ = ] } 2||
224 [ nip "TYPEDEF: void* " "\n" surround ] [ " " glue "TYPEDEF: " "\n" surround ] if ;
226 : field-visitor ( -- callback )
229 malloced memory>struct
230 swap dup clang_getCursorKind
232 { CXCursor_FieldDecl [
233 [ cursor-name ] [ cursor-type ] bi " " glue
234 "\n { " " }" surround
236 CXChildVisit_Continue
238 [ dup g... 3drop CXChildVisit_Recurse ]
243 : struct>string ( malloced CXCursor -- )
244 [ mark-malloced ] dip
245 tuck cursor-name append-malloced
246 [ field-visitor ] dip
247 [ clang_visitChildren drop ] keep
248 ! hack to removev typedefs like `typedef struct foo foo;`
249 dup malloced-string "}" tail? [
250 reset-malloced "STRUCT: " " ;\n" surround
253 reset-malloced "TYPEDEF: void* " "\n" surround
257 : enum-visitor ( -- callback )
260 malloced memory>struct
261 swap dup clang_getCursorKind
263 { CXCursor_EnumConstantDecl [
266 [ clang-get-token-spelling ] with-cursor-tokens
269 clang_getEnumConstantDeclUnsignedValue number>string
272 "\n { " " }" surround
274 CXChildVisit_Continue
276 ! { CXCursor_IntegerLiteral [
278 ! [ clang-get-token-spelling ] with-cursor-tokens
279 ! first " " " }" surround append-malloced drop
280 ! CXChildVisit_Continue
282 [ "omg" g... 3dup [ g... ] tri@ 3drop CXChildVisit_Recurse ]
287 : enum>string ( malloced CXCursor -- )
288 [ mark-malloced ] dip
289 tuck cursor-name "ENUM: " prepend append-malloced
291 [ clang_visitChildren drop ] keep
292 " ;\n" append-malloced drop ;
294 : cursor-visitor ( -- callback )
297 malloced memory>struct
298 swap dup clang_getCursorKind
301 { CXCursor_Namespace [ 2drop CXChildVisit_Recurse ] }
302 { CXCursor_FunctionDecl [ function>string append-malloced drop CXChildVisit_Continue ] }
303 { CXCursor_TypedefDecl [ typedef>string append-malloced drop CXChildVisit_Continue ] }
304 { CXCursor_StructDecl [ struct>string CXChildVisit_Continue ] }
305 { CXCursor_EnumDecl [ enum>string CXChildVisit_Continue ] }
306 ! { CXType_FunctionProto [ cursor-name "C-TYPE: " "\n" surround append-malloced drop CXChildVisit_Continue ] }
307 [ dup g... 3drop CXChildVisit_Recurse ]
312 : with-clang-index ( quot: ( index -- string ) -- )
313 [ 0 0 clang_createIndex ] dip keep clang_disposeIndex ; inline
315 : with-clang-translation-unit ( idx source-file command-line-args nargs unsaved-files nunsaved-files options quot: ( tu -- string ) -- )
316 [ enum>number clang_parseTranslationUnit ] dip
317 keep clang_disposeTranslationUnit ; inline
319 : with-clang-default-translation-unit ( path quot: ( tu path -- string ) -- )
321 _ f 0 f 0 CXTranslationUnit_None [
323 ] with-clang-translation-unit
324 ] with-clang-index ; inline
326 : with-clang-cursor ( path quot: ( tu path cursor -- string ) -- )
328 _ f 0 f 0 CXTranslationUnit_None [
329 _ over clang_getTranslationUnitCursor @
330 ] with-clang-translation-unit
331 ] with-clang-index ; inline
333 : parse-c-defines ( path -- string )
338 cell-bits 8 /i * swap <displaced-alien>
341 ] with-clang-default-translation-unit ;
343 : parse-c-exports ( path -- string )
345 nipd cursor-visitor rot file-info size>> 2 * <malloced>
346 [ clang_visitChildren drop ] keep malloced>string
347 ] with-clang-cursor ;
349 : parse-include ( path -- string )
352 ! [ parse-c-defines ]
356 ! "/Library/Developer/CommandLineTools/SDKs/MacOSX10.15.sdk/usr/include/php/ext/sqlite3/libsqlite/sqlite3.h" parse-include
358 ! "/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib/clang/15.0.0/include"