Mon May 11 13:09:54 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* cleanup variant

--- old-qt.gui/src/variant.lisp 2014-10-30 07:44:05.000000000 +0100

+++ new-qt.gui/src/variant.lisp 2014-10-30 07:44:05.000000000 +0100

@@ -1,8 +1,5 @@

(in-package :qt)

-(defgeneric make-variant (value)

- (:documentation "Returns a variant for VALUE."))

-

(defmethod print-object ((variant variant) stream)

"Print the type and value of the variant."

(if (null-pointer-p (pointer variant))

@@ -13,13 +10,51 @@

(handler-case (from-variant variant)

(error () nil))))))

-(defmethod make-variant (value)

- "Returns a new VARIANT containing a C++ version of VALUE."

- (make-instance 'variant :args (list value)))

+(defun make-variant (&optional (value nil value-p))

+ "Returns a new VARIANT containing a C++ version of VALUE

+or an empty variant when VALUE is not specified."

+ (if value-p

+ (make-instance 'variant :args (list value))

+ (make-instance 'variant)))

+

+(defun make-char (character)

+ (let ((octets (babel:string-to-octets (string character))))

+ (case (length octets)

+ (1 (make-instance 'char :args (list (aref octets 0))))

+ (2 (make-instance 'char :args (list (aref octets 0)

+ (aref octets 1))))

+ (t (error "qt:char requires the character ~A to be encoded

+in one or two octets, but it is using ~A."

+ character (length octets))))))

+

+(defun surrogate-p (char)

+ (or (cxx:is-high-surrogate char)

+ (cxx:is-low-surrogate char)))

+

+(defun from-char (char)

+ "Returns the lisp character represented by CHAR."

+ (assert (not (surrogate-p char))

+ (char)

+ "The char ~A is part of a surrogate.")

+ (char

+ (babel:octets-to-string (make-array 2 :element-type '(unsigned-byte 8)

+ :initial-contents

+ (list

+ (char-code (cxx:cell char))

+ (char-code (cxx:row char)))))

+ 0))

+

+(defmethod print-object ((char char) stream)

+ (if (or (null-pointer-p (pointer char))

+ (surrogate-p char))

+ (call-next-method)

+ (print-unreadable-object (char stream :type t)

+ (princ (from-char char) stream))))

+

;; FIXME include in MAKE-VARIANT?

(defun make-lisp-variant (value)

- "Returns a new VARIANT that wrapps VALUE."

+ "Returns a new VARIANT that wraps VALUE."

(let ((object (make-cxx-lisp-object value)))

(unwind-protect

(make-instance 'variant :args (list *cxx-lisp-object-metatype*

@@ -33,14 +68,12 @@

"Returns true when VARIANT is valid (has a value) and false otherwise."

(cxx:is-valid variant))

-;;FIXME define setf-able value function

-

(defun from-variant (variant)

"Returns the value of VARIANT."

(ecase (cxx:user-type variant)

(#.(value variant.+invalid+)

- (cerror "Return NIL" "Type of variant ~A is invalid." variant)

- nil)

+ (cerror "Return (VALUES)" "Type of variant ~A is invalid." variant)

+ (values))

(#.(value variant.+string+)

(cxx:to-string variant))

(#.(value variant.+string-list+)

@@ -51,9 +84,20 @@

(cxx:to-int variant))

(#.(value variant.+double+)

(cxx:to-double variant))

+ (#.(value variant.+char+)

+ (cxx:to-char variant))

+ (#.(value variant.+bool+)

+ (cxx:to-bool variant))

(#.*cxx-lisp-object-metatype*

(let* ((lisp-object (qt-smoke-lisp-object-value (smoke::pointer variant)))

(value))

(setf value (translate-cxx-lisp-object lisp-object))

(free-cxx-lisp-object lisp-object)

value))))

+

+(defmethod value ((variant variant))

+ "Returns the value of VARIANT."

+ (from-variant variant))

+

+(defmethod (setf value) (new-value (variant variant))

+ (cxx:operator= variant (make-variant new-value)))