(in-package #:smoke) (declaim (inline make-smoke-method)) (defstruct smoke-method (id 0 :type smoke-index) (smoke (make-smoke-module) :type smoke-module)) (declaim (inline smoke-method-pointer)) (defun smoke-method-pointer (method) (declare (optimize (speed 3))) (mem-aref (smoke-array-pointer (smoke-module-methods (smoke-method-smoke method))) 'smoke-method (smoke-method-id method))) (defmethod print-object ((smoke-method smoke-method) stream) (if (or (null-pointer-p (smoke-module-pointer (smoke-method-smoke smoke-method))) (null-pointer-p (smoke-method-pointer smoke-method))) (print-unreadable-object (smoke-method stream :type t) (princ "no method" stream)) (print-unreadable-object (smoke-method stream :type t) (princ (method-declaration smoke-method) stream)))) (defmethod smoke ((method smoke-method)) (smoke-module-pointer (smoke-method-smoke method))) (defmethod id ((method smoke-method)) (declare (optimize (speed 3))) (smoke-method-id method)) (define-condition undefined-method (undefined-function) ((class-name :initarg :class-name :initform nil)) (:report (lambda (condition stream) (format stream "No Smoke method ~S for class ~S." (cell-error-name condition) (slot-value condition 'class-name)))) (:documentation "A undefined Smoke method")) (defun find-smoke-method (class name) "Returns the method NAME of CLASS." (with-foreign-object (m 'smoke-module-index) (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name) (let ((smoke (foreign-slot-value m 'smoke-module-index 'smoke))) (make-smoke-method :smoke (if (null-pointer-p smoke) (make-smoke-module) (gethash (pointer-address smoke) *smoke-modules*)) :id (foreign-slot-value m 'smoke-module-index 'index))))) (declaim (inline smoke-method-name)) (defun smoke-method-name (method) (mem-aref (smoke-array-pointer (smoke-module-method-names (smoke-method-smoke method))) :pointer (the (smoke-index 0) (method-slot-value method 'name)))) ;smoke-find-method (defun make-smoke-method-from-name (class name) "Returns the method NAME of CLASS. Signals a undefined-method condition when no method was found. Signals an error when the method is ambiguous." (with-foreign-object (m 'smoke-module-index) (do () (nil) (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name) (restart-case (if (null-pointer-p (foreign-slot-value m 'smoke-module-index 'smoke)) (error (make-condition 'undefined-method :name name :class-name (name class))) (return)) (supply (new-name) :report "Supply a new method name" :interactive read-new-value (setf name new-name)))) (when (> 0 (foreign-slot-value m 'smoke-module-index 'index)) (loop as i = (mem-aref (smoke-module-ambiguous-method-list (smoke class)) 'smoke-index (- (foreign-slot-value m 'smoke-module-index 'index))) while (> i 0) do (decf (foreign-slot-value m 'smoke-module-index 'index)) (let ((m (make-smoke-method :smoke (smoke class) :id i))) (format t " ~A ~A~%" (name m) (signature m)))) (error "The method ~S of ~S is ambiguous" name (name class))) ;;TODO (make-smoke-method :smoke (gethash (pointer-address (foreign-slot-value m 'smoke-module-index 'smoke)) *smoke-modules*) :id (foreign-slot-value m 'smoke-module-index 'index)))) (defun map-methods (function smoke) "Applies FUNCTION to the methods of SMOKE. The method argument to function must not be modified." (declare (function function) (optimize (speed 3))) (let ((method (make-smoke-method :smoke smoke :id 0)) (length (smoke-array-length (smoke-module-methods smoke)))) (loop for id from 0 below length do ;; exception: methods is < lenght (setf (smoke-method-id method) id) (funcall function method)))) (declaim (inline method-slot-value)) (defun method-slot-value (method slot-name) (declare (smoke-method method) (symbol slot-name) (optimize (speed 3))) (foreign-slot-value (smoke-method-pointer method) 'smoke-method slot-name)) (define-compiler-macro method-slot-value (&whole form method slot-name) "Optimize constant slot-names." ;; declaring the function inline calls the compiler macro of ;; foreign-slot-value with 'SLOT-NAME instead of its value an thus ;; has no effect; thus the compiler macro. (if (constantp slot-name) `(foreign-slot-value (smoke-method-pointer ,method) 'smoke-method ,slot-name) form)) (defmethod name ((method smoke-method)) (mem-aref (smoke-array-pointer (smoke-module-method-names (smoke-method-smoke method))) :string (method-slot-value method 'name))) (defun signature (method) "Returns the signature of METHOD." (format nil "~A(~{~A~^, ~}) ~:[~;const~]" (name method) (mapcar #'name (arguments method)) (const-p method))) (defun access (method) "Returns the access for METHOD. (public or protected)" (if (protected-p method) "protected" "public")) (defun modifiers (method) (format nil "~:[~;virtual ~]~A~:[~; static~]" (virtual-p method) (access method) (static-p method))) (defun return-type (method) "Returns the return type of METHOD." (declare (optimize (speed 3))) (make-instance 'smoke-type :id (method-slot-value method 'return-type) :smoke (smoke-method-smoke method))) (defun method-declaration (method) (format nil "~A~:[ void~; ~1:*~A~] ~A::~A" (modifiers method) (name (return-type method)) (name (get-class method)) (signature method))) (defun get-method-flag (method flag) (logand (method-slot-value method 'flags) (foreign-enum-value 'smoke-method-flags flag))) (define-compiler-macro get-method-flag (&whole form method flag) (if (constantp flag) `(logand (method-slot-value ,method 'flags) ;; Resolve flag value at compile time ,(foreign-enum-value 'smoke-method-flags flag)) form)) (defgeneric constructor-p (object) (:documentation "Returns T when OBJECT is a constructor.")) (defmethod constructor-p ((method smoke-method)) (/= 0 (get-method-flag method :constructor))) (defun destructor-p (method) "Returns T when METHOD is a destructor; NIL otherwise." (/= 0 (get-method-flag method :destructor))) (defun static-p (method) "Returns T when METHOD is static and NIL otherwise." (/= 0 (get-method-flag method :static))) (defun protected-p (method) "Returns T when METHOD is protected; NIL otherwise." (/= 0 (get-method-flag method :protected))) (defun attribute-p (method) "Returns T when METHOD accesses C++ member/static variables." (/= 0 (get-method-flag method :attribute))) (defun property-p (method) "Returns T when METHOD accesses a Q_PROPERTY." (/= 0 (get-method-flag method :property))) (defmethod const-p ((method smoke-method)) "Returns T when METHOD is a const method and NIL otherwise." (/= 0 (get-method-flag method :const))) (defun valid-p (method) "Returns T when METHOD is valid and NIL otherwise." (/= 0 (smoke-method-id method))) (defun ambigious-p (method) "Returns T when METHOD is ambiguous and NIL otherwise." (< 0 (smoke-method-id method))) (defun enum-p (method) "Returns T when METHOD is enum value and NIL otherwise." (/= 0 (get-method-flag method :enum))) (defun internal-p (method) "Returns T when METHOD is internal and NIL otherwise." (/= 0 (get-method-flag method :internal))) (defun virtual-p (method) "Returns T when METHOD is internal and NIL otherwise." (/= 0 (get-method-flag method :virtual))) (defmethod get-class ((method smoke-method)) (make-smoke-class-from-id (smoke-method-smoke method) (method-slot-value method 'class))) (defclass smoke-argument (smoke-type) () (:documentation "A argument to a method")) (defmethod id ((argument smoke-argument)) (declare (optimize (speed 3))) (mem-aref (smoke-module-argument-list (smoke argument)) 'smoke-index (the smoke-index (call-next-method)))) (defun last-p (argument) "Returns T when ARGUMENT is the last argument and NIL otherwise." (= 0 (mem-aref (smoke-module-argument-list (smoke argument)) 'smoke-index (1+ (slot-value argument 'id))))) (defun end-p (argument) "Returns T when ARGUMENT is the after last element and NIL otherwise." (= 0 (id argument))) (defun next (argument) "Returns the argument following ARGUMENT." (assert (not (end-p argument)) (argument) "Access after end element") (make-instance 'smoke-argument :id (1+ (slot-value argument 'id)) :smoke (smoke argument))) (defun get-arguments-length (method) "Returns the number of arguments for METHOD." (method-slot-value method 'num-args)) (defun get-first-argument (method) "Returns the first argument of METHOD" (declare (optimize (speed 3))) (make-instance 'smoke-argument :id (method-slot-value method 'arguments) :smoke (smoke-method-smoke method))) (defun get-argument (method index) "Returns the type of METHODs argument with number INDEX." (make-instance 'smoke-argument :id (+ (method-slot-value method 'arguments) index) :smoke (smoke-method-smoke method))) (defun build-argument-list (list argument) (if (end-p argument) list (build-argument-list (append list (list argument)) (next argument)))) (defun arguments (method) "Returns a list of the arguments of METHOD." (build-argument-list nil (get-first-argument method)))