Thu Jul 23 00:26:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Use strcmp, fix constructor & destrucor calling for classes witn namespace (phonon::MediaPlayer) and add :arg0 to :arg2 initargs

--- old-smoke/src/overload-resolution.lisp 2014-10-30 08:12:42.000000000 +0100

+++ new-smoke/src/overload-resolution.lisp 2014-10-30 08:12:42.000000000 +0100

@@ -3,80 +3,33 @@

(in-package :smoke)

-(defun cstring= (string1 string2)

- "Returns T when the C strings STRING1 and STRING2 are equal

- and NIL otherwise."

- (declare (optimize (speed 3) (safety 0)))

- (dotimes (i array-total-size-limit)

- (let ((char1 (mem-aref string1 :char i))

- (char2 (mem-aref string2 :char i)))

- (when (/= char1 char2)

- (return-from cstring= nil))

- (when (or (= 0 char1)

- (= 0 char2))

- (return-from cstring= (= char1 char2))))))

-

(declaim (inline cmp))

(defun cmp (a b)

- "Returns -1 if a < b; 0 if a = b and 1 if a > b"

- (declare (values (integer -1 1)))

- (if (< a b)

- -1

- (if (> a b)

- 1

- 0)))

-

-(declaim (inline cstring-cmp))

-(defun cstring-cmp (string1 string2)

- "Compares the C strings STRING1 and STRING2."

- (declare (foreign-pointer string1 string2)

- (values (integer -1 1))

- (optimize (speed 3)))

- (dotimes (i array-total-size-limit (error "omg"))

- (let ((char1 (mem-aref string1 :char i))

- (char2 (mem-aref string2 :char i)))

- (when (/= char1 char2)

- (return-from cstring-cmp (if (< char1 char2) -1 1)))

- (when (= 0 char1) ;; <=> (= 0 char2)

- (return-from cstring-cmp 0)))))

+ (- a b))

+(declaim (inline strcmp))

+(defcfun strcmp :int (s1 :pointer) (s2 :pointer))

+

+(declaim (inline cstring/=))

(defun cstring/= (string1 string2)

"Returns T when the C strings STRING1 and STRING2 are not equal

and NIL otherwise."

- (declare (optimize (speed 3)))

- (dotimes (i array-total-size-limit)

- (let ((char1 (mem-aref string1 :char i))

- (char2 (mem-aref string2 :char i)))

- (when (/= char1 char2)

- (return-from cstring/= i))

- (when (= 0 char1)

- (return-from cstring/= nil)))))

-

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

+ (not (zerop (strcmp string1 string2))))

(defun method-cmp (method class-id name)

"Compares METHOD to the method with NAME of class CLASS-ID."

(declare (foreign-pointer name)

(type (smoke-index 0) class-id)

(smoke-method method)

- (values (integer -1 1))

(optimize (speed 3) (debug 0) (safety 0)))

(let ((id-cmp (cmp (the (smoke-index 0) (method-slot-value method 'class))

(the (smoke-index 0) class-id))))

- (declare (type (integer -1 1) id-cmp)

- (dynamic-extent id-cmp))

+ (declare (type smoke-index id-cmp))

(if (/= 0 id-cmp)

id-cmp

- (cstring-cmp (smoke-method-name method)

+ (strcmp (smoke-method-name method)

name))))

-;;; INLINE OPTIMIZE

(declaim (inline first-unabigious-index))

(defun first-unabigious-index (smoke index)

(declare (type smoke-index index)

@@ -112,13 +65,14 @@

'smoke-method-map index)

'smoke-method-map

'method)))))

- (cmp (the (integer -1 1) (method-cmp method class-id name))))

- (declare (type (integer -1 1) cmp)

+ (cmp (the smoke-index (method-cmp method class-id name))))

+ (declare (type smoke-index cmp)

(dynamic-extent method))

- (ecase cmp

- (-1 (setf start (1+ index)))

- (0 (return-from find-method-for-class index))

- (1 (setf end (1- index)))))))

+ (if (< cmp 0)

+ (setf start (1+ index))

+ (if (> cmp 0)

+ (setf end (1- index))

+ (return-from find-method-for-class index))))))

-1)

(defmacro push-candidate-method (index name argument-count class methods)

@@ -128,7 +82,7 @@

(smoke-array-pointer

(smoke-module-method-maps ,smoke))

'smoke-method-map

- ,index))

+ (the smoke-index ,index)))

(,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method))

(,method (make-smoke-method

:smoke ,smoke

@@ -169,30 +123,27 @@

(defun viable-functions (name argument-count class)

"Returns a list of methods named NAME that take ARGUMENT-COUNT methods."

;; 13.3.2

+ ;;

;; FIXME make a lazy map-viable-functions to allow returning early,

;; when an exact match is found.

(declare (optimize (speed 3)))

(with-foreign-string (name name)

- (let ((methods)

- (smoke (smoke class)))

+ (let ((methods))

(dolist (class (all-smoke-superclasses class))

- (let ((start-index (find-method-for-class name class)))

- (declare (type smoke-index start-index))

- (loop for index from start-index downto 1

- while (push-candidate-method index name argument-count class

- methods))

- (loop for index from (1+ start-index)

- to (the smoke-index (smoke-array-length

- (smoke-module-method-maps smoke)))

- while (push-candidate-method index name argument-count class

- methods))))

+ (let ((smoke (smoke class)))

+ (let ((start-index (find-method-for-class name class)))

+ (declare (type smoke-index start-index))

+ (when (>= start-index 0)

+ (loop for index from start-index downto 1

+ while (push-candidate-method index name argument-count class

+ methods))

+ (loop for index from (1+ start-index)

+ to (the smoke-index (smoke-array-length

+ (smoke-module-method-maps smoke)))

+ while (push-candidate-method index name argument-count class

+ methods))))))

methods)))

-(eval-when (:compile-toplevel :load-toplevel :execute)

-(defconstant +exact-match+ 0)

-(defconstant +promotion+ 1)

-(defconstant +conversion+ 2))

-

(declaim (inline make-conversion make-exact-match make-promotion

make-number-conversion make-pointer-conversion

make-boolean-conversion make-user-conversion))

@@ -200,19 +151,19 @@

(function-name nil :type (or symbol function) :read-only t)

(rank -1 :type fixnum :read-only t))

-(defstruct (exact-match (:include conversion (rank +exact-match+))))

+(defstruct (exact-match (:include conversion (rank 0))))

-(defstruct (promotion (:include conversion (rank +promotion+))))

+(defstruct (promotion (:include conversion (rank 1))))

-(defstruct (number-conversion (:include conversion (rank +conversion+))))

+(defstruct (number-conversion (:include conversion (rank 2))))

-(defstruct (pointer-conversion (:include conversion (rank (1+ +conversion+))))

+(defstruct (pointer-conversion (:include conversion (rank 3)))

(from (find-class t) :type class :read-only t)

(to (find-class t) :type class :read-only t))

-(defstruct (boolean-conversion (:include conversion (rank (+ 2 +conversion+)))))

+(defstruct (boolean-conversion (:include conversion (rank 4))))

-(defstruct (user-conversion (:include conversion (rank (+ 3 +conversion+)))))

+(defstruct (user-conversion (:include conversion (rank 5))))

(defgeneric conversion< (conversion1 conversion2)

(:documentation

@@ -245,10 +196,7 @@

(:method (conversion1 conversion2)

(= (conversion-rank conversion1) (conversion-rank conversion2)))

(:method ((conversion1 (eql nil)) (conversion2 (eql nil)))

- t)

- (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))

- (and (not (conversion< conversion1 conversion2))

- (not (conversion< conversion2 conversion1)))))

+ t))

(defun max-conversion (conversion1 conversion2)

"Returns the greater conversion of CONVERSION1 and CONVERSION2."

@@ -375,6 +323,8 @@

(5 (object.typep '(c-integer :unsigned-short)))

(6 (object.typep '(c-integer :int)))

(7 (object.typep '(c-integer :unsigned-int)))

+ (8 (object.typep '(c-integer :long)))

+ (9 (object.typep '(c-integer :unsigned-long)))

(10 (object.typep 'single-float))

(11 (object.typep 'double-float))

(12 (object.typep 'enum)) ;; FIXME enum-type

@@ -444,15 +394,16 @@

:to (find-class 't))))

(defun+using-type conversion-pointer object (object type)

- ;; Not using pointer-p to allow passing a raw pointer for

- ;; objects on the stack and references

+ ;; Not using pointer-p to allow passing a raw pointer for objects on

+ ;; the stack and references.

;; (e.g.: for qInstallMsgHandler(QtMsgHandler) )

;;

- ;; FIXME this breaks passing pointers to references

- ;; e.g.: calling the function foo(QByteArray& foo)

- ;; with (foo pointer) assumes pointer to point to a QByteArray,

- ;; but actually the conversion sequence QByteArray(pointer) should be used.

- ;; When pointer is a null pointer it fails horribly!.

+ ;; FIXME this breaks passing pointers to references.

+ ;;

+ ;; e.g.: calling the function foo(QByteArray& foo) with

+ ;; (foo pointer) assumes pointer to point to a QByteArray, but

+ ;; actually the conversion sequence QByteArray(pointer) should be

+ ;; used. When pointer is a null pointer it fails horribly!.

(when (and (or (= 0 (type-id type)) ; voidp

(= 13 (type-id type))) ; class

(object.typep 'foreign-pointer))

@@ -497,7 +448,7 @@

(if (using-typep)

#'standard-conversion-sequence-using-types

#'standard-conversion-sequence)

- (format nil "~A" (name (get-class type)))

+ (constructor-name (get-class type))

(list object) to-class)

(make-match 'user-conversion

'coerce-to-class