Make dynamic-bindings for each class.
[commonqt:commonqt.git] / info.lisp
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
2
3 ;;; Copyright (c) 2009 David Lichteblau. All rights reserved.
4
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
8 ;;;
9 ;;;   * Redistributions of source code must retain the above copyright
10 ;;;     notice, this list of conditions and the following disclaimer.
11 ;;;
12 ;;;   * Redistributions in binary form must reproduce the above
13 ;;;     copyright notice, this list of conditions and the following
14 ;;;     disclaimer in the documentation and/or other materials
15 ;;;     provided with the distribution.
16 ;;;
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28
29 (in-package :qt)
30
31 (eval-when (:compile-toplevel :load-toplevel :execute)
32   (defconstant +index-bits+  16)
33   (defconstant +module-bits+  4)
34   (defconstant +kind-bits+    2))
35
36 (deftype index         () `(unsigned-byte ,+index-bits+))
37 (deftype module-number () `(unsigned-byte ,+module-bits+))
38 (deftype kind          () `(unsigned-byte ,+kind-bits+))
39
40 (deftype tagged ()
41   `(unsigned-byte ,(+ +index-bits+ +module-bits+ +kind-bits+)))
42
43 (deftype module-iterator () '(integer -1 #.(expt 2 +module-bits+)))
44 (deftype index-iterator  () '(integer -1 #.(expt 2 +index-bits+)))
45
46 (deftype ambiguous-method-index () `(signed-byte ,(1+ +index-bits+)))
47
48 ;;;;
49 ;;;; Module
50 ;;;;
51
52 (defvar *n-modules* 0)
53 (declaim (type module-iterator *n-modules*))
54
55 (defvar *module-table*
56   (make-array (ash 1 +module-bits+) :initial-element nil))
57
58 (defvar *module-data-table*
59   (make-array (ash 1 +module-bits+) :initial-element nil))
60
61 (declaim (type (simple-array t (#.(expt 2 +module-bits+)))
62                *module-table*
63                *module-data-table*))
64
65 (declaim (inline module-ref))
66 (defun module-ref (i) (svref *module-table* i))
67
68 (declaim (inline data-ref))
69 (defun data-ref (i) (svref *module-data-table* i))
70
71 ;;;;
72 ;;;; Bit bashing
73 ;;;;
74
75 ;;;; Smoke uses tables of classes, methods, types, and "methodmap"s,
76 ;;;; each indexed by a 16 bit integer.  There can be multiple smoke
77 ;;;; instances ("modules") having separate tables, interlinked through
78 ;;;; "external classes".
79 ;;;;
80 ;;;; We use the following encoding scheme to represent references
81 ;;;; into this kind of meta data as a 22 bit integer:
82 ;;;;
83 ;;;;    0000000000000001000100      = (class number 1 in the second module)
84 ;;;;    <--------------><--><>
85 ;;;;       |             |   |
86 ;;;;       |             |  2 bit type
87 ;;;;       |             |
88 ;;;;       |        4 bit module index
89 ;;;;      16 bit index
90 ;;;;
91 ;;;; Properties:
92 ;;;;   - no CLOS object caching, no memory overhead
93 ;;;;   - can just compare references using EQL
94 ;;;;   - fits into a fixnum
95 ;;;;   - Index ordering within a module and type is preserved, so that
96 ;;;;     binary search in the tables works for references as well as indexes.
97 ;;;;
98 ;;;; Note:
99 ;;;;   - Since only a fixed number of bits is reserved for the module
100 ;;;;     index, we can't load an arbitrary number of smoke modules at run
101 ;;;;     time.  There are only few such modules in kdebindings though, so
102 ;;;;     this isn't really a limitation.  If we ever need more than 16
103 ;;;;     modules, we can increase +module-bits+ a little.
104
105 (defconstant +class+ 0)
106 (defconstant +method+ 1)
107 (defconstant +methodmap+ 2)
108 (defconstant +type+ 3)
109
110 (declaim (inline module-number))
111 (defun module-number (smoke)
112   (position smoke
113             *module-table*
114             :test #'cffi:pointer-eq
115             :end *n-modules*))
116
117 (defun named-module-number (name)
118   (position name
119             *module-data-table*
120             :key (lambda (data)
121                    (and data (data-name data)))
122             :test #'string=))
123
124 #-qt::debug (declaim (inline bash))
125 (defun bash (idx module-number kind)
126   (declare (type index idx))
127   (declare (type module-number module-number))
128   (declare (type kind kind))
129   (logior kind
130           (ash (logior module-number
131                        (ash idx +module-bits+))
132                +kind-bits+)))
133
134 #-qt::debug (declaim (inline ldb-module))
135 (defun ldb-module (x)
136   (declare (type tagged x))
137   (ldb (byte +module-bits+ +kind-bits+) x))
138
139 #-qt::debug (declaim (inline ldb-kind))
140 (defun ldb-kind (x)
141   (declare (type tagged x))
142   (ldb (byte +kind-bits+ 0) x))
143
144 #-qt::debug (declaim (inline unbash))
145 (defun unbash (x)
146   (declare (type tagged x))
147   (values (ldb (byte 16 (+ +module-bits+ +kind-bits+)) x)
148           (ldb-module x)
149           (ldb (byte +kind-bits+ 0) x)))
150
151 #-qt::debug (declaim (inline unbash*))
152 (defun unbash* (x expected-kind)
153   (declare (type tagged x)
154            #-qt::debug (ignore expected-kind))
155   (multiple-value-bind (idx <module> kind)
156       (unbash x)
157     #+qt::debug (assert (eql kind expected-kind))
158     (values idx <module> kind)))
159
160
161 ;;;;
162 ;;;; Names
163 ;;;;
164
165 (defun %find-name (smoke str)
166   (sw_find_name smoke str))
167
168
169 ;;;;
170 ;;;; Classes
171 ;;;;
172
173 (defun map-classes (fun &optional allow-external)
174   (iter (for <module> below *n-modules*)
175         (declare (type module-iterator <module>))
176         (map-classes-in-module fun <module> allow-external)))
177
178 (defun map-classes-in-module (fun <module> &optional allow-external)
179   (let ((n (data-nclasses (data-ref <module>))))
180     (iter (for i from 1 below n)
181           (declare (type index-iterator i))
182           (let ((<class> (bash i <module> +class+)))
183             (unless (and (qclass-external-p <class>) (not allow-external))
184               (funcall fun <class>))))))
185
186 (declaim (inline qclass-struct))
187 (defun qclass-struct (<class>)
188   (declare (type tagged <class>))
189   (multiple-value-bind (idx <module>)
190       (unbash* <class> +class+)
191     #+qt::debug (assert (<= 0 idx (data-nclasses (data-ref <module>))))
192     (cffi:mem-aref (data-classes (data-ref <module>))
193                    '|struct Class|
194                    idx)))
195
196 (defun qclass-name (<class>)
197   (cffi:foreign-slot-value (qclass-struct <class>) '|struct Class| 'classname))
198
199 (defun qclass-external-p (<class>)
200   (plusp
201    (cffi:foreign-slot-value (qclass-struct <class>) '|struct Class| 'external)))
202
203 (defun resolve-external-qclass (<class>)
204   (if (qclass-external-p <class>)
205       (find-qclass (qclass-name <class>))
206       <class>))
207
208 (defun instance-qclass (ptr &optional (errorp t))
209   (or (cffi:with-foreign-object (&smoke :pointer)
210         (cffi:with-foreign-object (&index :short)
211           (sw_id_instance_class ptr &smoke &index)
212           (let ((smoke (cffi:mem-ref &smoke :pointer)))
213             (unless (cffi:null-pointer-p smoke)
214               (bash (cffi:mem-ref &index :short)
215                     (module-number smoke)
216                     +class+)))))
217       (when errorp
218         (error "Class not found for ~S" ptr))))
219
220 (defun find-qclass (name &optional (errorp t))
221   (etypecase name
222     (integer
223      (assert (eql (ldb-kind name) +class+))
224      name)
225     (string
226      (or (cffi:with-foreign-object (&smoke :pointer)
227            (cffi:with-foreign-object (&index :short)
228              (sw_find_class name &smoke &index)
229              (let ((smoke (cffi:mem-ref &smoke :pointer)))
230                (unless (cffi:null-pointer-p smoke)
231                  (bash (cffi:mem-ref &index :short)
232                        (module-number smoke)
233                        +class+)))))
234          (when errorp
235            (error "Class not found: ~A" name))))))
236
237 (defun find-qclass-in-module (<module> name &optional (allow-external t))
238   (declare (type module-number <module>))
239   (let ((index (the index-iterator
240                  (sw_id_class (module-ref <module>)
241                               name
242                               (if allow-external 1 0)))))
243     (and (plusp index) (bash index <module> +class+))))
244
245 (defmacro deflistify (list-name map-name &rest args)
246   `(defun ,list-name (,@args)
247      (iter
248        (,map-name (lambda (x) (collect x)) ,@args)
249        (finish))))
250
251 (defun format-reference (stream arg foo bar)
252   (declare (ignore foo bar))
253   (multiple-value-bind (id <module> kind)
254       (unbash arg)
255     (format stream "~D <~D,~D,~D>" arg id <module> kind)))
256
257 (declaim (inline map-qclass-superclasses))
258 (defun map-qclass-superclasses (fun <class>)
259   (let* ((<module> (ldb-module <class>))
260          (parents (the index-iterator
261                     (cffi:foreign-slot-value (qclass-struct <class>)
262                                              '|struct Class|
263                                              'parents)))
264          (inheritancelist (data-inheritancelist (data-ref <module>))))
265     (iter (for i from parents)
266           (declare (type index-iterator i))
267           (let ((classid (the index-iterator
268                            (cffi:mem-aref inheritancelist :short i))))
269             (while (plusp classid))
270             (funcall fun (or (resolve-external-qclass
271                               (bash classid <module> +class+))
272                              (error "Failed to resolve superclass: ~/qt:format-reference/"
273                                     (bash classid <module> +class+))))))))
274
275 (deflistify list-qclass-superclasses map-qclass-superclasses
276   <class>)
277
278 (defun qclass-flags (<class>)
279   (cffi:foreign-slot-value (qclass-struct <class>) '|struct Class| 'flags))
280
281 (macrolet ((deftest (name mask)
282              `(defun ,name (<class>)
283                 (logtest ,mask (qclass-flags <class>)))))
284   (deftest qclass-constructor-p #x01)
285   (deftest qclass-deepcopy-p #x02)
286   (deftest qclass-virtual-p #x04)
287   (deftest qclass-undefined-p #x08))
288
289 (defun list-qclass-flags (<class>)
290   (let ((x '()))
291     (when (qclass-constructor-p <class>) (push :constructor x))
292     (when (qclass-deepcopy-p <class>) (push :deepcopy x))
293     (when (qclass-virtual-p <class>) (push :virtual x))
294     (when (qclass-undefined-p <class>) (push :undefined x))
295     x))
296
297 (declaim (inline qclass-trampoline-fun))
298 (defun qclass-trampoline-fun (<class>)
299   (declare (type tagged <class>))
300   (cffi:foreign-slot-value (qclass-struct <class>) '|struct Class| 'classfn))
301
302 (declaim (inline qclass-enum-fun))
303 (defun qclass-enum-fun (<class>)
304   (declare (type tagged <class>))
305   (cffi:foreign-slot-value (qclass-struct <class>) '|struct Class| 'enumfn))
306
307
308 ;;;;
309 ;;;; MethodMap
310 ;;;;
311
312 (defun methodmap-struct (<methodmap>)
313   (multiple-value-bind (idx <module>)
314       (unbash* <methodmap> +methodmap+)
315     #+qt::debug (assert (<= 0 idx (data-nmethodmaps (data-ref <module>))))
316     (cffi:mem-aref (data-methodmaps (data-ref <module>))
317                    '|struct MethodMap|
318                    idx)))
319
320 (declaim (ftype (function (tagged) tagged) methodmap-class))
321 (declaim (inline methodmap-class))
322 (defun methodmap-class (<methodmap>)
323   (bash (cffi:foreign-slot-value (methodmap-struct <methodmap>)
324                                  '|struct MethodMap|
325                                  'classid)
326         (ldb-module <methodmap>)
327         +class+))
328
329 (declaim (inline map-methodmap-methods))
330 (defun map-methodmap-methods (fun <methodmap>)
331   (declare (type tagged <methodmap>))
332   (let ((<module> (ldb-module <methodmap>))
333         (methodid (cffi:foreign-slot-value (methodmap-struct <methodmap>)
334                                            '|struct MethodMap|
335                                            'methodid)))
336     (declare (type ambiguous-method-index methodid))
337     (if (plusp methodid)
338         (funcall fun (bash methodid <module> +method+))
339         (let ((ambiguous-methods
340                (data-ambiguousMethodList (data-ref <module>))))
341           (iter (for i from (- methodid))
342                 (declare (type index i))
343                 (let ((id (cffi:mem-aref ambiguous-methods :short i)))
344                   (while (plusp id))
345                   (funcall fun (bash id <module> +method+))))))))
346
347 (deflistify list-methodmap-methods map-methodmap-methods
348   <methodmap>)
349
350 (defun name-ref (<module> idx)
351   (declare (type module-number <module>))
352   (declare (type index idx))
353   (cffi:mem-aref (data-methodnames (data-ref <module>))
354                  :string
355                  idx))
356
357 (declaim (inline methodmap-name-index))
358 (defun methodmap-name-index (<methodmap>)
359   (declare (type tagged <methodmap>))
360   (cffi:foreign-slot-value (methodmap-struct <methodmap>)
361                            '|struct MethodMap|
362                            'name))
363
364 (declaim (inline methodmap-name))
365 (defun methodmap-name (<methodmap>)
366   (declare (type tagged <methodmap>))
367   (name-ref (ldb-module <methodmap>)
368             (the index (methodmap-name-index <methodmap>))))
369
370 (defun find-methodmap (<class> name)
371   (multiple-value-bind (classid <module>)
372       (unbash* <class> +class+)
373     (let* ((smoke (module-ref <module>))
374            (index
375             (the index (sw_id_method smoke classid (%find-name smoke name)))))
376       (if (zerop index)
377           nil
378           (bash index <module> +methodmap+)))))
379
380
381 ;;;;
382 ;;;; Methods
383 ;;;;
384
385 (defun map-methods (fun)
386   (iter (for <module> below *n-modules*)
387         (declare (type module-iterator <module>))
388         (map-methods-in-module fun <module>)))
389
390 (defun map-methods-in-module (fun <module>)
391   (let ((n (data-nmethods (data-ref <module>))))
392     (iter (for i from 0 below n)
393           (declare (type index-iterator i))
394           (funcall fun (bash i <module> +method+)))))
395
396 (declaim (inline qmethod-struct))
397 (defun qmethod-struct (<method>)
398   (multiple-value-bind (idx <module>)
399       (unbash* <method> +method+)
400     #+qt::debug (assert (<= 0 idx (data-nmethods (data-ref <module>))))
401     (cffi:mem-aref (data-methods (data-ref <module>))
402                    '|struct Method|
403                    idx)))
404
405 (declaim (inline qmethod-class))
406 (defun qmethod-class (<method>)
407   (declare (type tagged <method>))
408   (bash (cffi:foreign-slot-value (qmethod-struct <method>)
409                                  '|struct Method|
410                                  'classid)
411         (ldb-module <method>)
412         +class+))
413
414 (declaim (inline qmethod-name-index))
415 (defun qmethod-name-index (<method>)
416   (declare (type tagged <method>))
417   (cffi:foreign-slot-value (qmethod-struct <method>)
418                            '|struct Method|
419                            'name))
420
421 (declaim (inline qmethod-name))
422 (defun qmethod-name (<method>)
423   (declare (type tagged <method>))
424   (name-ref (ldb-module <method>)
425             (the index (qmethod-name-index <method>))))
426
427 (defun qmethod-flags (<method>)
428   (cffi:foreign-slot-value (qmethod-struct <method>) '|struct Method| 'flags))
429
430 (macrolet ((deftest (name mask)
431              `(defun ,name (<method>)
432                 (logtest ,mask (qmethod-flags <method>)))))
433   (deftest qmethod-static-p #x01)
434   (deftest qmethod-const-p #x02)
435   (deftest qmethod-copyctor-p #x04)
436   (deftest qmethod-internal-p #x08)
437   (deftest qmethod-enum-p #x10)
438   (deftest qmethod-ctor-p #x20)
439   (deftest qmethod-dtor-p #x40)
440   (deftest qmethod-protected-p #x80)
441   (deftest qmethod-virtual-p #x400))
442
443 (defun list-qmethod-flags (<method>)
444   (remove-if-not (lambda (fun)
445                    (funcall fun <method>))
446                  '(qmethod-static-p
447                    qmethod-const-p
448                    qmethod-copyctor-p
449                    qmethod-internal-p
450                    qmethod-enum-p
451                    qmethod-ctor-p
452                    qmethod-dtor-p
453                    qmethod-protected-p)))
454
455 (defun qmethod-return-type (<method>)
456   (bash (cffi:foreign-slot-value (qmethod-struct <method>)
457                                  '|struct Method|
458                                  'ret)
459         (ldb-module <method>)
460         +type+))
461
462 (declaim (inline map-qmethod-argument-types))
463 (defun map-qmethod-argument-types (fun <method>)
464   (let* ((<module> (ldb-module <method>))
465          (argumentlist (data-argumentlist (data-ref <module>))))
466     (cffi:with-foreign-slots
467         ((args numargs) (qmethod-struct <method>) |struct Method|)
468       (declare (type index-iterator args numargs))
469       (if (plusp numargs)
470           (iter (for i from args)
471                 (declare (type index i))
472                 (repeat numargs)
473                 (funcall fun
474                          (bash (cffi:mem-aref argumentlist :short i)
475                                <module>
476                                +type+)))
477           nil))))
478
479 (deflistify list-qmethod-argument-types map-qmethod-argument-types
480   <method>)
481
482 (defun qmethod-classfn-index (<method>)
483   (cffi:foreign-slot-value (qmethod-struct <method>)
484                            '|struct Method|
485                            'methodForClassFun))
486
487 ;;;;
488 ;;;; Type
489 ;;;;
490
491 ;; fixme: zerop flags; zerop classid
492
493 (defun qtype-void-p (<type>)
494   (zerop (unbash <type>)))
495
496 (defun map-types (fun)
497   (iter (for <module> below *n-modules*)
498         (declare (type module-iterator <module>))
499         (map-types-in-module fun <module>)))
500
501 (defun map-types-in-module (fun <module>)
502   (let ((n (data-ntypes (data-ref <module>))))
503     (iter (for i from 1 below n)
504           (declare (type index i))
505           (funcall fun (bash i <module> +type+)))))
506
507 (declaim (inline qtype-struct))
508 (defun qtype-struct (<type>)
509   (declare (type tagged <type>))
510   (multiple-value-bind (idx <module>)
511       (unbash* <type> +type+)
512     #+qt::debug (assert (<= 0 idx (data-ntypes (data-ref <module>))))
513     (cffi:mem-aref (data-types (data-ref <module>))
514                    '|struct Type|
515                    idx)))
516
517 (declaim (inline qtype-class))
518 (defun qtype-class (<type>)
519   (declare (type tagged <type>))
520   (resolve-external-qclass
521    (bash (cffi:foreign-slot-value (qtype-struct <type>)
522                                   '|struct Type|
523                                   'classid)
524          (ldb-module <type>)
525          +class+)))
526
527 (declaim (inline qtype-name))
528 (defun qtype-name (<type>)
529   (declare (type tagged <type>))
530   (cffi:foreign-slot-value (qtype-struct <type>) '|struct Type| 'name))
531
532 (defun qtype-interned-name (<type>)
533   (intern (qtype-name <type>) :keyword))
534
535 (defun qtype-flags (<type>)
536   (cffi:foreign-slot-value (qtype-struct <type>) '|struct Type| 'flags))
537
538 (defun qtype-stack-item-slot (<type>)
539   (elt #(ptr bool char uchar short ushort int uint long ulong float double
540          enum class)
541        (logand #xf (qtype-flags <type>))))
542
543 (defun qtype-kind (<type>)
544   (case (logand #x30 (qtype-flags <type>))
545     (#x10 :stack)
546     (#x20 :pointer)
547     (#x30 :reference)))
548
549 (defun qtype-constp (<type>)
550   (logtest #x40 (qtype-flags <type>)))
551
552 (defun find-qtype (name &optional <module>)
553   (loop for i from (or <module> 0) to (or <module> (1- *n-modules*))
554         for index = (sw_id_type (module-ref i) name)
555         when (plusp index) return (bash index i +type+)))
556
557 ;;;;
558 ;;;; Classes (cont. from above, now that inlined function are there)
559 ;;;;
560
561 (defun %find-any-methodmap-for-class (<class>)
562   (declare (type tagged <class>))
563   ;; Note: The way the comparison is currently written depends on <class>
564   ;; order being the same as index order within the same module.
565   (let* ((<module> (ldb-module <class>))
566          (from 1)
567          (to (data-nmethodmaps (data-ref <module>))))
568     (declare (type index-iterator from to))
569     (iter (while (<= from to))
570           (let* ((current-index
571                   (truncate (+ from to) 2))
572                  (current-<methodmap>
573                   (bash current-index <module> +methodmap+))
574                  (current-<class>
575                   (methodmap-class current-<methodmap>)))
576             (cond
577               ((eql current-<class> <class>)
578                (return current-<methodmap>))
579               ((> current-<class> <class>)
580                (setf to (1- current-index)))
581               (t
582                (setf from (1+ current-index))))))))
583
584 (declaim (inline map-class-methodmaps))
585 (defun map-class-methodmaps (fun <class>)
586   (let ((any (%find-any-methodmap-for-class <class>)))
587     (when any
588       (multiple-value-bind (first-idx <module>)
589                            (unbash any)
590         (macrolet
591             ((% (from offset)
592                `(iter (for idx ,from (+ first-idx ,offset))
593                       (declare (type index-iterator idx))
594                       (let ((<methodmap> (bash idx <module> +methodmap+)))
595                         (while (eql <class> (methodmap-class <methodmap>)))
596                         (funcall fun <methodmap>)))))
597           (% from 0)
598           (% downfrom -1))))))
599
600 (deflistify list-qclass-methodmaps map-class-methodmaps
601   <class>)
602
603 (defun %find-name-index-range (<module> method-name)
604   (let* ((str-length (length method-name))
605          (from (the index (%find-name (module-ref <module>) method-name)))
606          (to (data-nmethodnames (data-ref <module>))))
607     (declare (type index-iterator to))
608     (when (plusp from)
609       (values from
610               (iter (for current-index from (1+ from) below to)
611                     (let* ((current-name (name-ref <module> current-index))
612                            (mismatch (mismatch current-name method-name)))
613                       (while (and (eql mismatch str-length)
614                                   (find (char current-name str-length) "?#$")))
615                       (finally (return (1- current-index)))))))))
616
617 (defun %find-any-methodmap-for-class-and-name-range (<class> min max)
618   (declare (type tagged <class>))
619   (let* ((<module> (ldb-module <class>))
620          (from 1)
621          (to (data-nmethodmaps (data-ref <module>))))
622     (declare (type index-iterator from to))
623     (iter (while (<= from to))
624           (let* ((current-index
625                   (truncate (+ from to) 2))
626                  (current-<methodmap>
627                   (bash current-index <module> +methodmap+))
628                  (current-<class>
629                   (methodmap-class current-<methodmap>))
630                  (current-name-index
631                   (methodmap-name-index current-<methodmap>)))
632             (cond
633               ((eql current-<class> <class>)
634                (cond
635                  ((<= min current-name-index max)
636                   (return current-<methodmap>))
637                  ((> current-name-index max)
638                   (setf to (1- current-index)))
639                  (t
640                   (setf from (1+ current-index)))))
641               ((> current-<class> <class>)
642                (setf to (1- current-index)))
643               (t
644                (setf from (1+ current-index))))))))
645
646 (defun map-class-methodmaps-named (fun <class> method-name)
647   (declare (type tagged <class>))
648   (multiple-value-bind (min max)
649       (%find-name-index-range (ldb-module <class>) method-name)
650     (when min
651       (let ((any (%find-any-methodmap-for-class-and-name-range
652                   <class> min max)))
653         (when any
654           (multiple-value-bind (first-idx <module>)
655               (unbash any)
656             (macrolet
657                 ((% (from offset)
658                    `(iter (for idx ,from (+ first-idx ,offset))
659                           (declare (type index-iterator idx))
660                           (let ((<methodmap> (bash idx <module> +methodmap+)))
661                             (while (and (eql <class> (methodmap-class <methodmap>))
662                                         (<= min
663                                             (methodmap-name-index <methodmap>)
664                                             max)))
665                             (funcall fun <methodmap>)))))
666               (% from 0)
667               (% downfrom -1))))))))
668
669 (declaim (inline map-class-methodmaps))
670 (defun map-class-methods-named (fun <class> name)
671   (map-class-methodmaps-named
672    (lambda (<methodmap>)
673      (map-methodmap-methods fun <methodmap>))
674    <class> name))
675
676 (deflistify list-class-methods-named map-class-methods-named
677   <class>
678   name)
679
680 (defun list-class-all-methods-named (<class> method-name)
681   (labels ((recurse (c)
682              (append (list-class-methods-named c method-name)
683                      (iter (for super in (list-qclass-superclasses c))
684                        (appending (recurse super))))))
685     (recurse <class>)))
686
687 (let ((unconst-table (make-hash-table)))
688   (defun qtype-deconstify (<type>)
689     (or (gethash <type> unconst-table)
690         (setf (gethash <type> unconst-table)
691               (let ((type-name (qtype-name <type>)))
692                 (if (and (alexandria:starts-with-subseq "const " type-name)
693                          (alexandria:ends-with #\& type-name))
694                     (or (find-qtype (subseq type-name 6 (1- (length type-name))))
695                         <type>)
696                     <type>))))))
697
698 (let ((qlist-element-table (make-hash-table)))
699   (defun qlist-element-type (<type>)
700     (multiple-value-bind (result present-p)
701         (gethash <type> qlist-element-table)
702       (if present-p
703           result
704           (setf (gethash <type> qlist-element-table)
705                 (let ((type-name (qtype-name (qtype-deconstify <type>))))
706                   (cond ((string= type-name "QStringList")
707                          (find-qtype "QString"))
708                         ((and (alexandria:starts-with-subseq "QList<" type-name)
709                               (alexandria:ends-with #\> type-name))
710                          (find-qtype (subseq type-name 6 (1- (length type-name)))))
711                         (t nil))))))))
712
713 ;;;;
714 ;;;; Utilities
715 ;;;;
716
717 (defun qapropos (str)
718   (setf str (string-upcase str))
719   (map-classes (lambda (<class>)
720                  (let ((name (qclass-name <class>)))
721                    (when (search str (string-upcase name))
722                      (format t "Class ~A~%" name)))))
723   (map-methods (lambda (<method>)
724                  (when (search str (string-upcase (qmethod-name <method>)))
725                    (format t "Method ~A~%" (qmethod-fancy-name <method>))))))
726
727 (defun find-qclass-ignoring-case (str)
728   (block nil
729     (map-classes
730      (lambda (<class>)
731        (when (string-equal (qclass-name <class>) str)
732          (return <class>))))))
733
734 (defun qmethod-dotted-name (<method>)
735   (format nil "~A::~A"
736           (qclass-name (qmethod-class <method>))
737           (qmethod-name <method>)))
738
739 (defun qmethod-fancy-name (<method>)
740   (format nil "~A::~A [~D]"
741           (qclass-name (qmethod-class <method>))
742           (qmethod-name <method>)
743           (unbash <method>)))
744
745 (defun find-dotted-qmethods (str)
746   (let ((result '()))
747     (map-methods
748      (lambda (method)
749        (when (and method (string-equal (qmethod-dotted-name method) str))
750          (push method result))))
751     result))
752
753 (defun describe-methodmap (<methodmap>)
754   (format t "~/qt:format-reference/ is a MethodMap~%~%" <methodmap>)
755   (format t "    name: ~A~%" (methodmap-name <methodmap>))
756   (let ((<class> (methodmap-class <methodmap>)))
757     (format t "    for class: ~A (~A)~%" (qclass-name <class>) <class>))
758   (format t "~%Methods:~%")
759   (describe-methodmap-methods <methodmap>))
760
761 (defun describe-qtype (<type>)
762   (format t "~/qt:format-reference/ is a type~%~%" <type>)
763   (format t "    name: ~A~%" (qtype-name <type>))
764   ;; ...
765   )
766
767 (defun describe-methodmap-methods (<methodmap>)
768   (let ((methods (list-methodmap-methods <methodmap>)))
769     (cond
770      ((null methods)
771       ;; fixme?
772       )
773      ((cdr methods)
774       (format t "    ~A~30Tambiguous:~%"
775               (methodmap-name <methodmap>))
776       (dolist (method methods)
777         (format t "    ~34T~A:~%"
778                 (qmethod-fancy-name method))))
779      (t
780       (format t "    ~A~30T~A~%"
781               (methodmap-name <methodmap>)
782               (qmethod-fancy-name (car methods)))))))
783
784 (defun describe-qclass-methods (class)
785   (dolist (<methodmap> (list-qclass-methodmaps class))
786     (describe-methodmap-methods <methodmap>)))
787
788 (defun describe-qclass (<class> &optional inherited)
789   (format t "~/qt:format-reference/ is a smoke class~%~%" <class>)
790   (format t "    name: ~A~%" (qclass-name <class>))
791   (format t "    flags: #x~X (~{~A~^, ~})~%"
792           (qclass-flags <class>)
793           (list-qclass-flags <class>))
794   (format t "~%Superclasses:~%")
795   (if (list-qclass-superclasses <class>)
796       (labels ((recurse (c indent)
797                  (dolist (d (list-qclass-superclasses c))
798                    (format t "~vT~A~%" indent (qclass-name d))
799                    (recurse d (+ indent 4)))))
800         (recurse <class> 4))
801       (format t "    (none)~%"))
802   (format t "~%Methods:~%")
803   (describe-qclass-methods <class>)
804   (let ((superclasses (list-qclass-superclasses <class>)))
805     (when superclasses
806       (cond
807         (inherited
808          (format t "~%Inherited methods:~%")
809          (labels ((recurse (c)
810                     (dolist (d (list-qclass-superclasses c))
811                       (describe-qclass-methods d)
812                       (recurse d))))
813            (recurse <class>)))
814         (t
815          (format t "~%Use (QDESCRIBE ~S T) to see inherited methods.~%"
816                  (qclass-name <class>))))))
817   (describe-qclass-properties <class> inherited))
818
819 (defun describe-qmethod (method)
820   (format t "~/qt:format-reference/ is a smoke method~%" method)
821   (format t "    class: ~A~%" (qmethod-class method))
822   (format t "    name: ~A~%" (qmethod-name method))
823   (format t "    return type: ~A~%" (qmethod-return-type method))
824   (format t "    flags: #x~X (~{~A~^, ~})~%"
825           (qmethod-flags method)
826           (list-qmethod-flags method))
827   (format t "  argument types:~%")
828   (if (list-qmethod-argument-types method)
829       (dolist (<type> (list-qmethod-argument-types method))
830         (format t "    ~A~%" (qtype-name <type>)))
831       (format t "    (none)~%")))
832
833 (defun class-reference-p (x)
834   (multiple-value-bind (id <module> kind) (unbash x)
835     (and (eql kind +class+)
836          (<= 0 <module> (1- *n-modules*))
837          (<= 0 id (data-nclasses (data-ref <module>))))))
838
839 (defun method-reference-p (x)
840   (multiple-value-bind (id <module> kind) (unbash x)
841     (and (eql kind +method+)
842          (<= 0 <module> (1- *n-modules*))
843          (<= 0 id (data-nmethods (data-ref <module>))))))
844
845 (defun methodmap-reference-p (x)
846   (multiple-value-bind (id <module> kind) (unbash x)
847     (and (eql kind +methodmap+)
848          (<= 0 <module> (1- *n-modules*))
849          (<= 0 id (data-nmethodmaps (data-ref <module>))))))
850
851 (defun type-reference-p (x)
852   (multiple-value-bind (id <module> kind) (unbash x)
853     (and (eql kind +type+)
854          (<= 0 <module> (1- *n-modules*))
855          (<= 0 id (data-ntypes (data-ref <module>))))))
856
857 (defun qdescribe (thing &optional inherited)
858   (etypecase thing
859     (integer
860      (cond
861        ((class-reference-p thing) (describe-qclass thing))
862        ((method-reference-p thing) (describe-qmethod thing))
863        ((type-reference-p thing) (describe-qtype thing))
864        ((methodmap-reference-p thing) (describe-methodmap thing))
865        (t (format t "Unknown object: ~A~%" thing))))
866     (string
867      (let ((newlinep nil))
868        (let ((class (find-qclass-ignoring-case thing)))
869          (when class
870            (setf newlinep t)
871            (describe-qclass class inherited)))
872        (dolist (method (find-dotted-qmethods thing))
873          (if newlinep
874              (terpri)
875              (setf newlinep t))
876          (describe-qmethod method))))
877     (null-qobject
878      (format t "~A is a null pointer~%" thing))
879     (qobject
880      (describe-qobject thing))))
881
882 ;;;; Startup stuff
883
884
885 (defvar *weakly-cached-objects*)
886 (defvar *strongly-cached-objects*)
887 (defvar *keep-alive*)
888 (defvar *qobject-metaobject* nil)
889 (defvar *smoke-instance-list* (list nil nil))
890 (defvar *smoke-instances-by-pointer*)
891
892 (defun reload ()
893   (setf *n-modules* 0)
894   (fill *module-table* nil)
895   (fill *module-data-table* nil)
896   (setf *weakly-cached-objects* (tg:make-weak-hash-table :weakness :value))
897   (setf *strongly-cached-objects* (make-hash-table))
898   (setf *keep-alive* (make-hash-table :test #'eq))
899   (setf *qobject-metaobject* nil)
900   (unless *library-loaded-p*
901     (load-libcommonqt))
902   (setf *loaded* t))
903
904 (defun ensure-loaded ()
905   (unless *loaded*
906     (reload)))
907
908 (defun ensure-smoke (name)
909   (ensure-loaded)
910   (let ((name (string-downcase name)))
911     (unless (named-module-number name)
912       (let ((idx *n-modules*))
913         (unless (< idx (length *module-table*))
914           (error "Sorry, +module-bits+ exceeded"))
915         (cffi:load-foreign-library
916         (format nil
917                 #+darwin "libsmoke~A.dylib"
918                 #+(or mswindows windows win32) "smoke~A.dll"
919                 #-(or mswindows windows win32 darwin) "libsmoke~A.so"
920                 name))
921         (let ((init (cffi:foreign-symbol-pointer
922                      (format nil "init_~A_Smoke" name))))
923           (assert init)
924           (cffi:foreign-funcall-pointer init () :void))
925         (let ((smoke-struct
926                (cffi:mem-ref (cffi:foreign-symbol-pointer
927                               (format nil "~A_Smoke" name))
928                              :pointer))
929               (data (cffi:foreign-alloc '|struct SmokeData|)))
930           (setf (svref *module-table* idx) smoke-struct)
931           (setf (svref *module-data-table* idx) data)
932           (sw_smoke smoke-struct
933                     data
934                     (cffi:callback deletion-callback)
935                     (cffi:callback method-invocation-callback)
936                     (cffi:callback child-callback)))
937         (incf *n-modules*)
938         idx))))
939
940 (defun unload ()
941   (setf *loaded* nil))
942
943 ;;; core image workarounds
944
945 (defvar *ffi-fasl-pathname* nil)
946
947 (defun rebirth ()
948   #+ccl
949   (load (or *ffi-fasl-pathname*
950             (compile-file-pathname
951              (merge-pathnames
952               "ffi.lisp"
953               (asdf:component-pathname (asdf:find-system :qt)))))))