Thu Jul 2 19:34:07 CEST 2009 Tobias Rautenkranz * initial import diff -rN -u old-commonqt/commonqt.mbd new-commonqt/commonqt.mbd --- old-commonqt/commonqt.mbd 1970-01-01 01:00:00.000000000 +0100 +++ new-commonqt/commonqt.mbd 2014-10-30 07:09:31.000000000 +0100 @@ -0,0 +1,14 @@ +;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- +(in-package :sysdef-user) + +(define-system :cl-smoke.commonqt () + (:version 0 0 1) + (:documentation "CL-smoke CommonQT compability layer.") + (:author "Tobias Rautenkranz") + (:needs :smoke :qt :cl-ppcre :cffi) + (:components + ("src" module + (:components + "package" + ("signal-slot" (:needs "commonqt")) + ("commonqt" (:needs "package")))))) diff -rN -u old-commonqt/src/commonqt.lisp new-commonqt/src/commonqt.lisp --- old-commonqt/src/commonqt.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-commonqt/src/commonqt.lisp 2014-10-30 07:09:31.000000000 +0100 @@ -0,0 +1,211 @@ +(in-package :cl-smoke.commonqt) + +;;; calling methods +;;; +(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) + `(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)) + +;;; Instantiating +;;; +(defun new (instance &rest arguments) + "Calls the C++ construor for INSTANCE with ARGUMENTS." + (assert (null-pointer-p (smoke:pointer 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) + instance) + +;;; Connecting signals and slots +;;; +(defun qsignal (name) + (cl-smoke.qt:qsignal name)) +(defun qslot (name) + (cl-smoke.qt:qslot name)) + +;;; QApplication +;;; +(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 + (cffi:foreign-alloc :int + :initial-element (1+ (length arguments)))) + (argv ;(smoke::make-auto-pointer + (cffi:foreign-alloc :string + :initial-contents + (cons (lisp-implementation-type) ;; arg0 + arguments))) + (application (make-instance 'cl-smoke.qt:application :args + (list argc argv)))) + ;; argc & argv must remain valid during the lifetime of application. + (setf (cl-smoke.qt:property application 'arguments) + (cl-smoke.qt:make-lisp-variant (cons argc argv))) + application)) + +;;; Overriding C++ methods +(defclass override-gf (standard-generic-function) + ((cxx-gf :initarg :cxx-gf + :reader cxx-gf)) + (:metaclass closer-mop:funcallable-standard-class) + (:documentation "Redirects its methods to CXX-GF.")) + +(defmethod add-method ((gf override-gf) method) + (add-method (cxx-gf gf) method)) + +(defmethod remove-method ((gf override-gf) method) + (remove-method (cxx-gf gf) method)) + +;;; 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))) + +(defun setup-meta-object (class qt-superclass) + (let ((methods (make-array (+ (length (slot-value class 'signals)) + (length (slot-value class 'qt-slots))) + :element-type 'function + :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)))) + (dolist (slot (slot-value class 'qt-slots)) + (setf (aref methods index) + (if (symbolp (second slot)) + (second slot) + (eval `(function ,(second slot))))) + (incf index)) + (setf (slot-value class 'method-functions) methods)) + (let ((signals (mapcar #'(lambda (s) (make-slot-or-signal (first s))) + (slot-value class 'signals))) + (slots (mapcar #'(lambda (s) (make-slot-or-signal (first s))) + (slot-value class 'qt-slots))) + (class-name (class-name class))) + (setf (slot-value class 'meta-object) + (make-metaobject qt-superclass + (format nil "~A::~A" + (package-name (symbol-package class-name)) + (symbol-name class-name)) + nil + signals + slots)))) + +(defun setup-qt-class (qt-class next-method &rest args &key qt-superclass + direct-superclasses direct-default-initargs + override &allow-other-keys) + (assert (null direct-superclasses)) + (dolist (method override) + (ensure-generic-function + (second method) + :generic-function-class (find-class 'override-gf) + :lambda-list '(this &rest args) + :cxx-gf (fdefinition (smoke::lispify (first method) :cxx)))) + (apply next-method qt-class + :direct-default-initargs ;; the C++ instance is constructed with #'NEW + (cons `(:pointer (null-pointer) ,#'null-pointer) + direct-default-initargs) + :direct-superclasses + (list (find-qclass (first qt-superclass))) + args) + (setup-meta-object qt-class (find-qclass (first qt-superclass)))) + +(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)))) + +(defmethod reinitialize-instance :around ((qt-class qt-class) &rest args) + (apply #'setup-qt-class qt-class #'call-next-method args)) + +(defun emit-signal (object signal-name &rest arguments) + "Emits the signal SIGNAL-NAME of OBJECT using ARGUMENTS." + (let* ((meta-object (slot-value (class-of object) 'meta-object)) + (id (#_indexOfSignal meta-object signal-name))) + (assert (>= id 0) + () + "No signal ~A of ~A." signal-name object) + (cl-smoke.qt-impl::activate + object id (cl-smoke.qt-impl::method-arguments-type meta-object id) + arguments))) + +(defmacro call-next-qmethod () + "Calls the next method." + '(call-next-method)) + + +;;; Enum values +;;; +(defun primitive-value (enum) + "Returns the integer value of ENUM." + (cxx-support:value enum)) + +;;; Type disambiguation +;;; +;; No-op since we have overload resolution. +(setf (fdefinition 'uint) #'identity + (fdefinition 'int) #'identity) + +(defun find-qclass (class-name) + "Returns the CLOS class for the C++ CLASS-NAME string." + (find-class (smoke::lispify class-name :cl-smoke.qt))) diff -rN -u old-commonqt/src/package.lisp new-commonqt/src/package.lisp --- old-commonqt/src/package.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-commonqt/src/package.lisp 2014-10-30 07:09:31.000000000 +0100 @@ -0,0 +1,33 @@ +;; Remove the :qt nickname of :cl-smoke.qt to allow +;; :cl-smoke.commonqt to use it. +(eval-when (:load-toplevel :compile-toplevel) + (rename-package :cl-smoke.qt :cl-smoke.qt)) + +(defpackage :cl-smoke.commonqt + (:use :cl :cxx-support :cffi) + (:nicknames :qt) + (:export #:new + + #:qsignal + #:qslot + + #:make-qapplication + + #:qt-class + + #:emit-signal + #:call-next-qmethod + #:primitive-value + + #:uint + #:int)) + +;; No named-readtables support; fake it. +;; +(defpackage :named-readtables + (:use :cl) + (:export #:in-readtable)) + +(in-package :named-readtables) +(defun in-readtable (name) + (declare (ignore name))) diff -rN -u old-commonqt/src/signal-slot.lisp new-commonqt/src/signal-slot.lisp --- old-commonqt/src/signal-slot.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-commonqt/src/signal-slot.lisp 2014-10-30 07:09:31.000000000 +0100 @@ -0,0 +1,131 @@ +;;; Copyright (c) 2009 David Lichteblau. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-smoke.commonqt) + +(defclass class-info () + ((key :initarg :key + :accessor entry-key) + (value :initarg :value + :accessor entry-value))) + +(defclass slot-or-signal () + ((name :initarg :name + :accessor entry-name) + (full-name :initarg :full-name + :accessor entry-full-name) + (arg-types :initarg :arg-types + :accessor entry-arg-types) + (reply-type :initarg :reply-type + :accessor entry-reply-type))) + +(defun make-slot-or-signal (signature) + (let ((signature (#_data + (#_normalizedSignature "QMetaObject" signature)))) + (cl-ppcre:register-groups-bind + (a b c d) + ("^(([\\w,<>:]*)\\s+)?([^\\s]*)\\((.*)\\)" signature) + (declare (ignore a)) + (make-instance 'slot-or-signal + :name c + :full-name (concatenate 'string c "(" d ")") + :arg-types d + :reply-type (if (or (null b) (equal b "void")) "" b))))) + +(defconstant +access-protected+ #x01) +(defconstant +access-public+ #x02) +(defconstant +method-signal+ #x04) +(defconstant +method-slot+ #x08) + +(cffi:defcstruct qmeta-object + "QMetaObject (a POD struct)" + (super-data :pointer) + (string-data :pointer) + (data :pointer) + (extra-data :pointer)) + +(defun make-metaobject (parent class-name class-infos signals slots) + (let ((data (make-array 0 :fill-pointer 0 :adjustable t)) + (table (make-hash-table)) + (stream (make-string-output-stream))) + (labels ((intern-string (s) + (or (gethash s table) + (setf (gethash s table) + (prog1 + (file-position stream) + (write-string s stream) + (write-char (code-char 0) stream))))) + (add (x) (vector-push-extend x data)) + (add-string (s) (add (intern-string s)))) + (add 1) ;revision + (add (intern-string class-name)) ;class name + (add (length class-infos)) ;classinfo + (add (if (plusp (length class-infos)) 10 0)) + (add (+ (length signals) (length slots))) + (add (+ 10 (* 2 (length class-infos)))) ;methods + (add 0) ;properties + (add 0) + (add 0) ;enums/sets + (add 0) + (dolist (entry class-infos) + (add-string (entry-key entry)) + (add-string (entry-value entry))) + (dolist (entry signals) + (add-string (entry-full-name entry)) + (add-string (remove #\, (entry-full-name entry) :test-not #'eql)) + (add-string (entry-reply-type entry)) + (add-string "") ;tag + (add (logior +method-signal+ +access-protected+))) + (dolist (entry slots) + (add-string (entry-full-name entry)) + (add-string (remove #\, (entry-full-name entry) :test-not #'eql)) + (add-string (entry-reply-type entry)) + (add-string "") ;tag + (add (logior +method-slot+ +access-public+))) + (add 0)) + (let ((dataptr (cffi:foreign-alloc :int :count (length data)))) + (dotimes (i (length data)) + (setf (cffi:mem-aref dataptr :int i) (elt data i))) + (let ((meta-struct (cffi:foreign-alloc 'qmeta-object)) + (parent-meta-object (#_staticMetaObject parent))) + (setf (foreign-slot-value meta-struct 'qmeta-object 'super-data) + (smoke:pointer parent-meta-object) + + (foreign-slot-value meta-struct 'qmeta-object 'string-data) + (foreign-string-alloc (get-output-stream-string stream)) + + (foreign-slot-value meta-struct 'qmeta-object 'data) + dataptr + + (foreign-slot-value meta-struct 'qmeta-object 'extra-data) + (null-pointer)) + (let ((meta-object (make-instance 'cl-smoke.qt:meta-object + :pointer meta-struct))) + + ;; PARENT-META-OBJECT must remain valid during the lifetime + ;; of META-OBJECT. + (push parent-meta-object (smoke::owned-objects meta-object)) + meta-object))))) diff -rN -u old-commonqt/test.lisp new-commonqt/test.lisp --- old-commonqt/test.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-commonqt/test.lisp 2014-10-30 07:09:31.000000000 +0100 @@ -0,0 +1,25 @@ +#| +MALLOC_CHECK_=3 sbcl --noinform --disable-debugger --noprint --load $0 --end-toplevel-options "$@" || exit 1 +exit 0 +# do not use --script to allow loading mudballs with ${HOME}/.sbclrc +# Used for testing on darcs record. +|# + + +(in-package :sysdef-user) + +(defun load-sysdef (pathname system) + (load pathname) + (setf (mb.sysdef::pathname-of (find-system system)) pathname)) + +(defun load-sysdef-file (system-name file-name) + "Loads a mbd file in the current directory." + (load-sysdef (make-pathname :defaults *default-pathname-defaults* + :name file-name + :type "mbd") + system-name)) + +(load-sysdef-file :cl-smoke.commonqt "commonqt") +(mb:test :cl-smoke.commonqt) + +(sb-ext:quit) diff -rN -u old-commonqt/tests/test.lisp new-commonqt/tests/test.lisp --- old-commonqt/tests/test.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-commonqt/tests/test.lisp 2014-10-30 07:09:31.000000000 +0100 @@ -0,0 +1,92 @@ +(eval-when (:compile-toplevel :load-toplevel) + (mb:load :FiveAM)) + +(in-package :cl-smoke.commonqt) + +(5am:def-suite :cl-smoke.commonqt-suite) +(5am:in-suite :cl-smoke.commonqt-suite) + +(5am:test static-call + (5am:is (string= (cl-smoke.qt:q-version) + (#_qVersion "GlobalSpace")))) + +(5am:test enum + (5am:is (enum= cl-smoke.qt:+blue+ + (#_blue "Qt")))) + +(5am:test new + (5am:is (cxx:= (make-instance 'cl-smoke.qt:byte-array :args '("foobar")) + (#_new QByteArray "foobar")))) + +(5am:test call + (let ((byte-array (make-instance 'cl-smoke.qt:byte-array :args '("foobar")))) + (5am:is (string= (cxx:data byte-array) + (#_data byte-array))))) + +(defclass button () + ((called :accessor button-meta-object-called :initform nil)) + (:metaclass qt-class) + (:qt-superclass "QPushButton") + (:override ("metaObject" meta-object))) + +(defmethod initialize-instance :after ((instance button) &rest initargs) + (declare (ignore initargs)) + (new instance "foobar")) + +(defmethod meta-object ((this button)) + (setf (button-meta-object-called this) t) + (call-next-qmethod)) + +(5am:test subclassing + (cl-smoke.qt:with-app () + (let ((button (make-instance 'button))) + (5am:is (string= "" + (#_objectName button))) + (5am:is (string= "foobar" + (#_text button)))))) + +(5am:test overriding + (cl-smoke.qt:with-app () + (let ((button (make-instance 'button))) + (5am:is (eql nil (button-meta-object-called button))) + (#_metaObject button) + (5am:is (eql t (button-meta-object-called button)))))) + +(defclass mumble () + ((called :accessor mumble-called :initform nil)) + (:metaclass qt-class) + (:qt-superclass "QObject") + (:slots ("listen(int)" (lambda (this &optional value) + (5am:is (= 37 value)) + (setf (mumble-called this) t)))) + (:signals ("say(int)"))) + +(defmethod initialize-instance :after ((instance mumble) &rest initargs) + (declare (ignore initargs)) + (new instance)) + +(5am:test signal-slot + (let ((mumble (make-instance 'mumble))) + (5am:is (eql t + (#_connect "QObject" + mumble (qt:qsignal "say(int)") + mumble (qt:qslot "listen(int)")))) + (5am:is (eql nil (mumble-called mumble))) + (emit-signal mumble "say(int)" 37) + (5am:is (eql t (mumble-called mumble))) + + (5am:is (string= "QObject" + (#_className (#_superClass (#_metaObject mumble))))))) + +(5am:test make-qapplication + (let ((application (make-qapplication))) + (5am:is (eql (#_instance "QCoreApplication") + application)) + (5am:is (eql t (typep application 'cl-smoke.qt:application))) + (smoke:delete-object application))) + +(eval-when (:load-toplevel) + (let ((results (5am:run :cl-smoke.commonqt-suite))) + (5am:explain! results) + (unless (5am:results-status results) + (error "Testsuite :qt.suite failed."))))