;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE: ast.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: Common-Lisp
;;;;USER-INTERFACE: NONE
;;;;DESCRIPTION
;;;;
;;;; Reads the AST dumped by ast.c.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;; 2013-01-29 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; AGPL3
;;;;
;;;; Copyright Pascal J. Bourguignon 2013 - 2013
;;;;
;;;; This program is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Affero General Public
;;;; License as published by the Free Software Foundation, either
;;;; version 3 of the License, or (at your option) any later
;;;; version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU Affero General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Affero General Public License
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************
(defvar *indentation* 2)
(defvar *indent-level* 0)
(defgeneric generate-code (ast-node)
(:documentation
"Return a string containing the source code for the AST-NODE."))
(defvar *cxobjects*)
(defun length=1 (list)
(and (consp list) (null (cdr list))))
(defun slot-specifiers (slots &optional prefix)
(mapcar (lambda (slot)
`(,slot :initarg ,(intern (symbol-name slot) "KEYWORD")
:initform nil
:accessor ,(if prefix
(intern
(concatenate 'string (symbol-name prefix)
(symbol-name slot))
(symbol-package prefix))
slot)))
slots))
(defun slots-to-sexp (slots object)
`(,(class-name (class-of object))
,@(mapcan (lambda (slot)
(list (intern (symbol-name slot) "KEYWORD")
(slot-value object slot)))
slots)))
(defparameter *platform-availability-slots*
'(platform introduced deprecated obsoleted unavailable message))
(defclass platform-availability ()
#.(slot-specifiers *platform-availability-slots* 'platform-))
(defmethod slots ((self platform-availability))
*platform-availability-slots*)
(defmethod to-sexp ((self platform-availability))
(slots-to-sexp *platform-availability-slots* self))
(defparameter *availability-slots*
'(always-deprecated always-deprecated-message
always-unavailable always-unavailable-message
platforms))
(defclass availability ()
#.(slot-specifiers *availability-slots* 'availability-))
(defmethod slots ((self availability))
*availability-slots*)
(defmethod to-sexp ((self availability))
(slots-to-sexp *availability-slots* self))
(defparameter *cxsourcelocation-slots* '(file line column offset))
(defclass cxsourcelocation ()
#.(slot-specifiers *cxsourcelocation-slots* 'cxsourcelocation-))
(defmethod slots ((self cxsourcelocation))
*cxsourcelocation-slots*)
(defmethod to-sexp ((self cxsourcelocation))
(slots-to-sexp *cxsourcelocation-slots* self))
(defmethod print-object ((self cxsourcelocation) stream)
(format stream "~A:~A:~A:"
(location-file self)
(location-line self)
(location-column self))
self)
(defparameter *cssourcerange-slots* '(start end))
(defclass cssourcerange ()
#.(slot-specifiers *cssourcerange-slots* 'cssourcerange-))
(defmethod slots ((self cssourcerange))
*cssourcerange-slots*)
(defmethod to-sexp ((self cssourcerange))
(slots-to-sexp *cssourcerange-slots* self))
(defmethod print-object ((self cssourcerange) stream)
(print-unreadable-object (self stream :identity t :type t)
(format stream "~S" (list :start (range-start self)
:end (range-end self))))
self)
(dolist (kind '(platform-availability availability))
(setf (symbol-function kind)
(lambda (&rest arguments &key &allow-other-keys)
(apply (function make-instance) kind arguments))))
(defun token (&rest args) (values))
(defparameter *cxtype-slots*
'(kind-spelling const volatile restrict pod-type canonical-type
declaration element-type number-of-elements array-element-type
array-size pointee calling-convention result-type arguments
variadic))
(defclass cxtype ()
#.(slot-specifiers *cxtype-slots* 'type-))
(defmethod slots ((self cxtype))
*cxtype-slots*)
(defmethod to-sexp ((type cxtype))
(slots-to-sexp *cxtype-slots* type))
(defparameter *predefined-types*
'((Unexposed . nil)
(Void . "void")
(Bool . "bool")
(Char-U . ("Char-U"))
(unsigned-Char . "unsigned char")
(Char-16 . ("Char-16"))
(Char-32 . ("Char-32"))
(unsigned-Short . "unsigned short")
(unsigned-Int . "unsigned int")
(unsigned-Long . "unsigned long")
(unsigned-Long-Long . "unsigned long long")
(unsigned-Int-128 . "unsigned __int128")
(Char-S . ("Char-S"))
(Signed-Char . "signed char")
(Wide-Char . "wide char")
(Short . "short")
(Int . "int")
(Long . "long")
(Long-Long . "long long")
(Int-128 . "__int128")
(c-Float . "float")
(Double . "double")
(Long-Double . "long double")
(Null-Pointer . ("Null-Pointer"))
(Overload . ("Overload"))
(Dependent . ("Dependent"))
(ObjC-Id . "id")
(ObjC-Class . "Class")
(ObjC-Selector . "SEL")
(c-Complex . "complex")
(Pointer . ("Pointer"))
(Block-Pointer . ("Block-Pointer"))
(left-Value-Reference . ("left-Value-Reference"))
(right-Value-Reference . ("right-Value-Reference"))
(Record . ("struct"))
(Enum . ("enum"))
(Typedef . ("typedef"))
(ObjC-Interface . ("@interface"))
(ObjC-Object-Pointer . ("ObjC-Object-Pointer"))
(Function-No-Proto . ("Function-No-Proto"))
(Function-Proto . ("Function-Proto"))
(Constant-Array . ("Constant-Array"))
(c-Vector . ("c-Vector"))
(invalid . (:invalid))))
(defmethod generate-code ((self cxtype))
(let ((entry (assoc (class-name (class-of self)) *predefined-types*)))
(if (stringp (cdr entry))
(cdr entry)
(error "Code generation for type ~S is undefined." self))))
(defparameter *cxcursor-slots*
'(is-declaration is-reference is-expression is-statement
is-attribute is-invalid is-translation-unit is-preprocessing
is-unexposed linkage platform-availability language
translation-unit semantic-parent lexical-parent included-file
location range type underlying-type enum-type enum-constant
unsigned-enum-constant arguments overloaded-declarations
access-specifier virtual-base is-definition definition canonical children
bit-field-width spelling usr referenced objc-type-encoding
result-type token-kind token-spelling token))
(defparameter *cxcursor-cursor-slots*
'(arguments overloaded-declarations definition canonical children referenced)
"CXCursor slots that may be cxcursor or lists of cxcursors.")
(defclass cxcursor ()
#.(slot-specifiers *cxcursor-slots* 'cursor-))
(defmethod slots ((self cxcursor))
*cxcursor-slots*)
(defmethod to-sexp ((cursor cxcursor))
(slots-to-sexp *cxcursor-slots* cursor))
(defmethod print-object ((cursor cxcursor) stream)
(print-unreadable-object (cursor stream :identity t :type t)
(format stream "~S ~S" (cursor-spelling cursor)
(cursor-location cursor)))
cursor)
(defclass forward-cxobject-reference ()
((ident :initarg :ident :accessor ident)))
(defmethod resolve ((reference forward-cxobject-reference))
(or (gethash (ident reference) *cxobjects*)
reference))
(dolist (kind '(cxcursor cxtype cxsourcerange cxsourcelocation))
(setf (symbol-function kind)
(lambda (ident)
(or (gethash ident *cxobjects*)
(make-instance 'forward-cxobject-reference :ident ident)))))
(dolist (kind '(Unexposed Void Bool Char-U unsigned-Char
Char-16 Char-32 unsigned-Short unsigned-Int unsigned-Long
unsigned-Long-Long unsigned-Int-128 Char-S Signed-Char Wide-Char
Short Int Long Long-Long Int-128 c-Float Double Long-Double
Null-Pointer Overload Dependent ObjC-Id ObjC-Class ObjC-Selector
c-Complex Pointer Block-Pointer left-Value-Reference
right-Value-Reference Record Enum Typedef ObjC-Interface
ObjC-Object-Pointer Function-No-Proto Function-Proto
Constant-Array c-Vector invalid))
(eval `(defclass ,kind (cxtype)
()))
(setf (symbol-function kind)
(lambda (&rest arguments &key &allow-other-keys)
(apply (function make-instance) kind arguments))) )
(dolist (kind '(unexposed-decl struct-decl union-decl class-decl enum-decl field-decl
enum-constant-decl function-decl var-decl parm-decl
objc-interface-decl objc-category-decl objc-protocol-decl
objc-property-decl objc-ivar-decl objc-instance-method-decl
objc-class-method-decl objc-implementation-decl
objc-category-impl-decl typedef-decl cxx-method namespace
linkage-spec constructor destructor conversion-function
template-type-parameter non-type-template-parameter
template-template-parameter function-template class-template
class-template-partial-specialization namespace-alias using-directive
using-declaration type-alias-decl objc-synthesize-decl
objc-dynamic-decl cxx-access-specifier objc-super-class-ref
objc-protocol-ref objc-class-ref type-ref cxx-base-specifier
template-ref namespace-ref member-ref label-ref overloaded-decl-ref
variable-ref invalid-file no-decl-found not-implemented invalid-code
unexposed-expr decl-ref-expr member-ref-expr call-expr
objc-message-expr block-expr integer-literal floating-literal
imaginary-literal string-literal character-literal paren-expr
unary-operator array-subscript-expr binary-operator
compound-assign-operator conditional-operator cstyle-cast-expr
compound-literal-expr init-list-expr addr-label-expr stmt-expr
generic-selection-expr gnunull-expr cxx-static-cast-expr
cxx-dynamic-cast-expr cxx-reinterpret-cast-expr cxx-const-cast-expr
cxx-functional-cast-expr cxx-typeid-expr cxx-bool-literal-expr
cxx-null-ptr-literal-expr cxx-this-expr cxx-throw-expr cxx-new-expr
cxx-delete-expr unary-expr objc-string-literal objc-encode-expr
objc-selector-expr objc-protocol-expr objc-bridged-cast-expr
pack-expansion-expr size-of-pack-expr lambda-expr
objc-bool-literal-expr unexposed-stmt label-stmt compound-stmt
case-stmt default-stmt if-stmt switch-stmt while-stmt do-stmt
for-stmt goto-stmt indirect-goto-stmt continue-stmt break-stmt
return-stmt gccasm-stmt objc-at-try-stmt objc-at-catch-stmt
objc-at-finally-stmt objc-at-throw-stmt objc-at-synchronized-stmt
objc-autorelease-pool-stmt objc-for-collection-stmt cxx-catch-stmt
cxx-try-stmt cxx-for-range-stmt seh-try-stmt seh-except-stmt
seh-finally-stmt msasm-stmt null-stmt decl-stmt translation-unit
unexposed-attr ibaction-attr iboutlet-attr iboutlet-collection-attr
cxx-final-attr cxx-override-attr annotate-attr asm-label-attr
preprocessing-directive macro-definition macro-expansion
inclusion-directive module-import-decl invalid))
(eval `(defclass ,kind (cxcursor)
()))
(setf (symbol-function kind)
(lambda (&rest arguments &key &allow-other-keys)
(apply (function make-instance) kind arguments))))
(defun read-ast (ast)
(setf *cxobjects* (make-hash-table))
(let ((version (read ast))
(root (eval (read ast))))
(assert (eq 'clang-version (first version)))
(assert (string= "clang version 3.3" (second version) :end2 #.(length "clang version 3.3")))
(loop
:for sexp = (read ast nil ast)
:for i :from 0
:until (eq ast sexp)
:for ident = (first sexp)
:for form = (second sexp)
:do (setf (gethash ident *cxobjects*) (eval form))
:when (zerop (mod i 100))
:do (princ "." *trace-output*) (force-output *trace-output*)
:finally (terpri *trace-output*) (force-output *trace-output*))
(labels ((process (object)
(typecase object
(forward-cxobject-reference (resolve object))
(cons (mapcar (function process) object))
(t object))))
(maphash (lambda (ident cxobject)
(declare (ignore ident))
(when cxobject
(dolist (slot (slots cxobject))
(when (slot-boundp cxobject slot)
(setf (slot-value cxobject slot)
(process (slot-value cxobject slot)))))))
*cxobjects*))
(resolve root)))
(defun ast (&rest file-and-arguments)
(with-open-stream (ast (ccl:external-process-output-stream
(ccl:run-program
"/home/pjb/src/pjb/clang/ast"
file-and-arguments
:output :stream)))
(read-ast ast)))
(setf *print-circle* t)
;; (defparameter *ast* (ast "/home/pjb/src/pjb/clang/example.c"))
;; (defparameter *ast* (with-open-file (ast "/home/pjb/src/pjb/clang/example.ast") (read-ast ast)))
(defmethod find-cursors-spelled ((cursor cxcursor) name)
(nconc (if (string= name (cursor-spelling cursor))
(list cursor)
'())
(mapcan (lambda (child) (find-cursors-spelled child name))
(cursor-children cursor))))
(defparameter *ast*
(with-open-file (ast "/home/pjb/src/pjb/clang/example.ast")
(read-ast ast)))
(defmethod generate-code ((self cxtype))
(format nil "~A" self))
(defmethod generate-code :around ((self cxcursor))
(if (or (cursor-is-statement self)
(cursor-is-declaration self)
(cursor-is-unexposed self))
(format nil "~V<~>~A" *indent-level* (call-next-method))
(call-next-method)))
(defmethod generate-code ((self function-decl))
(format nil "~A ~A(~{~A~^;~})~{~A~}"
(generate-code (cursor-result-type self))
(cursor-spelling self)
(mapcar (function generate-code)
(cursor-arguments self))
(mapcar (function generate-code)
(cursor-children self))))
(defmethod generate-code ((self compound-stmt))
(format nil "{~{~%~A;~}}~%"
(let ((*indent-level* (+ *indent-level* *indentation*)))
(mapcar (function generate-code)
(cursor-children self)))))
(defmethod generate-code ((self decl-stmt))
(with-output-to-string (*standard-output*)
(dolist (child (cursor-children self))
(format t "~A" (generate-code child)))))
(defmethod generate-code ((self var-decl))
(format nil "~A ~A"
(generate-code (cursor-type self))
(cursor-spelling self)))
(defmethod generate-code ((self unexposed-expr))
(if (listp (cursor-children self))
(format nil "~{~A~}"
(mapcar (function generate-code)
(cursor-children self)))
(generate-code (cursor-children self))))
(defmethod generate-code ((self decl-ref-expr))
(cursor-spelling self))
(defmethod generate-code ((self string-literal))
(cursor-spelling self))
(defmethod generate-code ((self call-expr))
(format nil "~A(~{~A~^,~})"
(generate-code (first (cursor-children self)))
(generate-code (second (cursor-children self)))))
(defparameter *fun* (first (find-cursors-spelled *ast* "dump")))
(defmethod cursor-text ((self cxcursor))
(if (zerop (length (cursor-spelling self)))
(if (zerop (length (cursor-token-spelling self)))
nil
(cursor-token-spelling self))
(cursor-spelling self)))
(defgeneric flatten-unexposed-nodes (cursor)
(:method ((self t))
self)
(:method ((self cxcursor))
(if (and (cursor-is-unexposed self)
(= 1 (length (cursor-children self))))
(flatten-unexposed-nodes (first (cursor-children self)))
(let ((dst (make-instance (class-of self))))
(dolist (slot *cxcursor-slots* dst)
(setf (slot-value dst slot)
(if (eq slot 'children)
(mapcar (function flatten-unexposed-nodes)
(cursor-children self))
(slot-value self slot)))))))
;; (:method ((self unexposed-decl))
;; unexposed-decl
;; unexposed-expr
;; unexposed-stmt
;; unexposed-attr
;; )
)
(defmethod dump-nodes ((self cxcursor) &optional (level 0))
;; (format t "~%~V<~>(~A ~@[ s:~S~]~@[ t:~S~]"
;; level
;; (class-name (class-of self))
;; (cursor-spelling self)
;; (cursor-token-spelling self))
(format t "~%~V<~>(~A ~A"
level
(class-name (class-of self))
(cursor-text self))
(dolist (child (cursor-children self))
(dump-nodes child (+ 2 level)))
(format t ")")
(values))
#||
(defparameter *fun* (first (find-cursors-spelled *ast* "dump")))
(map nil 'print (find-cursors-spelled *ast* "dump"))
(to-sexp(first (find-cursors-spelled *ast* "dump")))
(to-sexp (cursor-result-type *fun*))
(generate-code *fun*)
"void dump(){
int i;
printf( #<string-literal \"\" example.c:13:12: #x3020020C2FAD>);
#<for-stmt \"\" example.c:14:5: #x302001FEEABD>;
printf( #<string-literal \"\" example.c:19:12: #x302001F3295D>);
#<for-stmt \"\" example.c:20:5: #x302001F9E5AD>;
printf( #<string-literal \"\" example.c:22:12: #x302001FEA4FD>);}
"
(to-sexp (first (cursor-children (first (cursor-children (first (cursor-children *fun*)))))))
(to-sexp)
(to-sexp (first(cursor-children (first (cursor-children(second (cursor-children (second (cursor-children (first (cursor-children *fun*)))))))))))
(string-literal :is-declaration nil :is-reference nil :is-expression t :is-statement nil :is-attribute nil :is-invalid nil :is-translation-unit nil :is-preprocessing nil :is-unexposed nil :linkage :invalid :platform-availability nil :language :invalid :translation-unit #<translation-unit "example.c" nil:0:0: #x30200200E9AD> :semantic-parent nil :lexical-parent nil :included-file nil :location #2=#1=example.c:13:12: :range #<range (:start #1#:13:12: :end #1#:13:36:) #x3020020C310D> :type #<constant-array #x302002157F6D> :underlying-type nil :enum-type nil :enum-constant nil :unsigned-enum-constant nil :arguments nil :overloaded-declarations nil :access-specifier nil :virtual-base nil :is-definition nil :definition nil :canonical #<string-literal #3="" #2# #x3020020C2FAD> :children nil :bit-field-width nil :spelling #3# :usr #3# :referenced nil :objc-type-encoding nil :result-type nil)
||#
(cursor-children (dump-nodes (flatten-unexposed-nodes *fun*)))
(to-sexp (first (cursor-children (third (cursor-children (first (cursor-children (flatten-unexposed-nodes *fun*))))))))
(binary-operator :is-declaration nil :is-reference nil :is-expression t :is-statement nil :is-attribute nil :is-invalid nil :is-translation-unit nil :is-preprocessing nil :is-unexposed nil :linkage nil :platform-availability nil :language nil :translation-unit #<translation-unit "example.c" nil #x302001DB343D> :semantic-parent nil :lexical-parent nil :included-file nil :location nil :range nil :type #<int #x302001D6E76D> :underlying-type nil :enum-type nil :enum-constant nil :unsigned-enum-constant nil :arguments nil :overloaded-declarations nil :access-specifier nil :virtual-base nil :is-definition nil :definition nil :canonical #<binary-operator #1="" nil #x302001E61EBD> :children (#<decl-ref-expr "i" nil #x3020030BD8AD> #<integer-literal "" nil #x3020030BD72D>) :bit-field-width nil :spelling #1# :usr #1# :referenced nil :objc-type-encoding nil :result-type nil :token-kind nil :token-spelling nil :token nil)
(function-decl dump
(compound-stmt nil
(decl-stmt nil
(var-decl i))
(call-expr printf
(decl-ref-expr printf)
(string-literal "--------------------\n"))
(for-stmt nil
(binary-operator nil
(decl-ref-expr i)
(integer-literal 0))
(binary-operator nil
(decl-ref-expr i)
(decl-ref-expr top))
(unary-operator nil
(decl-ref-expr i))
(compound-stmt nil
(if-stmt nil
(binary-operator nil
(member-ref-expr type
(array-subscript-expr nil
(decl-ref-expr stack)
(decl-ref-expr i)))
(integer-literal 0))
(compound-stmt nil
(call-expr printf
(decl-ref-expr printf)
(string-literal "[%3d]: %10d\n")
(decl-ref-expr i)
(member-ref-expr valeur
(array-subscript-expr nil
(decl-ref-expr stack)
(decl-ref-expr i)))))
(compound-stmt nil
(call-expr printf
(decl-ref-expr printf)
(string-literal "[%3d]: %c\n")
(decl-ref-expr i)
(binary-operator nil
(character-literal 'a')
(member-ref-expr valeur
(array-subscript-expr nil
(decl-ref-expr stack)
(decl-ref-expr i)))))))))
(call-expr printf
(decl-ref-expr printf)
(string-literal "--------------------\n"))
(for-stmt nil
(binary-operator nil
(decl-ref-expr i)
(integer-literal 0))
(binary-operator nil
(decl-ref-expr i)
(binary-operator nil
(paren-expr nil
(decl-ref-expr memoire))
(unexposed-expr nil)))
(unary-operator nil
(decl-ref-expr i))
(compound-stmt nil
(call-expr printf
(decl-ref-expr printf)
(string-literal "[%3c]: %10d\n")
(binary-operator nil
(character-literal 'a')
(decl-ref-expr i))
(array-subscript-expr nil
(decl-ref-expr memoire)
(decl-ref-expr i)))))
(call-expr printf
(decl-ref-expr printf)
(string-literal "--------------------\n"))))