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 NOTE
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46 mu_convert:
47 convert_data:
48 proc (a_source_ptr, a_source_desc_ptr, a_target_ptr, a_target_desc_ptr,
49 a_code);
50
51
52
53
54
55
56
57
58
59
60 %page;
61 a_code = 0;
62 source_ptr = a_source_ptr;
63 source_desc_ptr = a_source_desc_ptr;
64 target_ptr = a_target_ptr;
65 target_desc_ptr = a_target_desc_ptr;
66
67 target_type =
68 2 * target_desc_ptr -> descriptor.type
69 + fixed (target_desc_ptr -> descriptor.packed);
70
71 if target_desc_ptr -> descriptor.type >= 19
72 & target_desc_ptr -> descriptor.type <= 22 then
73 target_length = fixed (string (target_desc_ptr -> descriptor.size));
74 else do;
75 target_len.scale =
76 addr (target_desc_ptr -> descriptor.scale) -> signed_scale;
77 target_len.precision = fixed (target_desc_ptr -> descriptor.precision);
78 end;
79
80 source_type =
81 2 * source_desc_ptr -> descriptor.type
82 + fixed (source_desc_ptr -> descriptor.packed);
83
84 if source_desc_ptr -> descriptor.type >= 19
85 & source_desc_ptr -> descriptor.type <= 22 then
86 source_length = fixed (string (source_desc_ptr -> descriptor.size));
87 else do;
88 source_len.scale =
89 addr (source_desc_ptr -> descriptor.scale) -> signed_scale;
90 source_len.precision = fixed (source_desc_ptr -> descriptor.precision);
91 end;
92 ^L
93 on any_other
94 begin;
95
96 call find_condition_info_ ((null), addr (cond_info), a_code);
97 do cond_idx = 1 to 7
98 while (cond_info.condition_name ^= cond_name (cond_idx));
99 end;
100 if cond_idx > 7 then
101 call continue_to_signal_ (a_code);
102
103 goto COND (cond_idx);
104
105 COND (1):
106 a_code = mrds_error_$size_condition;
107 goto EXIT;
108
109 COND (2):
110 a_code = mrds_error_$conversion_condition;
111 goto EXIT;
112
113
114 COND (3):
115 a_code = mrds_error_$fixedoverflow_condition;
116 goto EXIT;
117
118 COND (4):
119 a_code = mrds_error_$error_condition;
120 goto EXIT;
121
122 COND (5):
123 a_code = mrds_error_$illegal_procedure_condition;
124 goto EXIT;
125
126 COND (6):
127 a_code = mrds_error_$overflow_condition;
128 goto EXIT;
129
130 COND (7):
131 a_code = mrds_error_$underflow_condition;
132 goto EXIT;
133
134 COND (8):
135 call continue_to_signal_ (a_code);
136
137
138 end;
139
140
141 call
142 assign_round_ (target_ptr, target_type, target_length, source_ptr,
143 source_type, source_length);
144
145 EXIT:
146 return;
147 ^L
148
149
150 dcl a_source_ptr ptr;
151 dcl a_source_desc_ptr ptr;
152 dcl a_target_ptr ptr;
153 dcl a_target_desc_ptr ptr;
154 dcl a_code fixed bin (35);
155
156
157
158 dcl source_desc_ptr ptr;
159 dcl target_desc_ptr ptr;
160
161 dcl source_ptr ptr;
162 dcl target_ptr ptr;
163
164 dcl source_type fixed bin;
165 dcl target_type fixed bin;
166 dcl cond_idx fixed bin;
167
168 dcl source_length fixed bin (35);
169
170 dcl 1 source_len aligned based (addr (source_length)),
171 2 scale fixed bin (17) unal,
172 2 precision fixed bin (17) unal;
173
174 declare signed_scale fixed bin (11) unal based;
175
176 dcl target_length fixed bin (35);
177
178 dcl 1 target_len aligned based (addr (target_length)),
179 2 scale fixed bin (17) unal,
180 2 precision fixed bin (17) unal;
181
182 dcl 1 cond_info aligned,
183 2 mc_ptr ptr,
184 2 version fixed bin,
185 2 condition_name char (32) varying,
186 2 info_ptr ptr,
187 2 wc_ptr ptr,
188 2 loc_ptr ptr,
189 2 flags aligned,
190 3 crawlout bit (1) unal,
191 3 mbz1 bit (35) unal,
192 2 mbz2 bit (36) aligned,
193 2 user_loc_ptr ptr,
194 2 mbz (4) bit (36) aligned;
195
196 dcl cond_name (7) char (32) varying int static options (constant)
197 init ("size", "conversion", "fixedoverflow", "error",
198 "illegal_procedure", "overflow", "underflow");
199
200
201
202 dcl (addr, fixed, null, string) builtin;
203
204
205
206 dcl assign_round_
207 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
208 dcl find_condition_info_ entry (ptr, ptr, fixed bin (35));
209 dcl continue_to_signal_ entry (fixed bin (35));
210
211
212
213 dcl (
214 mrds_error_$conversion_condition,
215 mrds_error_$error_condition,
216 mrds_error_$fixedoverflow_condition,
217 mrds_error_$illegal_procedure_condition,
218 mrds_error_$overflow_condition,
219 mrds_error_$size_condition,
220 mrds_error_$underflow_condition
221 ) ext fixed bin (35);
222 dcl any_other condition;
223
224 %include mdbm_descriptor;
225
226 end mu_convert;