Sun Aug 2 12:12:41 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Cleanup C++ to Lisp translation

--- old-smoke/src/objects/stack.lisp 2014-10-30 08:12:02.000000000 +0100

+++ new-smoke/src/objects/stack.lisp 2014-10-30 08:12:02.000000000 +0100

@@ -17,19 +17,19 @@

(optimize (speed 3)))

(%make-call-stack

:pointer smoke-stack

- :top (inc-pointer smoke-stack

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

+ :top (inc-pointer smoke-stack #.(foreign-type-size 'smoke-stack-item))))

(defun push-stack (stack value type)

- (setf (foreign-slot-value (call-stack-top stack)

- 'smoke-stack-item type) value)

+ (setf (foreign-slot-value (call-stack-top stack) 'smoke-stack-item type)

+ value)

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

(define-compiler-macro push-stack (&whole form stack value type)

(if (constantp type)

`(progn

(setf (foreign-slot-value (call-stack-top ,stack)

- 'smoke-stack-item ,type) ,value)

+ 'smoke-stack-item ,type)

+ ,value)

(incf-pointer (call-stack-top ,stack)

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

form))

@@ -100,22 +100,13 @@

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

(declare (optimize (speed 3)))

(ecase (type-id type)

- (0 (let ((cffi-type (get-type (name type))))

- (if (null cffi-type)

- (progn

- ;; FIXME warn but not on void**

- ;;(warn "Unknown translation from ~A to lisp." (name type))

- (foreign-slot-value stack-item 'smoke-stack-item 'voidp))

- (let* ((pointer (foreign-slot-value stack-item

- 'smoke-stack-item

- 'voidp))

- (value (convert-from-foreign pointer cffi-type)))

- (when (stack-p type)

- ;; FIXME free-translated-object is not intended for this;

- ;; param is NIL for now.

- (cffi:free-translated-object pointer cffi-type nil))

- value

- ))))

+ (0 (if-let ((translation (gethash (name type) *to-lisp-translations*)))

+ (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item

+ 'voidp)))

+ (prog1 (funcall (car translation) pointer)

+ (when (stack-p type)

+ (funcall (cdr translation) pointer))))

+ (error "Do not know how to convert the type ~A to Lisp." type)))

(1 (foreign-slot-value stack-item 'smoke-stack-item 'bool))

(2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char)))

(3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar)))

@@ -128,7 +119,8 @@

(10 (foreign-slot-value stack-item 'smoke-stack-item 'float))

(11 (foreign-slot-value stack-item 'smoke-stack-item 'double))

(12 (make-instance 'enum

- :value (foreign-slot-value stack-item 'smoke-stack-item 'enum-value)

+ :value (foreign-slot-value stack-item 'smoke-stack-item

+ 'enum-value)

:type type))))

(defgeneric instance-to-lisp (pointer class type)

@@ -137,19 +129,24 @@

(defun object-to-lisp (object type)

(declare (optimize (speed 3)))

- (if (class-p type)

- (let ((class (get-class type)))

- (if (has-pointer-p object)

+ (let ((class (get-class type)))

+ (if (has-pointer-p object)

+ (if (derived-p (class-of (get-object object))

+ (get-class type))

(get-object object)

- (instance-to-lisp object (find-smoke-class class) type)))

- nil))

+ (progn

+ (cerror "Remove the old object."

+ "The object at pointer ~A is ~A but should be a ~A."

+ object (get-object object) type)

+ (remove-object object)

+ (instance-to-lisp object (find-smoke-class class) type)))

+ (instance-to-lisp object (find-smoke-class class) type))))

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

"Returns the Lisp representation for STACK-ITEM of type C++ class."

- (object-to-lisp (foreign-slot-value stack-item

- 'smoke-stack-item

+ (object-to-lisp (foreign-slot-value stack-item 'smoke-stack-item

'class)

type))

@@ -157,9 +154,30 @@

"Returns the Lisp representation of STACK-ITEM"

(declare (optimize (speed 3)))

(cond

- ((void-p type)

- (values))

- ((class-p type)

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

- (t

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

+ ((void-p type) (values))

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

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

+

+(defvar *to-lisp-translations* (make-hash-table :test 'equal))

+

+(defun error-no-free (object)

+ (error "Can not free object at ~A." object))

+

+(defmacro define-to-lisp-translation (type-names &optional

+ (conversion-function-name 'identity)

+ (free-function-name 'error-no-free))

+ `(progn ,@(loop for type-name in (ensure-list type-names)

+ collect `(setf (gethash ,type-name *to-lisp-translations*)

+ (cons ',conversion-function-name

+ ',free-function-name)))))

+

+(defmacro define-pointer-typedef (type-names lisp-type)

+ (declare (ignore lisp-type))

+ `(progn

+ (define-to-lisp-translation ,type-names identity identity)))

+ ;; not needed

+ ;;(define-from-lisp-translation ,type-names ,lisp-type)))

+

+(define-to-lisp-translation ("void*" "const void*" "void**"))

+

+(define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp)