(in-package #:smoke)

(declaim (inline smoke))

(defclass smoke-type ()
  ((id :reader id :initarg :id
       :type smoke-index
       :documentation "The objects index.")
   (smoke :reader smoke :initarg :smoke
          :type smoke-module
          :documentation "Pointer to the Smoke module."))
  (:documentation "A type"))

(defmethod print-object ((type smoke-type) stream)
  (if (or (<= (id type) 0)
          (null-pointer-p (smoke-module-pointer (smoke type))))
      (call-next-method)
      (print-unreadable-object (type stream :type t)
        (princ (name type) stream))))

;; Clozure CL needs this
(defmethod make-load-form ((type smoke-type) &optional environment)
  (declare (ignore environment))
  `(make-instance 'smoke-type
                  :id ,(id type)
                  :smoke (eval ,(get-smoke-variable-for-pointer
                                 (smoke-module-pointer (smoke type))))))

(declaim (inline type-slot-value))
(defun type-slot-value (type slot-name)
  (declare (smoke-type type)
           (symbol slot-name)
           (optimize (speed 3)))
  (foreign-slot-value (mem-aref (smoke-array-pointer
                                 (smoke-module-types (smoke type)))
                                'smoke-type
                                (the smoke-index (id type)))
                      'smoke-type slot-name))

(define-compiler-macro type-slot-value (&whole form type slot-name)
  (if (constantp slot-name)
      `(foreign-slot-value (mem-aref (smoke-array-pointer
                                      (smoke-module-types (smoke ,type)))
                                     'smoke-type
                                     (the smoke-index (id ,type)))
                           'smoke-type ,slot-name)
      form))
  

(defun make-smoke-type (smoke name)
  "Returns the type in the Smoke module SMOKE named NAME."
  (make-instance 'smoke-type
                 :id (smoke-find-type (smoke-module-pointer smoke) name)
                 :smoke smoke))

(defmethod name ((type smoke-type))
  (declare (optimize (speed 3)))
  (type-slot-value type 'name))

(defun smoke-type= (type1 type2)
  (if (eq (smoke type1) (smoke type2))
      (= (id type1) (id type2))
      (string= (name type1) (name type2))))

(defun get-type-flag (type flag)
  (declare (optimize (speed 3)))
  (logand (type-slot-value type 'flags)
          #xF0 ;; = !0x0F
          (the fixnum (foreign-enum-value 'smoke-type-flags flag))))

(define-compiler-macro get-type-flag (&whole form type flag)
  (if (constantp flag)
      `(logand (type-slot-value ,type 'flags)
               #xF0
               ,(foreign-enum-value 'smoke-type-flags flag))
      form))
      
(defmacro allocation-flag-p (type flag)
  ;; Can't just use #'get-type-flag since it can only be one of
  ;; :stack, :reference and :pointer.
  ;; (:stack + :pointer = :reference) <=> (#x10 + #x20 = #x30)
  `(= ,(foreign-enum-value 'smoke-type-flags flag)
      (logand #x30
              (type-slot-value ,type 'flags))))

(declaim (inline stack-p))
(defun stack-p (type)
  "Returns T when TYPE is stored on the stack; NIL otherwise."
  (allocation-flag-p type :stack))

(defun reference-p (type)
  "Returns T when TYPE is a reference ('type&'); NIL otherwise."
  (allocation-flag-p type :reference))

(defun pointer-p (type)
  "Returns T when TYPE is a pointer ('type*'); NIL otherwise."
  (allocation-flag-p type :pointer))

(defgeneric const-p (object)
  (:method ((type smoke-type))
    "Returns T when TYPE is const; NIL otherwise."
    (/= 0 (get-type-flag type :const))))

(defun class-p (type)
  "Returns T when TYPE is a smoke class"
  (and (eql (type-id type) 13)
       (not (zerop (type-slot-value type 'class)))))

(defun type-id (type)
  "Returns the ID of TYPE."
  (declare (smoke-type type)
           (optimize (speed 3) (safety 0)))
  (logand (the (c-integer :unsigned-short) (type-slot-value type 'flags))
          #.(foreign-enum-value 'smoke-type-flags :type-id)))

(defun void-p (type)
  "Return T when TYPE is a void type (no value)."
  ;; void is an empty string.
  ;; For efficiency just check if the first byte is a null byte;
  ;; No need to convert the entire C string to lisp like in:
  ;;  (null (name type)))
  (declare (optimize (speed 3)))
  (null-pointer-p (mem-ref
                   (foreign-slot-pointer 
                    (mem-aref (smoke-array-pointer
                               (smoke-module-types (smoke type)))
                              'smoke-type
                              (the smoke-index (id type)))
                    'smoke-type 'name)
                   :pointer)))
              

(defgeneric get-class (smoke-symbol)
  (:documentation "Returns the smoke-class associated with SMOKE-SYMBOL."))

(defmethod get-class ((type smoke-type))
  "Return the smoke-class of TYPE."
  (assert (class-p type)
          (type)
          "The type ~S is not a smoke class." type)
  (make-smoke-class-from-id (smoke type) (type-slot-value type 'class)))

;; Return the cffi keyword for the type
(defun type-foreign-keyword (smoke-type)
  (intern (nsubstitute #\- #\  (nstring-upcase (name smoke-type)))
          :keyword))

(defun type-size (smoke-type)
  (if (class-p smoke-type)
      (class-size (get-class smoke-type))
      (foreign-type-size (type-foreign-keyword smoke-type))))