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