-
Notifications
You must be signed in to change notification settings - Fork 2
/
clorb-any.lisp
137 lines (98 loc) · 3.46 KB
/
clorb-any.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
;;;; CORBA:Any handling
(in-package :clorb)
(defclass CORBA:ANY ()
((typecode :initarg :typecode )
(value :initarg :value )))
(defgeneric any-typecode (obj))
(defgeneric any-value (obj))
(defun corba:any (&key any-typecode any-value)
(check-type any-typecode (or NULL CORBA:TypeCode))
(make-instance 'CORBA:Any
:typecode (or any-typecode (any-typecode any-value))
:value any-value))
(defmethod initialize-instance :after ((any corba:any) &key &allow-other-keys)
(unless (slot-boundp any 'typecode)
(setf (slot-value any 'typecode)
(any-typecode (slot-value any 'value)))))
(defmethod print-object ((any corba:any) stream)
(print-unreadable-object (any stream :type t)
(dolist (slot '(typecode nil value))
(cond ((null slot) (princ " " stream))
((slot-boundp any slot) (prin1 (slot-value any slot) stream))
(t (princ "?" stream))))))
(defmethod any-typecode ((obj corba:any))
(slot-value obj 'typecode))
(defmethod any-value ((obj corba:any))
(slot-value obj 'value))
(defmethod (setf any-value) (val (obj corba:any))
(setf (slot-value obj 'value) val))
(defmethod (setf any-typecode) (val (obj corba:any))
(setf (slot-value obj 'typecode) val))
;;; TypeCode accessor
(defmethod any-typecode ((obj t))
(etypecase obj
(character (if (< (char-code obj) 256) corba:tc_char corba:tc_wchar))
#+clorb-distinct-wchar-type
(corba:wchar corba:tc_wchar)
(CORBA:short CORBA:tc_short)
(CORBA:ushort CORBA:tc_ushort)
(CORBA:long CORBA:tc_long)
(CORBA:ulong CORBA:tc_ulong)
(CORBA:longlong CORBA:tc_longlong)
(CORBA:ulonglong CORBA:tc_ulonglong)
(corba:float CORBA:tc_float)
(corba:double CORBA:tc_double)
#|(corba:longdouble CORBA:tc_longdouble)|#
(corba:boolean corba:tc_boolean)))
(defun member-typecode (sequence)
(let ((max-num 0)
(min-num 0)
(non-string nil)
(non-integer nil))
(doseq (el sequence)
(setf non-string (or non-string (not (stringp el))))
(cond ((integerp el)
(setf max-num (max max-num el)
min-num (min min-num el)))
(t (setf non-integer t))))
(cond ((not non-string)
corba:tc_string)
((not non-integer)
(if (< min-num 0)
(any-typecode (- (max (- min-num) max-num)))
(any-typecode max-num)))
(t corba:tc_any))))
(defmethod any-typecode ((obj array))
(create-array-tc (length obj) (member-typecode obj)))
(defmethod any-typecode ((obj list))
(create-sequence-tc 0 (member-typecode obj)))
(defmethod any-typecode ((obj string))
CORBA:tc_string)
;;; Value accessor
(defmethod any-value ((obj number))
obj)
(defmethod any-value ((obj string))
obj)
(defmethod any-value ((obj character))
obj)
(defmethod any-value ((obj symbol))
;; ENUM
obj)
(defmethod any-value ((obj sequence))
obj)
(defmethod any-value ((obj t))
(raise-system-exception 'CORBA:BAD_PARAM))
;;;; Marshal/Unmarshal
(defun marshal-any (arg buffer)
(let ((tc (any-typecode arg)))
(marshal-typecode tc buffer)
(marshal (any-value arg) tc buffer)))
(defun unmarshal-any (buffer)
(let ((tc (unmarshal-typecode buffer)))
(if *explicit-any*
(corba:any :any-typecode tc :any-value (unmarshal tc buffer))
(unmarshal tc buffer))))
(defun marshal-any-value (any buffer)
(marshal (any-value any)
(any-typecode any)
buffer))