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 Note
31
32
33
34
35
36
37
38
39
40
41
42
43
44 decevl_:
45 procedure (rslts, type) returns (fixed bin (35));
46
47 declare rslts (10) fixed bin (35);
48 declare type fixed bin (26);
49
50
51
52 declare 1 attr,
53 2 binary bit (1),
54 2 double bit (1),
55 2 float bit (1);
56 declare binpt fixed bin (26);
57 declare buffer char (64);
58 declare double bit (1) aligned;
59 declare first bit (1) aligned;
60 declare next_sw bit (1) aligned;
61 declare prec fixed bin (35);
62 declare saw_point bit (1) aligned;
63 declare scale fixed bin (26);
64 declare 1 x_structure aligned, NOTE
65 2 pad1_for_alignment fixed bin (71),
66 2 x (3) fixed bin (26);
67 declare xp fixed bin (26);
68
69
70
71 declare 1 brk_overlay aligned based (addr (brk (2))),
72 2 skip char (3) unal,
73 2 ch char (1) unal;
74 declare 1 number aligned based (addr (buffer)),
75 2 sign char (1) unal,
76 2 digit (prec) char (1) unal,
77 2 skip bit (1) unal,
78 2 exponent fixed bin (7) unal;
79
80
81
82 declare (addr, byte, divide, length, max, min, rank, string, substr, unspec)
83 builtin;
84
85
86
87 declare (overflow, size) condition;
88
89
90
91 declare eb_data_$iasc fixed bin (35) external static;
92 declare eb_data_$iflt fixed bin (35) external static;
93 declare eb_data_$ifxd fixed bin (35) external static;
94 declare eb_data_$iint fixed bin (35) external static;
95
96
97
98 declare assign_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
99 declare inputs_$ascii_literal entry;
100 declare inputs_$next entry;
101 declare inputs_$nxtnb entry;
102 ^L
103 %include varcom;
104 %include erflgs;
105 %include codtab;
106 %include std_descriptor_types;
107 ^L
108
109
110 double = ""b;
111 xp = 0;
112 saw_point = "0"b;
113 string (attr) = ""b;
114 first = "1"b;
115 prec = 0;
116 scale = 0;
117 binpt = 71;
118 number.sign = "+";
119
120 on overflow, size goto return_from_size;
121
122
123
124
125 do while ("1"b);
126 next_sw = "1"b;
127
128 if brk (1) = inum
129 then do;
130 if attr.float
131 then scale = scale + 1;
132
133 prec = prec + 1;
134 number.digit (prec) = ch;
135 end;
136
137 else if brk (1) = ipoint
138 then do;
139 saw_point = "1"b;
140 attr.float = "1"b;
141 end;
142
143 else if brk (1) = iminus
144 then number.sign = "-";
145
146 else if brk (1) = iplus
147 then ;
148
149 else
150 label_220:
151 if brk (1) = ilet
152 then begin;
153 declare char char (1) aligned;
154
155
156
157 char = byte (brk (2));
158
159 if char = "a" & ^attr.binary & ^attr.float & number.sign ^= "-"
160 then begin;
161 declare chars char (32);
162 declare i fixed bin;
163 declare word_count fixed bin;
164
165 declare char_array (8) char (4) defined (chars);
166
167
168
169 call assign_ (addr (x (1)), 2 * real_fix_bin_2_dtype, 71, addr (buffer),
170 2 * real_fix_dec_9bit_ls_dtype, prec);
171
172 type = eb_data_$iasc;
173 x (2) = min (x (2), length (chars));
174 word_count = max (divide (x (2) + 3, 4, 17), 1);
175 unspec (chars) = ""b;
176
177 do i = 1 to x (2);
178 call inputs_$ascii_literal;
179 substr (chars, i, 1) = byte (brk (2));
180 end;
181
182 do i = 1 to word_count;
183 unspec (rslts (i)) = unspec (char_array (i));
184 end;
185
186 call inputs_$next;
187
188 return (word_count);
189 end;
190
191 else if char = "b" & ^attr.binary
192 then do;
193 attr.binary = "1"b;
194 binpt = evaluate_integer_field ();
195 end;
196
197 else if char = "L" & ^double
198 then do;
199 call inputs_$next;
200 double = "1"b;
201 end;
202 else do;
203 if char = "d"
204 then attr.double = "1"b;
205
206 else if char ^= "e"
207 then prnte = 1;
208
209 attr.float = "1"b;
210 xp = evaluate_integer_field ();
211 end;
212
213 goto label_220;
214 end;
215
216 else if ^first
217 then do;
218
219
220
221
222 if ^attr.binary & ^attr.float
223 then do;
224 type = eb_data_$iint;
225 call assign_ (addr (x (1)), 2 * real_fix_bin_2_dtype, 71, addr (buffer),
226 2 * real_fix_dec_9bit_ls_dtype, prec);
227
228
229
230 if double then do;
231 rslts (1) = x (1);
232 rslts (2) = x (2);
233 return (2);
234 end;
235
236
237
238 rslts (1) = x (2);
239
240 return (1);
241 end;
242
243 number.exponent = xp - scale;
244
245 if attr.binary
246 then do;
247 type = eb_data_$ifxd;
248
249 if prnte ^= 1
250 then call assign_ (addr (x (1)), 2 * real_fix_bin_2_dtype, (71 - binpt) * 1f18b + 71,
251 addr (buffer), 2 * real_flt_dec_9bit_dtype, prec);
252 end;
253
254 else do;
255 type = eb_data_$iflt;
256 call assign_ (addr (x (1)), 2 * real_flt_bin_2_dtype, 63, addr (buffer),
257 2 * real_flt_dec_9bit_dtype, prec);
258 end;
259
260 rslts (1) = x (1);
261 rslts (2) = x (2);
262
263 if attr.double
264 then return (2);
265 else return (1);
266 end;
267
268 else do;
269 call inputs_$nxtnb;
270 next_sw = "0"b;
271 end;
272
273 if next_sw
274 then call inputs_$next;
275
276 first = "0"b;
277 end;
278
279
280
281
282
283
284
285
286 return_from_size:
287 prnte = 1;
288 type = eb_data_$iint;
289 rslts (1) = 0;
290
291 return (1);
292 ^L
293 evaluate_integer_field:
294 procedure returns (fixed bin (26));
295
296 declare int fixed bin (26);
297 declare sign fixed bin;
298
299 sign = 1;
300 int = 0;
301 first = "0"b;
302
303 call inputs_$next;
304 do while (brk (1) = iplus | brk (1) = iminus | brk (1) = inum);
305 if brk (1) = iminus
306 then sign = -1;
307
308 else if brk (1) = inum
309 then int = 10 * int + brk (2) - rank ("0");
310
311 call inputs_$next;
312 end;
313
314 return (sign * int);
315 end evaluate_integer_field;
316
317 end decevl_;