;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;FILE:               ast.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;    Reads the AST dumped by ast.c.
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;    2013-01-29 <PJB> Created.
;;;;    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
;;;;    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)
   "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
                                    (concatenate 'string (symbol-name prefix)
                                                 (symbol-name slot))
                                    (symbol-package prefix))

(defun slots-to-sexp (slots object)
  `(,(class-name (class-of object))
     ,@(mapcan (lambda (slot)
                 (list (intern (symbol-name slot) "KEYWORD")
                       (slot-value object slot)))

(defparameter *platform-availability-slots*
  '(platform introduced deprecated obsoleted unavailable message))

(defclass platform-availability ()
  #.(slot-specifiers *platform-availability-slots* 'platform-))

(defmethod slots ((self platform-availability))

(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

(defclass availability ()
  #.(slot-specifiers *availability-slots* 'availability-))

(defmethod slots ((self availability))

(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))

(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))

(defparameter *range-slots* '(start end))

(defclass range ()
  #.(slot-specifiers *range-slots* 'range-))

(defmethod slots ((self range))

(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))))

(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

(defclass cxtype ()
  #.(slot-specifiers *cxtype-slots* 'type-))

(defmethod slots ((self cxtype))

(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

(defclass cxcursor ()
  #.(slot-specifiers *cxcursor-slots* 'cursor-))

(defmethod slots ((self cxcursor))

(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)))

(defclass forward-cxobject-reference ()
  ((ident :initarg :ident :accessor ident)))

(defmethod resolve ((reference forward-cxobject-reference))
  (or (gethash (ident reference) *cxobjects*)

(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))))
      :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))))))
    (resolve root)))

(defun ast (&rest file-and-arguments)
  (with-open-stream (ast (ccl:external-process-output-stream
                           :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")))

 :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
 :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))

(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 (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)