add GC for QGET, QFUN return values; fix possible memory leaks (e.g. overridden metho...
[eql:eql.git] / src / lisp / ini.lisp
1 ;;; copyright (c) 2010-2011 Polos Ruetz
2
3 (in-package :eql)
4
5 (defmacro alias (s1 s2)
6   `(setf (symbol-function ',s1) (function ,s2)))
7
8 (defmacro qlet ((&rest pairs) &body body)
9   "args: (((var exp) ...) ...)
10    Similar to <code>let*</code>. Creates temporary Qt objects, deleting them at the end of the <code>qlet</code> body. If <code>exp</code> is a string, it will be substituted with <code>(qnew exp)</code>, optionally including constructor arguments.
11        (qlet ((painter \"QPainter\")) ...)
12        (qlet ((reg-exp \"QRegExp(QString)\" \"^\\\\S+$\")) ...)"
13   (let ((vars (mapcar 'first pairs))
14         (exps (mapcar (lambda (x)
15                         (let ((exp (rest x)))
16                           (if (stringp (first exp))
17                               (apply 'list 'qnew exp)
18                               (first exp))))
19                       pairs))
20         (x (gensym)))
21     `(let* ,(mapcar 'list vars exps)
22        (unwind-protect
23             (progn
24               ,@body)
25          ,(if (second vars)
26               `(dolist (,x (list ,@(nreverse vars)))
27                  (qdel ,x))
28               `(qdel ,(first vars)))))))
29
30 (defun %get-function (fn pkg)
31   (typecase fn
32     (symbol
33      fn)
34     (function
35      (let ((var (intern (symbol-name (gensym)) pkg)))
36        (setf (symbol-function var) fn)
37        var))))
38
39 (defun %make-vector ()
40   (make-array 0 :adjustable t :fill-pointer t))
41
42 ;;; qt-object
43
44 (defstruct (qt-object (:constructor qt-object (pointer unique id &optional finalize)))
45   (pointer 0 :type integer)
46   (unique 0 :type integer)
47   (id 0 :type fixnum)
48   (finalize nil :type boolean))
49
50 (defun new-qt-object (pointer unique id finalize)
51   (let ((obj (qt-object pointer unique id finalize)))
52     (when finalize
53       (ext:set-finalizer obj #'qdelete))
54     obj))
55
56 (defmethod print-object ((obj qt-object) s)
57   (print-unreadable-object (obj s :type nil :identity nil)
58     (format s "~A 0x~X~A"
59             (qt-object-name obj)
60             (qt-object-pointer obj)
61             (if (qt-object-finalize obj) " GC" ""))))
62
63 (defmacro tr (src &optional con (n -1))
64   "args: (source &optional context n)
65    Macro expanding to <code>qtranslate</code>, which calls <code>QCoreApplication::translate()</code>. Both <code>source</code> and <code>context</code> can be Lisp forms evaluating to constant strings (at compile time).<br>The <code>context</code> argument defaults to the Lisp file name, and the <code>n</code> argument is a plural indicator (see Qt Assistant)."
66   ;; see compiler-macro in my_app/tr.lisp
67   (let ((source (ignore-errors (eval src)))
68         (context (ignore-errors (eval con))))
69     `(eql:qtranslate ,(if (stringp context)
70                           context
71                           (if *compile-file-truename* (file-namestring *compile-file-truename*) ""))
72                      ,source
73                      ,n)))
74
75 (defun qset-null (obj)
76   "args: (object)
77    Sets the Qt object pointer to <code>0</code>. This function is called automatically after <code>qdel</code>."
78   (when (qt-object-p obj)
79     (setf (qt-object-pointer obj) 0)))
80
81 (let (home)
82   (defun set-home (path)
83     (setf home path))
84   (defun in-home (file)
85     (concatenate 'string home file)))
86
87 (defun qgui (&optional ev)
88   "args: (&optional process-events)
89    Launches the <code>EQL</code> convenience GUI.<br>If you don't have an interactive environment, you can pass <code>T</code> to run a pseudo Qt event loop. A better option is to start the tool like so:<br><code>./eql -qgui</code>, in order to run the Qt event loop natively."
90   (in-package :eql)
91   (load (in-home "gui/gui"))
92   (when ev
93     (loop
94        (qprocess-events)
95        (sleep 0.05))))
96
97 (defun qeql (obj1 obj2)
98   "args: (object1 object2)
99    Returns <code>T</code> for same instances of a Qt class."
100   (and (qt-object-p obj1)
101        (qt-object-p obj2)
102        (= (qt-object-pointer obj1)
103           (qt-object-pointer obj2))))
104
105 (defun qnull-object (obj)
106   "args: (object)
107    Checks for a <code>0</code> Qt object pointer."
108   (when (qt-object-p obj)
109     (zerop (qt-object-pointer obj))))
110
111 (defun qapropos (&optional name class type)
112   (let ((main (qapropos2 name class type)))
113     (dolist (sub1 main)
114       (format t "~%~%~A~%" (first sub1))
115       (dolist (sub2 (rest sub1))
116         (format t "~%  ~A~%~%" (first sub2))
117         (dolist (sub3 (rest sub2))
118           (format t "    ~A~%" sub3))))
119     (terpri)))
120
121 (defun qapropos* (&optional name class type)
122   "args: (&optional search class)
123    Similar to <code>qapropos</code>, returning the results as nested list."
124   (qapropos2 name class type))
125
126 (defun qnew-instance (name &rest args)
127   (qnew-instance2 name args))
128
129 (defun qinvoke-method (obj slot &rest args)
130   (qinvoke-method2 obj nil slot args))
131
132 (defun qinvoke-method* (obj name slot &rest args)
133   "args: (object class name &rest arguments)
134    alias: qfun*
135    Similar to <code>qinvoke-method</code>, additionally passing a class name, enforcing a cast to that class.
136        (qfun* event \"QKeyEvent\" \"key\")
137        (qfun* graphics-text-item \"QGraphicsItem\" \"setPos\" (list x y)) ; multiple inheritance problem
138        (qfun* *qt-main* :qt \"foo\") ; call embedded Qt/C++ function (see Qt_EQL)"
139   (qinvoke-method2 obj name slot args))
140
141 (defun qconnect (from signal to &optional slot)
142   (qconnect2 from signal to slot nil))
143
144 (defun qdisconnect (from signal to &optional slot)
145   (qconnect2 from signal to slot t))
146
147 (defun qobject-names (&optional type)
148   (qobject-names2 type))
149
150 (defun qui-class (file &optional var)
151   (qui-class2 file var))
152
153 (defun qmessage-box (msg)
154   "args: (x)
155    alias: qmsg
156    Convenience function, calling: (converting x to a string if necessary)
157        (qfun \"QMessageBox\" \"information\" nil \"EQL\" x))"
158   (qfun "QMessageBox" "information" nil "EQL" (if (stringp msg) msg (prin1-to-string msg))))
159
160 (defun qevents ()
161   (eql:qprocess-events)
162   #-win32
163   (serve-event:serve-all-events 0.01)
164   (sleep 0.01))
165
166 (alias qnew  qnew-instance)
167 (alias qdel  qdelete)
168 (alias qget  qproperty)
169 (alias qset  qset-property)
170 (alias qfun  qinvoke-method)
171 (alias qfun* qinvoke-method*)
172 (alias qmsg  qmessage-box)
173 (alias qq    qquit)
174
175 (in-package :si)
176
177 ;;; The following is taken from "src/lsp/top.lsp" version 11.1.1
178 ;;; added SERVE-EVENT to TPL-READ, in order to process Qt events
179 ;;; (every modification is annotated with "[EQL]")
180
181 #-win32
182 (defun qtop-level ()
183   "Args: ()
184 ECL specific.
185 The top-level loop of ECL. It is called by default when ECL is invoked."
186   (catch *quit-tag*
187     (let* ((*debugger-hook* nil)
188            + ++ +++ - * ** *** / // ///)
189       
190       ;;(in-package "CL-USER") [EQL]
191       (in-package "EQL") ;     [EQL]
192       
193       (unless *lisp-initialized*
194         (process-command-args)
195         (format t "ECL (Embeddable Common-Lisp) ~A" (lisp-implementation-version))
196         (format t "~%Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya~@
197 Copyright (C) 1993 Giuseppe Attardi~@
198 Copyright (C) 2000 Juan J. Garcia-Ripoll
199 ECL is free software, and you are welcome to redistribute it~@
200 under certain conditions; see file 'Copyright' for details.")
201         (format *standard-output* "~%Type :h for Help.  ")
202         (setq *lisp-initialized* t))
203       
204       (let ((*tpl-level* -1))
205         (qtpl)) ; [EQL]
206       0)))
207
208 #-win32
209 (defun qtpl (&key ((:commands *tpl-commands*) tpl-commands)
210                  ((:prompt-hook *tpl-prompt-hook*) *tpl-prompt-hook*)
211                  (broken-at nil)
212                  (quiet nil))
213   #-ecl-min
214   (declare (c::policy-debug-ihs-frame))
215   (let* ((*ihs-base* *ihs-top*)
216          (*ihs-top* (if broken-at (ihs-search t broken-at) (ihs-top)))
217          (*ihs-current* (if broken-at (ihs-prev *ihs-top*) *ihs-top*))
218          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
219          (*frs-top* (frs-top))
220          (*quit-tags* (cons *quit-tag* *quit-tags*))
221          (*quit-tag* *quit-tags*)       ; any unique new value
222          (*tpl-level* (1+ *tpl-level*))
223          (break-level *break-level*)
224          values)
225     (set-break-env)
226     (set-current-ihs)
227     (flet ((rep ()
228              ;; We let warnings pass by this way "warn" does the
229              ;; work.  It is conventional not to trap anything
230              ;; that is not a SERIOUS-CONDITION. Otherwise we
231              ;; would be interferring the behavior of code that relies
232              ;; on conditions for communication (for instance our compiler)
233              ;; and which expect nothing to happen by default.
234              (handler-bind 
235                  ((serious-condition
236                    (lambda (condition)
237                      (cond ((< break-level 1)
238                             ;; Toplevel should enter the debugger on any condition.
239                             )
240                            (*allow-recursive-debug*
241                             ;; We are told to let the debugger handle this.
242                             )
243                            (t
244                             (format t "~&Debugger received error: ~A~%~
245                                          Error flushed.~%" condition)
246                             (clear-input)
247                             (return-from rep t) ;; go back into the debugger loop.
248                             )
249                            )
250                      )))
251
252                (with-grabbed-console
253                    (unless quiet
254                      (break-where)
255                      (setf quiet t))
256                  (setq - (locally (declare (notinline qtpl-read)) ; [EQL]
257                            (tpl-prompt)
258                            (qtpl-read)) ; [EQL]
259                        values (multiple-value-list
260                                (eval-with-env - *break-env*))
261                        /// // // / / values *** ** ** * * (car /))
262                  (tpl-print values)))))
263           (loop
264            (setq +++ ++ ++ + + -)
265            (when
266                (catch *quit-tag*
267                  (if (zerop break-level)
268                    (with-simple-restart 
269                     (restart-toplevel "Go back to Top-Level REPL.")
270                     (rep))
271                    (with-simple-restart
272                     (restart-debugger "Go back to debugger level ~D." break-level)
273                     (rep)))
274                  nil)
275              (setf quiet nil))))))
276
277 ;; taken from "<ecl-dir>/contrib/serve-event/serve-event.lisp"
278 #-win32
279 (defmacro serve-event:with-fd-handler ((fd direction function) &rest body)
280   "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
281    DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
282    use, and FUNCTION is the function to call whenever FD is usable."
283   (let ((handler (gensym)))
284     `(let (,handler)
285        (unwind-protect
286             (progn
287               (setf ,handler (serve-event:add-fd-handler ,fd ,direction ,function))
288               ,@body)
289          (when ,handler
290            (serve-event:remove-fd-handler ,handler))))))
291
292 #-win32
293 (defun qtpl-read (&aux (*read-suppress* nil))
294   (finish-output)
295   (serve-event:with-fd-handler ; [EQL]
296       (0 :input (lambda (fd)   ; [EQL]
297                   ;; (loop       [EQL]
298                   (case (peek-char nil *standard-input* nil :EOF)
299                     ((#\))
300                      (warn "Ignoring an unmatched right parenthesis.")
301                      (read-char))
302                     ((#\space #\tab)
303                      (read-char))
304                     ((#\newline #\return)
305                      (read-char)
306                      ;; avoid repeating prompt on successive empty lines:
307                        (let ((command (tpl-make-command :newline "")))
308                          (when command (return-from qtpl-read command))))                   ; [EQL]
309                     (:EOF
310                      (terpri)
311                      (return-from qtpl-read (tpl-make-command :EOF "")))                    ; [EQL]
312                     (#\:
313                      (return-from qtpl-read (tpl-make-command (read-preserving-whitespace)  ; [EQL]
314                                                               (read-line))))
315                     (#\?
316                      (read-char)
317                      (case (peek-char nil *standard-input* nil :EOF)
318                        ((#\space #\tab #\newline #\return :EOF)
319                         (return-from qtpl-read (tpl-make-command :HELP (read-line))))       ; [EQL]
320                        (t
321                         (unread-char #\?)
322                         (return-from qtpl-read (read-preserving-whitespace)))))             ; [EQL]
323                     ;; We use READ-PRESERVING-WHITESPACE because with READ, if an
324                     ;; error happens within the reader, and we perform a ":C" or
325                     ;; (CONTINUE), the reader will wait for an inexistent #\Newline.
326                     (t
327                      (return-from qtpl-read (read))))))                                     ; [EQL]
328     (loop               ; [EQL]
329        (eql:qevents)))) ; [EQL]