(in-package #:smoke)

(defclass smoke-class ()
  ((id :initform 0 :type smoke-index
       :reader id :initarg :id)
   (smoke :type smoke-module
          :reader smoke :initarg :smoke)))

(defun make-smoke-class-from-id (smoke id)
  (make-instance 'smoke-class :id id :smoke smoke))

(declaim (inline smoke-class-pointer))
(defun smoke-class-pointer (class)
  (mem-aref (the foreign-pointer
              (smoke-array-pointer (smoke-module-classes (smoke class))))
            'smoke-class
            (the smoke-index (id class))))

(declaim (inline class-slot-value))
(defun class-slot-value (class slot-name)
  (foreign-slot-value (smoke-class-pointer class)
                      'smoke-class slot-name))

(define-compiler-macro class-slot-value (&whole form class slot-name)
  (if (constantp slot-name)
      `(foreign-slot-value (smoke-class-pointer ,class)
                           'smoke-class ,slot-name)
      form))

(defmethod name ((class smoke-class))
  (class-slot-value class 'name))

(defun name-pointer (class)
  (mem-ref (foreign-slot-pointer (smoke-class-pointer class)
                                 'smoke-class 'name)
           :pointer))

(defun class-size (smoke-class)
  (class-slot-value smoke-class 'size))

(defun map-classes (function smoke)
  "Applies FUNCTION to the classes of SMOKE."
  (declare (function function)
           (optimize (speed 3)))
  (let ((class (make-instance 'smoke-class
                              :smoke smoke)))
    (loop for id from 1 to (smoke-array-length (smoke-module-classes smoke)) do
         (setf (slot-value class 'id)
               id)
         (funcall function class))))

(defun external-p (class)
  "Returns T when CLASS is external in its module; NIL otherwise."
  (declare (type smoke-class class)
           (optimize (speed 3)))
  (class-slot-value class 'external))

(defun get-class-flag (class flag)
  (declare (optimize (speed 3)))
  (logand (class-slot-value class 'flags)
          (the fixnum (foreign-enum-value 'smoke-class-flags flag))))

(defmethod constructor-p ((class smoke-class))
  "Returns T when CLASS has a constructor; NIL otherwise."
  (/= 0 (get-class-flag class :constructor)))

(defun copy-constructor-p (class)
  (/= 0 (get-class-flag class :copy-constructor)))

(defun virtual-destructor-p (class)
  "Returns T when CLASS has a virtual destructor and NIL otherwise."
  (/= 0 (get-class-flag class :virtual-destructor)))

(define-condition undefined-class (cell-error)
  ()
  (:report (lambda (condition stream)
             (format stream "No Smoke class named ~S."
                     (cell-error-name condition))))
  (:documentation "A undefined Smoke class"))

(define-condition lisp-module-not-loaded (error)
  ((class-name :initarg :class-name))
  (:report (lambda (condition stream)
             (format stream "The Lisp smoke module of the class ~A is not loaded."
                     (slot-value condition 'class-name)))))

(defun make-smoke-class (name)
  "Returns the class named NAME.
Signals an undefined-class condition when there is no class for NAME."
  (with-foreign-object (c 'smoke-module-index)
    (do () (nil)
      (smoke-find-class c name)
      (restart-case
          (if (null-pointer-p (foreign-slot-value c 'smoke-module-index 'smoke))
              (error (make-condition 'undefined-class :name name))
              (return))
        (supply (new-name)
          :report "Supply a new class name"
          :interactive read-new-value
          (setf name new-name))))
    (let ((class (make-instance
                  'smoke-class
                  :id (foreign-slot-value c 'smoke-module-index 'index)
                  :smoke (gethash (pointer-address (foreign-slot-value
                                                    c 'smoke-module-index
                                                    'smoke))
                                  *smoke-modules*))))
      (unless (smoke class)
        (error (make-condition 'lisp-module-not-loaded :class-name name)))
      class)))

(defun real-class (class)
  "Returns the same class like CLASS, but such that EXTERNAL-P returns NIL."
  (if (external-p class)
      (make-smoke-class (name class))
      class))

(defun class-id (module class)
  "Returns the class id of CLASS for the Smoke module MODULE."
  (if (eq (smoke class) module)
      (id class)
      (smoke-class-id module (name class))))

(defun derived-p (class base-class)
  "Returns T when CLASS is derived from BASE-CLASS and NIL when not."
  (handler-case (derived-real-p (real-class class) (real-class base-class))
    ;; The class is external in every module => no derived.
    (undefined-class () nil)))

(defun derived-real-p (class base-class)
  (smoke-is-derived-from (smoke-module-pointer (smoke class)) 
                         (id class)
                         (smoke-module-pointer (smoke base-class))
                         (id base-class)))
  

(defun smoke-class-direct-superclasses (class)
  (smoke-add-superclass class nil (class-slot-value class 'parents)))

(defun smoke-add-superclass (class classes index)
  (let ((class-index (mem-aref (smoke-module-inheritance-list 
                                (smoke class))
                               'smoke-index
                               index)))
    (assert (<= class-index (smoke-array-length
                             (smoke-module-classes (smoke class)))))
    (if (= 0 class-index)
        classes
        (smoke-add-superclass
         class
         (append classes
                 (list (make-smoke-class-from-id (smoke class) class-index)))
         (1+ index)))))