Thu Jul 2 22:48:38 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* #_ reader macro enum calls & cleanup

--- old-commonqt/src/commonqt.lisp 2014-10-30 06:54:33.000000000 +0100

+++ new-commonqt/src/commonqt.lisp 2014-10-30 06:54:33.000000000 +0100

@@ -18,10 +18,21 @@

:args args))

(let ((object (read stream)))

(if (stringp object)

- `(lambda (&rest args)

- (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))

- (find-class ',(smoke::lispify object :cl-smoke.qt))

- args))

+ (if (upper-case-p (char (symbol-name method) 0))

+ `(lambda ()

+ ,(smoke::lispify

+ (concatenate 'string

+ (if (string= "Qt" object)

+ "+"

+ (concatenate 'string

+ object

+ ".+"))

+ (symbol-name method) "+")

+ :cl-smoke.qt))

+ `(lambda (&rest args)

+ (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))

+ (find-class ',(smoke::lispify object :cl-smoke.qt))

+ args)))

`(lambda (&rest args)

(apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))

,object

@@ -91,6 +102,9 @@

(method-functions :documentation "The signals and slots.")

(meta-object)))

+(defclass signal-slot-mixin ()

+ ())

+

(defun setup-meta-object (class qt-superclass)

(let ((methods (make-array (+ (length (slot-value class 'signals))

(length (slot-value class 'qt-slots)))

@@ -98,10 +112,10 @@

:initial-element #'identity))

(index 0))

(dolist (signal-name (slot-value class 'signals))

- (incf index)

(setf (aref methods index)

#'(lambda (this &rest args)

- (apply #'emit-signal this signal-name args))))

+ (apply #'emit-signal this signal-name args)))

+ (incf index))

(dolist (slot (slot-value class 'qt-slots))

(setf (aref methods index)

(if (symbolp (second slot))

@@ -138,42 +152,41 @@

(cons `(:pointer (null-pointer) ,#'null-pointer)

direct-default-initargs)

:direct-superclasses

- (list (find-qclass (first qt-superclass)))

+ (list (find-qclass (first qt-superclass))

+ (find-class 'signal-slot-mixin))

args)

(setup-meta-object qt-class (find-qclass (first qt-superclass))))

+(defmethod cxx:meta-object ((this signal-slot-mixin))

+ (slot-value (class-of this) 'meta-object))

+

+(defmethod cxx:qt-metacall ((this signal-slot-mixin) call id arguments)

+ (let ((m-id (call-next-method)))

+ (if (< m-id 0)

+ m-id

+ (if (enum= call cl-smoke.qt:meta-object.+invoke-meta-method+)

+ (progn

+ (when (< m-id (length (slot-value (class-of this)

+ 'method-functions)))

+ (with-simple-restart

+ (continue "Skip the method ~A of ~A."

+ (cxx:signature

+ (cxx:method (cxx:meta-object this) id))

+ this)

+ (apply (aref (slot-value (class-of this) 'method-functions)

+ m-id)

+ this

+ (cl-smoke.qt-impl::arguments-to-lisp

+ arguments

+ (cl-smoke.qt-impl::method-arguments-type

+ (cxx:meta-object this) id)))))

+ (- m-id

+ (length (slot-value (class-of this) 'method-functions))))

+ m-id))))

+

(defmethod initialize-instance :around ((class qt-class)

&rest args)

- (apply #'setup-qt-class class #'call-next-method args)

- (closer-mop:ensure-method #'cxx:meta-object

- '(lambda (this)

- (slot-value (class-of this) 'meta-object))

- :specializers (list class))

- (closer-mop:ensure-method

- #'cxx:qt-metacall

- '(lambda (this call id arguments)

- (let ((m-id (call-next-method)))

- (if (< m-id 0)

- m-id

- (if (enum= call cl-smoke.qt:meta-object.+invoke-meta-method+)

- (progn

- (when (< m-id (length (slot-value (class-of this)

- 'method-functions)))

- (with-simple-restart

- (continue "Skip the method ~A of ~A."

- id

- this)

- (apply (aref (slot-value (class-of this) 'method-functions)

- m-id)

- this

- (cl-smoke.qt-impl::arguments-to-lisp

- arguments

- (cl-smoke.qt-impl::method-arguments-type

- (cxx:meta-object this) id)))))

- (- m-id

- (length (slot-value (class-of this) 'method-functions))))

- m-id))))

- :specializers (list class (find-class t) (find-class t) (find-class t))))

+ (apply #'setup-qt-class class #'call-next-method args))

(defmethod reinitialize-instance :around ((qt-class qt-class) &rest args)

(apply #'setup-qt-class qt-class #'call-next-method args))

@@ -204,7 +217,9 @@

;;;

;; No-op since we have overload resolution.

(setf (fdefinition 'uint) #'identity

- (fdefinition 'int) #'identity)

+ (fdefinition 'int) #'identity

+ (fdefinition 'bool) #'identity

+ (fdefinition 'qstring) #'identity)

(defun find-qclass (class-name)

"Returns the CLOS class for the C++ CLASS-NAME string."

--- old-commonqt/src/package.lisp 2014-10-30 06:54:33.000000000 +0100

+++ new-commonqt/src/package.lisp 2014-10-30 06:54:33.000000000 +0100

@@ -20,7 +20,10 @@

#:primitive-value

#:uint

- #:int))

+ #:int

+ #:bool

+ #:qstring

+ #:enum=))

;; No named-readtables support; fake it.

;;

--- old-commonqt/tests/test.lisp 2014-10-30 06:54:33.000000000 +0100

+++ new-commonqt/tests/test.lisp 2014-10-30 06:54:33.000000000 +0100

@@ -12,7 +12,11 @@

(5am:test enum

(5am:is (enum= cl-smoke.qt:+blue+

- (#_blue "Qt"))))

+ (#_blue "Qt")))

+ (5am:is (enum= cl-smoke.qt:font.+bold+

+ (#_Bold "Font")))

+ (5am:is (enum= cl-smoke.qt:+key-enter+

+ (#_Key_Enter "Qt"))))

(5am:test new

(5am:is (cxx:= (make-instance 'cl-smoke.qt:byte-array :args '("foobar"))