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