-
Notifications
You must be signed in to change notification settings - Fork 2
/
idef-write.lisp
183 lines (153 loc) · 5.78 KB
/
idef-write.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
(in-package :clorb)
(defvar *idef-write-container* nil
"The innermost container beeing written by idef-write.
This guides the use of local or absolute names.")
(defvar *idef-write-default-prefix* nil)
(defmethod gen-iref ((pdef corba:primitivedef))
(ecase (op:kind pdef)
(:pk_void 'void)
(:pk_short 'short)
(:pk_long 'long)
(:pk_ushort 'ushort)
(:pk_ulong 'ulong)
(:pk_float 'float)
(:pk_double 'double)
(:pk_boolean 'boolean)
(:pk_char 'char)
(:pk_octet 'octet)
(:pk_any 'any)
(:pk_typecode 'TypeCode)
(:pk_string 'string)
(:pk_objref 'object)
(:pk_longlong 'longlong)
(:pk_ulonglong 'ulonglong)
(:pk_longdouble 'longdouble)
(:pk_wchar 'wchar)
(:pk_wstring 'wstring)))
(defmethod gen-iref ((idef corba:contained))
(if (eq (op:defined_in idef) *idef-write-container*)
(op:name idef)
(op:absolute_name idef)))
(defmethod gen-iref ((seq corba:sequencedef))
`(sequence ,(gen-iref (op:element_type_def seq))
,(op:bound seq)))
(defmethod gen-iref ((seq corba:arraydef))
`(array ,(gen-iref (op:element_type_def seq))
,(op:length seq)))
(defmethod default-repoid ((obj corba:contained) &optional prefix)
(let ((names (list ":" (op:version obj))))
(loop for c = obj then (op:defined_in c)
while (typep c 'CORBA:Contained)
unless (eq c obj) do (push "/" names)
do (push (op:name c) names))
(when prefix
(push "/" names)
(push prefix names))
(apply 'concatenate 'string
"IDL:"
names)))
(defun contained-id-info (obj)
(append
(unless (equal (op:version obj) "1.0")
(list :version (op:version obj)))
(unless (equal (op:id obj) (default-repoid obj *idef-write-default-prefix*))
(list :id (op:id obj)))))
(defmethod gen-idef ((tdef corba:aliasdef))
`(define-type ,(op:name tdef)
,(gen-iref (op:original_type_def tdef))))
;; (define-attribute "name" string :readonly t)
(defmethod gen-idef ((adef corba:attributedef))
`(define-attribute ,(op:name adef)
,(gen-iref (op:type_def adef))
,@(if (eq (op:mode adef) :attr_readonly)
'(:readonly t))
,@ (contained-id-info adef)))
(defmethod gen-idef ((odef corba:operationdef))
`(define-operation ,(op:name odef)
,(map 'list (lambda (param)
(list (op:mode param)
(op:name param)
(gen-iref (op:type_def param))))
(op:params odef))
:result-type ,(gen-iref (op:result_def odef))
:exceptions ,(map 'list 'gen-iref (op:exceptions odef))
,@ (contained-id-info odef)))
(defmethod gen-idef ((idef corba:interfacedef))
(let ((*idef-write-container* idef))
`(define-interface ,(op:name idef)
(
,@(unless (zerop (length (op:base_interfaces idef)))
(list :bases
(map 'list 'op:absolute_name (op:base_interfaces idef))))
,@(contained-id-info idef))
,@(map 'list 'gen-idef (op:contents idef :dk_all t)))))
(defmethod gen-idef ((mdef corba:moduledef))
(let ((*idef-write-container* mdef))
`(define-module ,(op:name mdef)
(,@(contained-id-info mdef))
,@(map 'list 'gen-idef (op:contents mdef :dk_all t)))))
(defmethod gen-idef ((sdef corba:structdef))
`(define-struct ,(op:name sdef)
,(map 'list
(lambda (smember)
(list (struct-get smember :name)
(gen-iref (op:type_def smember))))
(op:members sdef))
,@(contained-id-info sdef)))
(defmethod gen-idef ((enum corba:enumdef))
`(define-enum ,(op:name enum)
,(coerce (op:members enum) 'list)
,@(contained-id-info enum)))
(defmethod gen-idef ((union corba:uniondef))
`(define-union ,(op:name union)
,(gen-iref (op:discriminator_type_def union))
,(map 'list
(lambda (m)
(list (let ((label (struct-get m :label)))
(if (and (eq :tk_octet (op:kind (any-typecode label)))
(zerop (any-value label)))
'default
(any-value label)))
(struct-get m :name)
(gen-iref (op:type_def m))))
(op:members union))
,@(contained-id-info union)))
(defmethod gen-idef ((exception corba:exceptiondef))
`(define-exception ,(op:name exception)
,(map 'list
(lambda (smember)
(list (struct-get smember :name)
(gen-iref (op:type_def smember))))
(op:members exception))
,@(contained-id-info exception)))
(defmethod gen-idef ((const corba:constantdef))
`(define-constant ,(op:name const) ,(gen-iref (op:type_def const))
,(any-value (op:value const))
,@(contained-id-info const)))
(defun idef-write (obj &key default-prefix)
(let ((*idef-write-default-prefix* default-prefix))
(let ((idef
(typecase obj
(CORBA:Repository
(map 'list 'gen-idef (op:contents obj :dk_all t)))
(cons
(map 'list 'gen-idef obj))
(otherwise
(list (gen-idef obj))))))
(if default-prefix
`((with-prefix ,default-prefix
,@idef))
idef))))
(defun idef-file (obj file &key default-prefix)
(let* ((idef (idef-write obj :default-prefix default-prefix)))
(with-open-file (output file :direction :output
:if-exists :supersede)
(loop for x in (list '(in-package :clorb)
(cons 'idef-definitions idef))
do (pprint x output)))
(length idef)))
#|
(idef-file (op:lookup (vsns-get "ir") "CORBA") "clorb:src;ifr-idl.lisp" :default-prefix "omg.org")
(idef-file (get-ir) "clorb:src;x-all-idl.lisp")
(idef-file (op:lookup (get-ir) "CosNaming") "clorb:src;x-cosnaming-idl.lisp" :default-prefix "omg.org")
|#