Added ast.lisp side.

Pascal J. Bourguignon [2013-02-03 23:48]
Added ast.lisp side.
Filename
ast.lisp
diff --git a/ast.lisp b/ast.lisp
new file mode 100644
index 0000000..d82f72e
--- /dev/null
+++ b/ast.lisp
@@ -0,0 +1,496 @@
+;;;; -*- 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 *location-slots* '(file line column offset))
+
+(defclass location ()
+  #.(slot-specifiers *location-slots* 'location-))
+
+(defmethod slots ((self location))
+  *location-slots*)
+
+(defmethod to-sexp ((self location))
+  (slots-to-sexp *location-slots* self))
+
+(defmethod print-object ((self location) stream)
+  (format stream "~A:~A:~A:"
+          (location-file self)
+          (location-line self)
+          (location-column self))
+  self)
+
+
+
+(defparameter *range-slots* '(start end))
+
+(defclass range ()
+  #.(slot-specifiers *range-slots* 'range-))
+
+(defmethod slots ((self range))
+  *range-slots*)
+
+(defmethod to-sexp ((self range))
+  (slots-to-sexp *range-slots* self))
+
+(defmethod print-object ((self range) 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 range location))
+  (setf (symbol-function kind)
+        (lambda (&rest arguments &key &allow-other-keys)
+          (apply (function make-instance) kind arguments))))
+
+
+
+
+
+(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))
+
+(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))
+
+
+(defun cxcursor (ident)
+  (or (gethash ident *cxobjects*)
+      (make-instance 'forward-cxobject-reference :ident ident)))
+
+(defun cxtype (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 ((root      (eval (read ast))))
+    (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))
+                 (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)))
+
+(map nil 'print (find-cursors-spelled *ast* "dump"))
+
+
+(to-sexp(first  (find-cursors-spelled *ast* "dump")))
+
+(function-decl
+ :is-declaration t
+ :is-reference nil
+ :is-expression nil
+ :is-statement nil
+ :is-attribute nil
+ :is-invalid nil
+ :is-translation-unit nil
+ :is-preprocessing nil
+ :is-unexposed nil
+ :linkage
+ :external
+ :platform-availability nil
+ :language :c
+ :translation-unit #1=#<translation-unit "example.c" nil:0:0: #x30200200E9AD>
+ :semantic-parent #1#
+ :lexical-parent #1#
+ :included-file nil
+ :location #2=example.c:11:6:
+ :range #<range #x3020020C2A1D>
+ :type #<function-proto #x302001F62E6D>
+ :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 t
+ :definition #3=#<function-decl #4="dump" #2# #x3020020C28BD>
+ :canonical #3#
+ :children (#<compound-stmt "" example.c:11:16: #x302001F8C0AD>)
+ :bit-field-width nil
+ :spelling #4#
+ :usr "c:@F@dump"
+ :referenced #3#
+ :objc-type-encoding "v0"
+ :result-type #<void #x3020020E3DFD>)
+
+(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))
+  (format nil "~{~A~}"
+          (mapcar (function 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")))
+
+(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)
ViewGit