Fri Jul 24 15:39:55 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Cleanup

--- old-commonqt/src/commonqt.lisp 2014-10-30 07:09:09.000000000 +0100

+++ new-commonqt/src/commonqt.lisp 2014-10-30 07:09:09.000000000 +0100

@@ -1,42 +1,77 @@

+;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

+;;;

+;;; This program is free software: you can redistribute it and/or modify

+;;; it under the terms of the GNU General Public License as published by

+;;; the Free Software Foundation, either version 3 of the License, or

+;;; (at your option) any later version.

+;;;

+;;; This program is distributed in the hope that it will be useful,

+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

+;;; GNU General Public License for more details.

+;;;

+;;; You should have received a copy of the GNU General Public License

+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.

+;;;

+;;; As a special exception, the copyright holders of this library give you

+;;; permission to link this library with independent modules to produce an

+;;; executable, regardless of the license terms of these independent

+;;; modules, and to copy and distribute the resulting executable under

+;;; terms of your choice, provided that you also meet, for each linked

+;;; independent module, the terms and conditions of the license of that

+;;; module. An independent module is a module which is not derived from or

+;;; based on this library. If you modify this library, you may extend this

+;;; exception to your version of the library, but you are not obligated to

+;;; do so. If you do not wish to do so, delete this exception statement

+;;; from your version.

+

(in-package :cl-smoke.commonqt)

+;;; initialization

+(defun ensure-smoke ())

+(defun enable-syntax ())

+

;;; calling methods

+;;;

+;;; #_ reader macro

+;;;

+;;; FIXME: Return reference arguments using multiple return values.

;;;

(eval-when (:load-toplevel :compile-toplevel :execute)

-(defun read-perserving-case (stream)

- (let ((*readtable* (copy-readtable nil)))

- (setf (readtable-case *readtable*) :preserve)

- (read stream)))

-

-(defun cl-smoke-funcall-form (stream subchar arg)

- (declare (ignore subchar arg))

- (let ((method (read-perserving-case stream)))

- (if (string= "new" (symbol-name method))

- `(lambda (&rest args)

- (make-instance

- ',(smoke::lispify (symbol-name (read-perserving-case stream)) :cl-smoke.qt)

- :args args))

- (let ((object (read stream)))

- (if (stringp object)

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

- args))))))))

+ (defun read-perserving-case (stream)

+ (let ((*readtable* (copy-readtable nil)))

+ (setf (readtable-case *readtable*) :preserve)

+ (read stream)))

+

+ (defun cl-smoke-funcall-form (stream subchar arg)

+ (declare (ignore subchar arg))

+ (let ((method (read-perserving-case stream)))

+ (if (string= "new" (symbol-name method))

+ `(lambda (&rest args)

+ (make-instance

+ ',(smoke::lispify (symbol-name (read-perserving-case stream)) :cl-smoke.qt)

+ :args args))

+ (let ((object (read stream)))

+ (if (stringp object)

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

+ args))))))))

(eval-when (:load-toplevel :compile-toplevel)

(set-dispatch-macro-character #\# #\_ #'cl-smoke-funcall-form))

@@ -45,10 +80,11 @@

;;;

(defun new (instance &rest arguments)

"Calls the C++ construor for INSTANCE with ARGUMENTS."

- (assert (null-pointer-p (smoke:pointer instance)))

+ (assert (null-pointer-p (smoke:pointer instance))

+ (instance)

+ "The instance ~A is already constructed." instance)

(setf (slot-value instance 'smoke:pointer)

(smoke::call-constructor instance arguments))

- (assert (not (null-pointer-p (smoke:pointer instance))))

(smoke::set-binding instance)

(smoke::take-ownership instance)

(smoke::add-object instance)

@@ -66,10 +102,10 @@

(defun make-qapplication (&rest arguments)

"Returns a new QApplication instance with ARGUMENTS as command line

arguments argv. argv[0] is set to (LISP-IMPLEMNTATION-TYPE)."

- (let* ((argc (smoke::make-auto-pointer

+ (let* ((argc (smoke:make-auto-pointer

(cffi:foreign-alloc :int

:initial-element (1+ (length arguments)))))

- (argv (smoke::make-auto-pointer

+ (argv (smoke:make-auto-pointer

(cffi:foreign-alloc :string

:initial-contents

(cons (lisp-implementation-type) ;; arg0

@@ -97,37 +133,40 @@

;;; Subclassing C++ & defining signals and slots

;;;

(defclass qt-class (cxx:class)

- ((qt-slots :initarg :slots :initform nil) ;; FIXME remove this

- (signals :initarg :signals :initform nil) ;; FIXME remove this

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

- (meta-object)))

+ ((method-functions :accessor method-functions

+ :documentation "The signals and slots.")

+ (meta-object :reader class-meta-object))

+ (:documentation "Metaclass for a class derived from QObject, that allows

+adding signals and slots to the class."))

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

+ ()

+ (:documentation "Mixin for a class with metaclass QT-CLASS, that overwrites

+the metaObject and qtMetacall methods."))

+

+(defun setup-meta-object (class qt-superclass signals slots)

+ (let ((methods (make-array (+ (length signals)

+ (length slots))

:element-type 'function

:initial-element #'identity))

(index 0))

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

+ (dolist (signal-name signals)

(setf (aref methods index)

(let ((signal-name (first signal-name)))

#'(lambda (this &rest args)

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

(incf index))

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

+ (dolist (slot slots)

(setf (aref methods index)

(if (symbolp (second slot))

(second slot)

(eval `(function ,(second slot)))))

(incf index))

- (setf (slot-value class 'method-functions) methods))

+ (setf (method-functions class) methods))

(let ((signals (mapcar #'(lambda (s) (make-slot-or-signal (first s)))

- (slot-value class 'signals)))

+ signals))

(slots (mapcar #'(lambda (s) (make-slot-or-signal (first s)))

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

+ slots))

(class-name (class-name class)))

(setf (slot-value class 'meta-object)

(make-metaobject qt-superclass

@@ -140,8 +179,8 @@

(defun setup-qt-class (qt-class next-method &rest args &key qt-superclass

direct-superclasses direct-default-initargs

+ slots signals

override &allow-other-keys)

- (assert (null direct-superclasses))

(dolist (method override)

(ensure-generic-function

(second method)

@@ -153,13 +192,15 @@

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

direct-default-initargs)

:direct-superclasses

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

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

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

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

+ direct-superclasses)

args)

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

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

+ signals slots))

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

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

+ (class-meta-object (class-of this)))

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

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

@@ -167,22 +208,20 @@

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

+ (when (< m-id (length (method-functions (class-of this))))

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

+ (apply (aref (method-functions (class-of this)) 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))))

+ (length (method-functions (class-of this)))))

m-id))))

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

@@ -195,8 +234,10 @@

(defun emit-signal (object signal-name &rest arguments)

"Emits the signal SIGNAL-NAME of OBJECT using ARGUMENTS."

(declare (string signal-name))

- (let* ((meta-object (slot-value (class-of object) 'meta-object))

- (id (#_indexOfSignal meta-object signal-name)))

+ (let* ((meta-object (class-meta-object (class-of object)))

+ (id (#_indexOfSignal meta-object

+ (#_normalizedSignature "QMetaObject"

+ signal-name))))

(assert (>= id 0)

()

"No signal ~A of ~A." signal-name object)

@@ -208,7 +249,6 @@

"Calls the next method."

'(call-next-method))

-

;;; Enum values

;;;

(defun primitive-value (enum)

@@ -218,9 +258,8 @@

;;; Type disambiguation

;;;

(defun bool (value)

- (ccase value

- (1 t)

- (0 nil)))

+ "Returns true when VALUE is not 0 and false when it is 0."

+ (not (zerop value)))

;; No-op since we have overload resolution.

(setf (fdefinition 'uint) #'identity

@@ -230,3 +269,15 @@

(defun find-qclass (class-name)

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

(find-class (smoke::lispify class-name :cl-smoke.qt)))

+

+;;; Documentation

+;;;

+

+(defun qapropos (name)

+ (smoke::fgrep-classes cl-smoke.qt-impl::*smoke-module* name)

+ (smoke::fgrep-methods cl-smoke.qt-impl::*smoke-module* name))

+

+;; FIXME: implement QDESCRIBE

+(defun qdescribe (name)

+ (declare (ignore name))

+ (warn "QDESCRIBE not implemented."))