;;;; -*- 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"))))