Tue May 26 11:54:47 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Cleanup Lisp -> C++ conversion

--- old-smoke/src/clos.lisp 2014-09-30 10:28:59.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-30 10:28:59.000000000 +0200

@@ -1,7 +1,5 @@

(in-package #:smoke)

-(declaim (optimize (speed 0) (debug 3)))

-

(declaim (inline lispify))

(defun lispify (name &optional (package nil))

"Returns the interned symbol for name in Lisp style."

@@ -274,32 +272,33 @@

(type-to-lisp (cffi:mem-ref stack 'smoke-stack-item)

arg))))))

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

(defun put-returnvalue (stack value type)

(unless (void-p type)

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

(defun get-gf-for-method (smoke-method)

(declare (smoke-method smoke-method)

@@ -307,11 +306,11 @@

(symbol-function (lispify (name smoke-method) "CXX")))

(defcallback dispatch-method :boolean

- ((binding :pointer)

- (method smoke-index)

- (object :pointer)

- (stack smoke-stack)

- (abstract :boolean))

+ ((binding :pointer)

+ (method smoke-index)

+ (object :pointer)

+ (stack smoke-stack)

+ (abstract :boolean))

(declare (optimize (speed 3)))

(let ((method (make-instance 'smoke-method

:id method

@@ -325,11 +324,15 @@

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

(if object

(progn

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

t)

nil))))))

--- old-smoke/src/objects/class.lisp 2014-09-30 10:28:59.000000000 +0200

+++ new-smoke/src/objects/class.lisp 2014-09-30 10:28:59.000000000 +0200

@@ -16,12 +16,13 @@

()

(:documentation "A class"))

-(defmethod get-struct-slot-value ((class smoke-class) slot-name)

+(declaim (inline class-slot-value))

+(defun class-slot-value (class slot-name)

(foreign-slot-value (smoke-get-class (smoke class) (id class))

'smoke-class slot-name))

(defmethod name ((class smoke-class))

- (get-struct-slot-value class 'name))

+ (class-slot-value class 'name))

(defun map-classes (function smoke)

"Applys FUNCTION to the classes of SMOKE."

@@ -37,10 +38,10 @@

(defun external-p (class)

"Returns T when CLASS is external in its module; NIL otherwise."

- (get-struct-slot-value class 'external))

+ (class-slot-value class 'external))

(defmethod get-flag ((class smoke-class) flag)

- (boole boole-and (get-struct-slot-value class 'flags)

+ (boole boole-and (class-slot-value class 'flags)

(foreign-enum-value 'smoke-class-flags flag)))

(defmethod constructor-p ((class smoke-class))

@@ -105,7 +106,7 @@

(defun smoke-class-direct-superclasses (class)

- (smoke-add-superclass class nil (get-struct-slot-value class 'parents)))

+ (smoke-add-superclass class nil (class-slot-value class 'parents)))

(defun smoke-add-superclass (class classes index)

(let ((class-index (smoke-get-parent-index (smoke class) index)))

--- old-smoke/src/objects/enum.lisp 2014-09-30 10:28:59.000000000 +0200

+++ new-smoke/src/objects/enum.lisp 2014-09-30 10:28:59.000000000 +0200

@@ -10,6 +10,7 @@

(defclass enum ()

((value :reader value

+ :type (integer 0)

:initarg :value)

(type :reader enum-type

:initarg :type))

--- old-smoke/src/objects/method.lisp 2014-09-30 10:28:59.000000000 +0200

+++ new-smoke/src/objects/method.lisp 2014-09-30 10:28:59.000000000 +0200

@@ -1,5 +1,4 @@

(in-package #:smoke)

-(declaim (optimize (debug 3)))

(defclass smoke-method (smoke-symbol)

()

@@ -90,6 +89,7 @@

(setf (slot-value method 'id) id)

(funcall function method))))

+(declaim (inline method-slot-value))

(defun method-slot-value (method slot-name)

(declare (smoke-method method)

(symbol slot-name)

--- old-smoke/src/objects/object.lisp 2014-09-30 10:28:59.000000000 +0200

+++ new-smoke/src/objects/object.lisp 2014-09-30 10:28:59.000000000 +0200

@@ -2,8 +2,10 @@

(defclass smoke-symbol ()

((id :reader id :initarg :id

+ :type smoke-index

:documentation "The objects index.")

(smoke :reader smoke :initarg :smoke

+ :type foreign-pointer

:initform (null-pointer)

:documentation "Pointer to the Smoke module."))

(:documentation "A method or class in a Smoke module."))

--- old-smoke/src/objects/stack.lisp 2014-09-30 10:28:59.000000000 +0200

+++ new-smoke/src/objects/stack.lisp 2014-09-30 10:28:59.000000000 +0200

@@ -1,16 +1,14 @@

(in-package #:smoke)

-(declaim (optimize (debug 3)))

(defclass call-stack ()

((pointer :reader pointer :initarg :pointer

:initform (null-pointer)

+ :type foreign-pointer

:documentation "Pointer to the Smoke stack")

(top :accessor top :initarg :top

:initform (null-pointer)

- :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."))

(:documentation "Contains the argument passed to a Smoke method."))

(defmethod size ((stack call-stack))

@@ -30,11 +28,7 @@

'smoke-stack-item type) value)

(incf-pointer (top stack) (foreign-type-size 'smoke-stack-item)))

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

(ecase type-id

(0 (push-stack stack value 'voidp))

(1 (push-stack stack value 'bool))

@@ -49,45 +43,10 @@

(10 (push-stack stack value 'float))

(11 (push-stack stack value 'double))

(12 (push-stack stack (value value) 'enum-value))

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

(defun set-smoke-stack (stack args arguments)

"Pushes the arguments ARGS onto the Smoke stack STACK."

@@ -99,19 +58,18 @@

(assert (not (null arguments))

()

"To many arguments suppliend (Arguments ~A)." args)

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

(defmacro with-stack ((stack args types) &body body)

(let ((smoke-stack (gensym "STACK")))

`(with-foreign-object (,smoke-stack 'smoke-stack-item (1+ (length ,args)))

(let ((,stack (make-call-stack ,smoke-stack)))

- (unwind-protect

- (progn

(set-smoke-stack ,stack ,args

,types)

- ,@body)

- (mapcar #'funcall (cleanup-stack ,stack)))))))

+ ,@body))))

(defun enum-to-lisp (stack-item type)

"Returns the Lisp representation for STACK-ITEM of the basic C type TYPE."

@@ -176,5 +134,3 @@

(class-to-lisp stack-item type))

(t

(enum-to-lisp stack-item type))))

-

-

--- old-smoke/src/objects/type.lisp 2014-09-30 10:28:59.000000000 +0200

+++ new-smoke/src/objects/type.lisp 2014-09-30 10:28:59.000000000 +0200

@@ -13,6 +13,7 @@

(defmethod smoke::smoke ((type smoke-lazy-type))

(eval (smoke-symbol type)))

+(declaim (inline type-slot-value))

(defun type-slot-value (type slot-name)

(declare (smoke-type type)

(symbol slot-name)

@@ -72,7 +73,13 @@

(defun void-p (type)

"Return T when TYPE is a void type (no value)."

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

+

(defgeneric get-class (smoke-symbol)

(:documentation "Returns the smoke-class associated with SMOKE-SYMBOL."))

--- old-smoke/src/overload-resolution.lisp 2014-09-30 10:28:59.000000000 +0200

+++ new-smoke/src/overload-resolution.lisp 2014-09-30 10:28:59.000000000 +0200

@@ -2,7 +2,6 @@

;;; See: http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2008/n2800.pdf

(in-package :smoke)

-(declaim (optimize (debug 3)))

(defun mung-char-p (character)

"Returns true when CHARACTER is used for munging and false otherwise."

@@ -122,21 +121,25 @@

(defclass exact-match (std-conversion)

((rank :reader rank

:allocation :class

+ :type fixnum

:initform +exact-match+)))

(defclass promotion (std-conversion)

((rank :reader rank

:allocation :class

+ :type fixnum

:initform +promotion+)))

(defclass number-conversion (std-conversion)

((rank :reader rank

:allocation :class

+ :type fixnum

:initform +conversion+)))

(defclass pointer-conversion (std-conversion)

((rank :reader rank

:allocation :class

+ :type fixnum

:initform (1+ +conversion+))

(from :reader from

:initarg :from)

@@ -146,11 +149,13 @@

(defclass boolean-conversion (std-conversion)

((rank :reader rank

:allocation :class

+ :type fixnum

:initform (+ 2 +conversion+))))

(defclass user-conversion (std-conversion)

((rank :reader rank

:allocation :class

+ :type fixnum

:initform (+ 3 +conversion+))))

(defgeneric conversion< (conversion1 conversion2)

@@ -326,12 +331,13 @@

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

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

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

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

(defun make-cleanup-pointer (pointer cleanup-function)

- "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."

(let ((address (pointer-address pointer)))

(tg:finalize pointer #'(lambda ()

(funcall cleanup-function

@@ -339,9 +345,7 @@

(defun make-auto-pointer (pointer)

"Returns a pointer that frees the memory at POINTER when it is finalized."

- (let ((address (pointer-address pointer)))

- (tg:finalize pointer #'(lambda ()

- (foreign-free (make-pointer address))))))

+ (make-cleanup-pointer pointer #'foreign-free))

(defun coerce-c-string (string)

(make-auto-pointer (foreign-string-alloc string)))

@@ -360,6 +364,7 @@

(7 (when (object.typep 'enum)

(make-match 'promotion 'coerce-enum)))))

+(declaim (inline coerce-to-class))

(defun coerce-cast (object to-class)

(cast object to-class))

@@ -427,6 +432,7 @@

(make-match 'user-conversion

(lispify (name method) :cxx))))))

+(declaim (inline coerce-to-class))

(defun coerce-to-class (object to-class)

(make-instance to-class

:args (list object)))

@@ -453,6 +459,7 @@

sequence args)))

(defun call-using-args (object-or-class name arguments)

+ (declare (optimize (speed 3)))

(if (null arguments)

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

name)))