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