-
Notifications
You must be signed in to change notification settings - Fork 2
/
clorb-union.lisp
119 lines (98 loc) · 4.08 KB
/
clorb-union.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
;;;; clorb-union.lisp -- CORBA Union support
(in-package :clorb)
(defclass CORBA:UNION ()
((discriminator
:initarg :discriminator
:accessor union-discriminator)
(value
:initarg :value
:accessor union-value )))
(define-typecode union-typecode
:kind :tk_union
:cdr-syntax (complex :tk_string :tk_string :tk_typecode :tk_long
(sequence (2 :tk_string :tk_typecode)))
:params (id name discriminator_type default_index :members)
:member-params (member_label member_name member_type))
(defun create-union-tc (id name discriminator-type members)
"Create a TypeCode for union type.
members = ( (label name typecode)* )
where label = symbol clorb:default or value"
(check-type id string)
(check-type name string)
(check-type discriminator-type corba:typecode)
(setq members (coerce members 'list))
(let* ((default-index -1)
(massaged-members
(loop for (label name typecode) in members
for i from 0
do (when (eq label 'default)
(setq default-index i)
(setq label (arbritary-value discriminator-type)))
collect (list label name typecode))))
(make-typecode :tk_union id name
discriminator-type default-index
(coerce massaged-members 'vector))))
(defmethod any-typecode ((obj corba:union))
(symbol-typecode (class-name (class-of obj))))
(defmethod any-value ((obj corba:union))
obj)
;; FIXME: this is not standard, should not be in CORBA package
(defun corba:union (&key union-discriminator union-value
id typecode)
(let ((id (or id (and typecode (op:id typecode)))))
(let ((name (ifr-id-symbol id)))
(if name
(funcall name
:union-discriminator union-discriminator
:union-value union-value)
(make-instance 'corba:union
:discriminator union-discriminator
:value union-value)))))
(define-method default ((obj corba:union)) (union-value obj))
(define-method (setf default) (value (obj corba:union))
(setf (union-value obj) value))
(defun typecode-values-do (function typecode)
(case (op:kind typecode)
(:tk_char
(loop for code from 0 below char-code-limit
for char = (code-char code)
when char do (funcall function char)))
(:tk_boolean (funcall function nil) (funcall function t))
(:tk_enum (doseq (sym (tc-keywords typecode))
(funcall function sym)))
(otherwise (loop for i from 0 do (funcall function i)))))
(defmethod compute-unmarshal-function ((tc union-typecode))
(let* ((id (op:id tc))
(discriminant-type (op:discriminator_type tc))
(default-used (op:default_index tc))
(members (tc-members tc)))
(lambda (buffer)
(let* ((discriminant (unmarshal discriminant-type buffer))
(index
(do ((i 0 (1+ i)))
((or (>= i (length members))
(and (not (eql i default-used))
(eql discriminant (first (aref members i)))))
(if (>= i (length members))
default-used
i))))
(tc (third (aref members index))))
(corba:union :id id
:union-discriminator discriminant
:union-value (unmarshal tc buffer))))))
(defmethod compute-marshal-function ((tc union-typecode))
(let* ((discriminant-type (op:discriminator_type tc))
(default-used (op:default_index tc))
(members (tc-members tc)))
(lambda (union buffer)
(let* ((discriminant (union-discriminator union))
(value (union-value union))
(member (find discriminant members :key #'car)))
(when (and (null member)
(>= default-used 0))
(setq member (aref members default-used)))
(unless member
(raise-system-exception 'CORBA:MARSHAL))
(marshal discriminant discriminant-type buffer)
(marshal value (third member) buffer)))))
;;; clorb-union.lisp ends here