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/clos.lisp 2014-10-30 08:12:31.000000000 +0100

+++ new-smoke/src/clos.lisp 2014-10-30 08:12:31.000000000 +0100

@@ -19,8 +19,8 @@

,documentation

(declare (simple-string input)

(optimize (speed 3)))

- ;; At least on sbcl 1.0.25.debian CONCATENATE is faster

- ;; than VECTOR-PUSH-EXTEND

+ ;; At least on sbcl 1.0.25.debian CONCATENATE is faster than

+ ;; VECTOR-PUSH-EXTEND.

(let ((,output "")

(,index 0)

(,length (length input))

@@ -121,10 +121,10 @@

(:documentation "Metaclass to extend Smoke Objects."))

(defmethod closer-mop:validate-superclass ((class smoke-standard-class) (superclass standard-class))

- T)

+ t)

(defmethod closer-mop:validate-superclass ((class cxx:class) (superclass smoke-standard-class))

- T)

+ t)

(defmethod reinitialize-instance :around

((class smoke-standard-class)

@@ -245,7 +245,7 @@

(list ,@(rest lambda-list))))))))

(defcallback destructed :void

- ((object-pointer :pointer))

+ ((object-pointer :pointer))

(declare (optimize (speed 3)))

(let ((object (get-object object-pointer)))

(when object

@@ -267,8 +267,8 @@

(foreign-type-size 'smoke-stack-item))

(next arg)

(push (argument-to-lisp (mem-ref stack

- 'smoke-stack-item)

- arg)

+ 'smoke-stack-item)

+ arg)

args))))

(defun convert-argument (argument type &optional (user t))

@@ -286,9 +286,10 @@

(let ((stack (make-call-stack stack)))

(setf (call-stack-top stack) (call-stack-pointer stack))

;; FIXME support user conversions.

+ ;;

;; We need to determine which of value and converted-value is

- ;; passed on the stack. E.g. converted-value can be something like

- ;; (cxx:operator-variant value).

+ ;; passed on the stack. E.g. converted-value can be something

+ ;; like (cxx:operator-variant value).

(let ((converted-value (convert-argument value type nil)))

(push-smoke-stack stack converted-value (type-id type))

(when (stack-p type) ;; Pass by value => smoke deletes the object.

@@ -314,10 +315,11 @@

;; (object)

;; "No object for ~A to call ~A." object-ptr method)

(if (and object (typep (class-of object) 'cxx:class))

- ;; Do not allow overwriting methods of classes the users has not derived from (like in C++),

- ;; to reduce overhead.

+ ;; Do not allow overwriting methods of classes the users has

+ ;; not derived from (like in C++), to reduce overhead.

(let* ((method (make-smoke-method

- :smoke (gethash (pointer-address (smoke-get-smoke binding))

+ :smoke (gethash (pointer-address

+ (smoke-get-smoke binding))

*smoke-modules*)

:id method)))

(loop

@@ -409,25 +411,38 @@

(defmethod convert-to-class (smoke-class (object smoke-standard-object))

(cast object smoke-class))

+(defun constructor-name (class)

+ (let ((name-start (search "::" (name class) :from-end t)))

+ (if name-start

+ (subseq (name class) (+ name-start 2))

+ (name class))))

+

(defun call-constructor (object arguments)

(if (null arguments)

(let ((method (find-smoke-method (class-of object)

- (name (class-of object)))))

+ (constructor-name (class-of object)))))

+ (assert (valid-p method)

+ (method)

+ "No constructor for ~A." object)

(pointer-call method (null-pointer)))

(multiple-value-bind (method sequence)

- (find-best-viable-function (name (class-of object))

+ (find-best-viable-function (constructor-name (class-of object))

arguments

(class-of object))

(when (null method)

- (error "No constructor ~A for ~S"

- object arguments))

+ (error "No constructor for object ~A with

+the arguments ~S." object arguments))

(pointer-call method (null-pointer)

(mapcar #'(lambda (conversion argument)

(funcall conversion argument))

sequence arguments)))))

(defmethod initialize-instance :after ((object smoke-standard-object)

- &key args &allow-other-keys)

+ &key args

+ (arg0 nil arg0p)

+ (arg1 nil arg1p)

+ (arg2 nil arg2p)

+ &allow-other-keys)

"Initializes a Smoke object. Calls its constructor with the arguments supplied

by the key :ARGS and sets the smoke binding."

(declare (optimize (speed 3)))

@@ -437,7 +452,14 @@

"Pointer ~A bound and constructor argument :ARGS ~S supplied."

(slot-value object 'pointer) args)

(unless (slot-boundp object 'pointer)

- (setf (slot-value object 'pointer) (call-constructor object args))

+ (if arg0p

+ (setf (slot-value object 'pointer)

+ (call-constructor object

+ (cond

+ (arg2p (list arg0 arg1 arg2))

+ (arg1p (list arg0 arg1))

+ (t (list arg0)))))

+ (setf (slot-value object 'pointer) (call-constructor object args)))

(set-binding object)

(take-ownership object)

(add-object object)))