repos
/
qt.gui
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
*exec-p* allows disabling qt:exec
Annotate for file src/application.lisp
2009-06-11 tobias
1
(in-package :qt)
2009-04-05 tobias
2
2009-07-01 tobias
3
(declaim (optimize (debug 3)))
10:58:06 '
4
2010-01-10 tobias
5
(defvar *app*)
2009-04-05 tobias
6
(defvar *widgets* nil)
2009-05-24 tobias
7
(defvar *exec-p* t
15:02:00 '
8
"Run exec if true and not otherwise.")
2009-04-05 tobias
9
2009-06-11 tobias
10
(defun app ()
2010-01-10 tobias
11
"Returns the APPLICATION (or CORE-APPLICATION) object,
08:52:49 '
12
within a WITH-APP."
2009-06-11 tobias
13
(assert (app-p)
2010-01-10 tobias
14
(*app*)
08:52:49 '
15
"No application.")
'
16
*app*)
'
17
2009-06-11 tobias
18
(defun app-p ()
2010-01-10 tobias
19
"Returns t when the APPLICATION object exists and nil otherwise."
08:52:49 '
20
(boundp '*app*))
'
21
2009-07-01 tobias
22
2009-07-22 tobias
23
(let ((argv (null-pointer))
22:21:01 '
24
(argc (null-pointer)))
'
25
(declare (cffi:foreign-pointer argv argc))
'
26
(defun ensure-app (&optional
2009-06-11 tobias
27
(application 'application)
2009-07-22 tobias
28
(args #+sbcl sb-ext:*posix-argv*
22:21:01 '
29
#+ccl ccl:*command-line-argument-list*
'
30
#-(or sbcl ccl) (list (lisp-implementation-type))))
'
31
"Constructs the global application object, when there is none,
2010-01-10 tobias
32
with the command line arguments ARGS.
08:52:49 '
33
'
34
Returns the application object a first value and
'
35
true when a new application was created and false otherwise."
2009-07-22 tobias
36
(assert (not (null args))
22:21:01 '
37
(args)
'
38
"No program name supplied.")
2009-06-11 tobias
39
(if (app-p)
2009-07-22 tobias
40
(progn
2009-06-11 tobias
41
(assert (typep (app) (find-class application))
2009-07-22 tobias
42
(application)
22:21:01 '
43
"The existing application object ~A is
2009-06-11 tobias
44
not of type ~A." (app) (find-class application))
14:59:48 '
45
(values (app) nil))
2009-07-22 tobias
46
(progn
2009-06-03 tobias
47
;(assert (null-pointer-p (smoke::pointer (core-application.instance))))
2009-07-22 tobias
48
(foreign-free argv)
22:21:01 '
49
(foreign-free argc)
2010-01-10 tobias
50
2009-06-10 tobias
51
(setf argv (foreign-alloc :string :initial-contents args))
2009-07-22 tobias
52
(setf argc (foreign-alloc :int :initial-element (length args)))
2009-06-03 tobias
53
(values (make-instance 'qt:application :args (list argc argv)) t))))
2009-07-22 tobias
54
(defun kill-app ()
2009-06-11 tobias
55
(cxx:quit (app))
2009-06-03 tobias
56
(when (typep (app) (find-class 'qt:application))
22:02:12 '
57
(application.close-all-windows))
2009-07-22 tobias
58
(setf *widgets* nil)
2009-06-03 tobias
59
(trivial-garbage:cancel-finalization (app))
22:02:12 '
60
(smoke::remove-object (smoke::pointer (app)))
'
61
;; FIXME leak memory or memory fault!
'
62
;(smoke::delete-pointer (smoke::pointer (app)) (class-of (app)))
'
63
(cxx:delete-later (app))
2009-06-11 tobias
64
(setf (slot-value (app) 'pointer) (null-pointer))
2009-07-22 tobias
65
(makunbound '*app*)))
2010-01-10 tobias
66
08:52:49 '
67
(defmacro with-application ((ensure-app remove-app) &body body)
'
68
(let ((cleanup-p (gensym)))
'
69
`(multiple-value-bind (*app* ,cleanup-p) ,ensure-app
'
70
(unwind-protect
'
71
(progn ,@body)
'
72
(when ,cleanup-p
'
73
,remove-app)))))
2009-04-05 tobias
74
2009-06-11 tobias
75
(defmacro with-app (&body body)
2009-04-05 tobias
76
"Ensures that a APPLICATION instance exists,
17:56:16 '
77
evaluates BODY and executes the APPLICATION instance after BODY.
'
78
The instance can be accessed with:
2009-07-01 tobias
79
APP.
2009-04-05 tobias
80
17:56:16 '
81
Can be nested.
'
82
'
83
When a APPLICATION was created, it will be deleted when returning
'
84
from BODY."
2009-06-11 tobias
85
`(with-application ((ensure-app 'application) (kill-app))
2009-07-01 tobias
86
,@body))
2009-04-05 tobias
87
2009-06-11 tobias
88
(defmacro with-core-app (&body body)
14:59:48 '
89
`(with-application ((ensure-app 'core-application) (kill-app))
2009-07-01 tobias
90
,@body))
2010-01-10 tobias
91
2009-07-01 tobias
92
2009-06-11 tobias
93
(defun exec (&rest widgets)
2009-07-01 tobias
94
"Executes APP."
10:58:06 '
95
(setf *widgets* (append widgets *widgets*))
2009-05-24 tobias
96
(when *exec-p*
15:02:00 '
97
(restart-bind ((abort-app #'(lambda ()
'
98
(application.close-all-windows)
'
99
(cxx:quit (app))
'
100
(invoke-restart (find-restart 'continue)))
'
101
:report-function
'
102
#'(lambda (stream)
'
103
(format stream "Return from the application event loop."))))
'
104
(cxx:exec (app)))))