repos
/
commonqt
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Cleanup
Annotate for file /src/signal-slot.lisp
2009-07-24 tobias
1
;;; Copyright (c) 2009 Tobias Rautenkranz
2009-07-02 tobias
2
;;; Copyright (c) 2009 David Lichteblau. All rights reserved.
17:34:07 '
3
'
4
;;; Redistribution and use in source and binary forms, with or without
'
5
;;; modification, are permitted provided that the following conditions
'
6
;;; are met:
'
7
;;;
'
8
;;; * Redistributions of source code must retain the above copyright
'
9
;;; notice, this list of conditions and the following disclaimer.
'
10
;;;
'
11
;;; * Redistributions in binary form must reproduce the above
'
12
;;; copyright notice, this list of conditions and the following
'
13
;;; disclaimer in the documentation and/or other materials
'
14
;;; provided with the distribution.
'
15
;;;
'
16
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
'
17
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
'
18
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
'
19
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
'
20
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
'
21
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
'
22
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
'
23
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
'
24
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
'
25
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
'
26
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'
27
'
28
(in-package :cl-smoke.commonqt)
'
29
'
30
(defclass class-info ()
'
31
((key :initarg :key
'
32
:accessor entry-key)
'
33
(value :initarg :value
'
34
:accessor entry-value)))
'
35
'
36
(defclass slot-or-signal ()
'
37
((name :initarg :name
'
38
:accessor entry-name)
'
39
(full-name :initarg :full-name
'
40
:accessor entry-full-name)
'
41
(arg-types :initarg :arg-types
'
42
:accessor entry-arg-types)
'
43
(reply-type :initarg :reply-type
'
44
:accessor entry-reply-type)))
'
45
'
46
(defun make-slot-or-signal (signature)
'
47
(let ((signature (#_data
'
48
(#_normalizedSignature "QMetaObject" signature))))
'
49
(cl-ppcre:register-groups-bind
'
50
(a b c d)
'
51
("^(([\\w,<>:]*)\\s+)?([^\\s]*)\\((.*)\\)" signature)
'
52
(declare (ignore a))
'
53
(make-instance 'slot-or-signal
'
54
:name c
'
55
:full-name (concatenate 'string c "(" d ")")
'
56
:arg-types d
'
57
:reply-type (if (or (null b) (equal b "void")) "" b)))))
'
58
'
59
(defconstant +access-protected+ #x01)
'
60
(defconstant +access-public+ #x02)
'
61
(defconstant +method-signal+ #x04)
'
62
(defconstant +method-slot+ #x08)
'
63
'
64
(cffi:defcstruct qmeta-object
'
65
"QMetaObject (a POD struct)"
'
66
(super-data :pointer)
'
67
(string-data :pointer)
'
68
(data :pointer)
'
69
(extra-data :pointer))
'
70
'
71
(defun make-metaobject (parent class-name class-infos signals slots)
'
72
(let ((data (make-array 0 :fill-pointer 0 :adjustable t))
'
73
(table (make-hash-table))
'
74
(stream (make-string-output-stream)))
'
75
(labels ((intern-string (s)
'
76
(or (gethash s table)
'
77
(setf (gethash s table)
'
78
(prog1
'
79
(file-position stream)
'
80
(write-string s stream)
'
81
(write-char (code-char 0) stream)))))
'
82
(add (x) (vector-push-extend x data))
'
83
(add-string (s) (add (intern-string s))))
'
84
(add 1) ;revision
'
85
(add (intern-string class-name)) ;class name
'
86
(add (length class-infos)) ;classinfo
'
87
(add (if (plusp (length class-infos)) 10 0))
'
88
(add (+ (length signals) (length slots)))
'
89
(add (+ 10 (* 2 (length class-infos)))) ;methods
'
90
(add 0) ;properties
'
91
(add 0)
'
92
(add 0) ;enums/sets
'
93
(add 0)
'
94
(dolist (entry class-infos)
'
95
(add-string (entry-key entry))
'
96
(add-string (entry-value entry)))
'
97
(dolist (entry signals)
'
98
(add-string (entry-full-name entry))
'
99
(add-string (remove #\, (entry-full-name entry) :test-not #'eql))
'
100
(add-string (entry-reply-type entry))
'
101
(add-string "") ;tag
'
102
(add (logior +method-signal+ +access-protected+)))
'
103
(dolist (entry slots)
'
104
(add-string (entry-full-name entry))
'
105
(add-string (remove #\, (entry-full-name entry) :test-not #'eql))
'
106
(add-string (entry-reply-type entry))
'
107
(add-string "") ;tag
'
108
(add (logior +method-slot+ +access-public+)))
'
109
(add 0))
'
110
(let ((dataptr (cffi:foreign-alloc :int :count (length data))))
'
111
(dotimes (i (length data))
'
112
(setf (cffi:mem-aref dataptr :int i) (elt data i)))
'
113
(let ((meta-struct (cffi:foreign-alloc 'qmeta-object))
'
114
(parent-meta-object (#_staticMetaObject parent)))
'
115
(setf (foreign-slot-value meta-struct 'qmeta-object 'super-data)
'
116
(smoke:pointer parent-meta-object)
'
117
'
118
(foreign-slot-value meta-struct 'qmeta-object 'string-data)
'
119
(foreign-string-alloc (get-output-stream-string stream))
'
120
'
121
(foreign-slot-value meta-struct 'qmeta-object 'data)
'
122
dataptr
'
123
'
124
(foreign-slot-value meta-struct 'qmeta-object 'extra-data)
'
125
(null-pointer))
'
126
(let ((meta-object (make-instance 'cl-smoke.qt:meta-object
'
127
:pointer meta-struct)))
'
128
'
129
;; PARENT-META-OBJECT must remain valid during the lifetime
'
130
;; of META-OBJECT.
'
131
(push parent-meta-object (smoke::owned-objects meta-object))
'
132
meta-object)))))