Tue May 26 11:54:47 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Cleanup Lisp -> C++ conversion
hunk ./src/clos.lisp 3
-(declaim (optimize (speed 0) (debug 3)))
-
hunk ./src/clos.lisp 275
-(defgeneric set-returnvalue (stack value type))
-(defmethod set-returnvalue (stack (value smoke-standard-object) type)
- (assert (class-p type)
- (type)
- "The type ~A of the value ~A is not a class."
- (name type) value)
- (setf (foreign-slot-value stack 'smoke-stack-item 'class)
- (cast value (find-smoke-class (get-class type))))
- ;(pointer value))
- (when (stack-p type) ;; Pass by value => smoke deletes the object.
- (cancel-finalization value) [_$_]
- (unless (virtual-destructor-p (class-of value))
- (remove-object (pointer value))))) ;; Fixme mark object as invalid or copy it
-
-
-(defmethod set-returnvalue (stack (value integer) type)
- (setf (foreign-slot-value stack 'smoke-stack-item 'int)
- value))
-
-(defmethod set-returnvalue (stack (value (eql t)) type)
- (setf (foreign-slot-value stack 'smoke-stack-item 'bool)
- value))
+(defun convert-argument (argument type &optional (user t))
+ (let ((rank (get-conversion-sequence argument type user)))
+ (if (null rank)
+ (error "Can not convert the argument ~S to ~A."
+ argument (name type))
+ (funcall (conversion-function-name rank)
+ argument))))
hunk ./src/clos.lisp 285
- (set-returnvalue stack value type)))
+ (let ((stack (make-call-stack stack)))
+ (setf (top 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).
+ (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.
+ (cancel-finalization converted-value) [_$_]
+ (when (and (class-p type)
+ (not (virtual-destructor-p (get-class type))))
+ (if (pointerp converted-value)
+ (remove-object converted-value)
+ (progn
+ (cancel-finalization value)
+ (remove-object (pointer value))))))))))
hunk ./src/clos.lisp 309
- ((binding :pointer)
- (method smoke-index)
- (object :pointer)
- (stack smoke-stack)
- (abstract :boolean))
+ ((binding :pointer)
+ (method smoke-index)
+ (object :pointer)
+ (stack smoke-stack)
+ (abstract :boolean))
hunk ./src/clos.lisp 327
- (put-returnvalue stack
- (apply gf object
- (stack-to-args (cffi:inc-pointer stack (cffi:foreign-type-size 'smoke-stack-item))
- (get-first-argument method)))
- (return-type method))
+ (put-returnvalue
+ stack
+ (apply gf object
+ (stack-to-args
+ (cffi:inc-pointer stack [_$_]
+ (cffi:foreign-type-size
+ 'smoke-stack-item))
+ (get-first-argument method)))
+ (return-type method))
hunk ./src/objects/class.lisp 19
-(defmethod get-struct-slot-value ((class smoke-class) slot-name)
+(declaim (inline class-slot-value))
+(defun class-slot-value (class slot-name)
hunk ./src/objects/class.lisp 25
- (get-struct-slot-value class 'name))
+ (class-slot-value class 'name))
hunk ./src/objects/class.lisp 41
- (get-struct-slot-value class 'external))
+ (class-slot-value class 'external))
hunk ./src/objects/class.lisp 44
- (boole boole-and (get-struct-slot-value class 'flags)
+ (boole boole-and (class-slot-value class 'flags)
hunk ./src/objects/class.lisp 109
- (smoke-add-superclass class nil (get-struct-slot-value class 'parents)))
+ (smoke-add-superclass class nil (class-slot-value class 'parents)))
hunk ./src/objects/enum.lisp 13
+ :type (integer 0)
hunk ./src/objects/method.lisp 2
-(declaim (optimize (debug 3)))
hunk ./src/objects/method.lisp 92
+(declaim (inline method-slot-value))
hunk ./src/objects/object.lisp 5
+ :type smoke-index
hunk ./src/objects/object.lisp 8
+ :type foreign-pointer
hunk ./src/objects/stack.lisp 3
-(declaim (optimize (debug 3)))
hunk ./src/objects/stack.lisp 6
+ :type foreign-pointer
hunk ./src/objects/stack.lisp 10
- :documentation "Pointer to push the next argument to.")
- (cleanup-stack :accessor cleanup-stack
- :initform nil
- :documentation "Cleanup functions"))
+ :type foreign-pointer
+ :documentation "Pointer to push the next argument to."))
hunk ./src/objects/stack.lisp 31
-(defun push-cleanup (stack function)
- "Adds the cleanup function FUNCTION to STACK"
- (push function (cleanup-stack stack)))
-
-(defun push-stack2 (stack value type-id)
+(defun push-smoke-stack (stack value type-id)
hunk ./src/objects/stack.lisp 46
- (13 (push-stack stack value 'class))))
-
-(defun push-smoke-stack (stack lisp-value smoke-type)
- (typecase smoke-type
- (smoke-type
- (cond
- ((cffi:pointerp lisp-value)
- (push-stack2 stack lisp-value (type-id smoke-type)))
- ((class-p smoke-type)
- (push-stack2 stack
- (convert-to-class (get-class smoke-type) lisp-value)
- (type-id smoke-type)))
-; ((pointer-p smoke-type)
- (t
- (let ((cffi-type (get-type (name smoke-type))))
- (if (null cffi-type)
- (progn
- ; (assert (typep lisp-value 'foreign-pointer)
- ; (lisp-value)
- ; "The lisp-value ~S is not a foreign-pointer."
- ; lisp-value)
- (push-stack2 stack
- lisp-value
- (type-id smoke-type)))
- (multiple-value-bind (pointer args) (convert-to-foreign lisp-value
- cffi-type)
- (push-cleanup stack
- #'(lambda ()
- (free-converted-object pointer
- cffi-type
- args)))
- (push-stack2 stack
- pointer
- (type-id smoke-type))))))))
-; (t (push-stack2 stack lisp-value (type-id smoke-type)))))
- (t (push-lisp-object stack lisp-value smoke-type))))
-
-(defgeneric push-lisp-object (stack object class)
- (:documentation "Push the OBJECT on STACK."))
+ (13 (if (typep value 'smoke-standard-object)
+ ;; FIXME call pointer in overload resolution
+ (push-stack stack (pointer value) 'class)
+ (push-stack stack value 'class)))))
hunk ./src/objects/stack.lisp 61
- (push-smoke-stack stack (first args) (first arguments))
- (set-smoke-stack stack (rest args) (rest arguments))))
+ (if (typep (first arguments) 'smoke-type)
+ (push-smoke-stack stack (first args) (type-id (first arguments)))
+ (push-stack stack (first args) 'class)) ;; Used for :qt lisp-object
+ (set-smoke-stack stack (rest args) (rest arguments))))
hunk ./src/objects/stack.lisp 70
- (unwind-protect
- (progn
hunk ./src/objects/stack.lisp 72
- ,@body)
- (mapcar #'funcall (cleanup-stack ,stack)))))))
+ ,@body))))
hunk ./src/objects/stack.lisp 137
-
- [_$_]
hunk ./src/objects/type.lisp 16
+(declaim (inline type-slot-value))
hunk ./src/objects/type.lisp 76
- (null (name type)))
+ ;; void is an empty string.
+ ;; For efficency 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)))
+ (= 0 (mem-ref (smoke-get-type (smoke type) (id type))
+ :char)))
+ [_$_]
hunk ./src/overload-resolution.lisp 5
-(declaim (optimize (debug 3)))
hunk ./src/overload-resolution.lisp 124
+ :type fixnum
hunk ./src/overload-resolution.lisp 130
+ :type fixnum
hunk ./src/overload-resolution.lisp 136
+ :type fixnum
hunk ./src/overload-resolution.lisp 142
+ :type fixnum
hunk ./src/overload-resolution.lisp 152
+ :type fixnum
hunk ./src/overload-resolution.lisp 158
+ :type fixnum
hunk ./src/overload-resolution.lisp 334
- (13 (and (object.typep (find-class 'smoke-standard-object))
- (smoke-type= type (object.type-of))))))
+ (13 (and (object.typep 'smoke-standard-object)
+ (smoke-type= (get-class type) (object.type-of))))))
hunk ./src/overload-resolution.lisp 339
- "Returns a pointer that calls CLEANUP-FUNCTION when it is finalized."
+ "Returns a pointer that calls CLEANUP-FUNCTION with pointer as argument
+when it is finalized."
hunk ./src/overload-resolution.lisp 348
- (let ((address (pointer-address pointer)))
- (tg:finalize pointer #'(lambda ()
- (foreign-free (make-pointer address))))))
+ (make-cleanup-pointer pointer #'foreign-free))
hunk ./src/overload-resolution.lisp 367
+(declaim (inline coerce-to-class))
hunk ./src/overload-resolution.lisp 435
+(declaim (inline coerce-to-class))
hunk ./src/overload-resolution.lisp 462
+ (declare (optimize (speed 3)))