1
2
3
4
5 dcl (aplsv_ws_ptr, aplsv_symtab_ptr, symptr, aplsv_function_ptr, aplsv_value_ptr, code_ptr) ptr;
6 dcl (aplsv_group_ptr) ptr;
7 dcl symlen fixed bin (21);
8 dcl symtbep ptr;
9 dcl array_ptr ptr,
10 data_elements fixed bin,
11 code_len fixed bin;
12
13
14
15 dcl 1 aplsv_ws based (aplsv_ws_ptr) aligned,
16 2 pad1 (32) bit (36),
17 2 qr13stk bit (36),
18 2 qsymbot bit (36),
19 2 mx bit (36),
20 2 svi bit (36),
21 2 pad2 (21) bit (36),
22 2 library_number bit (36),
23 2 wsname aligned,
24 3 len fixed bin (8) unal,
25 3 chars char (11) unal,
26 2 man_number bit (36),
27 2 password char (8) unal,
28 2 date_saved char (8) unal,
29 2 time_saved bit (36),
30 2 pad4 (8) bit (36),
31 2 fuzz bit (36),
32 2 pad5 (2) bit (36),
33 2 index_origin bit (36),
34 2 seed bit (36),
35 2 pad6 (5) bit (36),
36 2 digits bit (36),
37 2 pad7 (126) bit (36),
38 2 printing_width bit (18) unal;
39
40 dcl 1 aplsv_symtab (1:1024) aligned based (aplsv_symtab_ptr),
41 2 type bit (9) unal,
42 2 value_offset bit (27) unal,
43 2 size fixed bin (8) unal,
44 2 name_or_offset bit (27) unal;
45
46 dcl 1 symbol_struc aligned based (symptr),
47 2 pad bit (36) unal,
48 2 size fixed bin (8) unal,
49 2 name char (1 refer (symbol_struc.size)) unal;
50
51 dcl 1 symtbe aligned based (symtbep) like aplsv_symtab;
52
53 dcl 1 aplsv_function aligned based (aplsv_function_ptr),
54 2 pad1 (2) bit (36),
55 2 pad2 bit (18) unal,
56 2 nlines fixed bin (17) unal,
57 2 nlocalvars fixed bin (17) unal,
58 2 nlabels_w_nargs fixed bin (17) unal,
59 2 pad3 bit (9) unal,
60 2 header_offset bit (27) unal,
61 2 line (1024) aligned,
62 3 flags bit (9) unal,
63 3 offset bit (27) unal;
64
65 dcl 1 aplsv_value aligned based (aplsv_value_ptr),
66 2 pad1 (2) bit (36) unal,
67 2 type bit (9) unal,
68 2 pad2 bit (9) unal,
69 2 rhorho_x4 fixed bin (17) unal,
70 2 rho (1:32) bit (36);
71
72 dcl 1 aplsv_group aligned based (aplsv_group_ptr),
73 2 pad1 (2) bit (36) aligned,
74 2 pad2 (2) bit (9) unaligned,
75 2 count fixed bin (17) unal,
76 2 symbp (0 refer (aplsv_group.count)) bit (36) aligned;
77
78 dcl 1 fun_code aligned based (code_ptr),
79 2 pad (2) bit (36) aligned,
80 2 size fixed bin (17) unal,
81 2 code (code_len refer (fun_code.size)) bit (9) unal;
82
83 dcl 1 bit_array based (array_ptr) aligned,
84 2 integral_elements dimension (data_elements/8) unaligned,
85 3 eight_nine_loss bit (1) unaligned,
86 3 data bit (8) unaligned,
87 2 tail bit (mod (data_elements, 8)) unal,
88 fixed_array bit (36) dim (data_elements) based (array_ptr) aligned,
89 float_array bit (72) dim (data_elements) based (array_ptr) aligned,
90 char_array char (data_elements) based (array_ptr);
91
92
93
94 dcl (CECONST init ("023"b3),
95 CBCONST init ("025"b3),
96 CICONST init ("027"b3),
97 CFCONST init ("031"b3),
98 CCCONST init ("033"b3),
99 CCEOT init ("0"b)) bit (9) static options (constant);
100
101 dcl (VARIABLE_TYPE init ("005"b3),
102 FUNCTION_TYPE init ("022"b3),
103 GROUP_TYPE init ("025"b3),
104 SYSTEM_VAR_TYPE init ("027"b3),
105 SYSTEM_FCN_TYPE init ("220"b3),
106 SUSP_TEMPVAR_TYPE init ("004"b3),
107 FUNCTIONZ_TYPE init ("023"b3),
108 UNUSED_TYPE init ("000"b3),
109 UNKNOWN1_TYPE init ("032"b3),
110 UNKNOWN2_TYPE init ("231"b3),
111 UNKNOWN3_TYPE init ("026"b3)
112 ) bit (9) aligned internal static options (constant);
113
114 dcl type_names (0:4) char (7) varying aligned internal static options (constant) initial (
115 "unknown", "bit", "fixed", "float", "char");
116
117 dcl (BIT_TYPE init ("001"b3),
118 FIXED_TYPE init ("002"b3),
119 FLOAT_TYPE init ("003"b3),
120 CHAR_TYPE init ("004"b3)
121 ) bit (9) aligned internal static options (constant);
122 ^L
123
124
125 cv_fb17:
126 procedure (aplsv_fb17) returns (fixed bin (17));
127
128
129
130 dcl aplsv_fb17 fixed bin (17) unaligned;
131
132
133
134 dcl fb17 fixed bin (17);
135 dcl word bit (36) aligned;
136
137
138
139 declare (binary, bit, substr, unspec) builtin;
140
141
142
143 unspec (word) = bit (binary (aplsv_fb17, 36), 36);
144 word = pack (word);
145
146 if substr (word, 5, 1) = "1"b
147 then substr (word, 1, 4) = "1111"b;
148
149 unspec (fb17) = word;
150 return (fb17);
151
152 end cv_fb17;
153 ^L
154 cv_b18:
155 procedure (aplsv_b18) returns (bit (18));
156
157
158
159 dcl aplsv_b18 bit (18) unal;
160
161
162
163 dcl b18 bit (18) aligned;
164
165
166
167 b18 = "00"b || substr (aplsv_b18, 2, 8) || substr (aplsv_b18, 11, 8);
168 return (b18);
169
170 end cv_b18;
171 ^L
172 pack:
173 procedure (aplsv_word) returns (bit (36) aligned);
174
175
176
177 dcl aplsv_word bit (36) aligned;
178
179
180
181 dcl word bit (36) aligned;
182
183
184
185 word = ""b;
186 substr (word, 5, 8) = substr (aplsv_word, 2, 8);
187 substr (word, 13, 8) = substr (aplsv_word, 11, 8);
188 substr (word, 21, 8) = substr (aplsv_word, 20, 8);
189 substr (word, 29, 8) = substr (aplsv_word, 29, 8);
190 return (word);
191
192 end pack;
193 ^L
194 cv_ascii:
195 procedure (zcode_chars) returns (char(*));
196
197
198
199 dcl zcode_chars char (*) unaligned;
200
201
202
203 dcl ascii_chars char (length (zcode_chars));
204
205
206
207 declare length builtin;
208
209
210
211 dcl ioa_ entry options (variable),
212 apl_zcode_to_ascii_ entry (char (*), char (*));
213
214
215
216 if length (zcode_chars) > length (ascii_chars)
217 then do;
218 call ioa_ ("max zcode-to-ascii length of ^d exceeded.", length (ascii_chars));
219 end;
220
221 call apl_zcode_to_ascii_ (zcode_chars, ascii_chars);
222 return (ascii_chars);
223
224 end cv_ascii;
225 ^L
226 byteptr:
227 procedure (P_aplsv_byte_address) returns (ptr);
228
229
230
231 dcl P_aplsv_byte_address bit (36) aligned;
232
233
234
235 dcl aplsv_byte_address bit (36) aligned,
236 virtual_address ptr;
237
238
239
240 dcl bytearray char (1) dim (0:1044479) based unaligned;
241
242
243
244
245
246
247 aplsv_byte_address = P_aplsv_byte_address & "000777777777"b3;
248 virtual_address = addr (aplsv_ws_ptr -> bytearray (binary (pack (aplsv_byte_address))));
249 return (virtual_address);
250
251 end byteptr;
252 ^L
253 cv_float:
254 procedure (aplsv_float) returns (float bin (63));
255
256 go to xx;
257
258 cv_floatx: entry (aplsv_float) returns (float bin (63));
259
260 word1 = "0000"b || substr (aplsv_float, 1, 32);
261 word2 = "0000"b || substr (aplsv_float, 33, 32);
262 go to yyy;
263
264
265
266 dcl aplsv_float bit (72) aligned;
267
268
269
270 dcl float_result float bin (63);
271 dcl exponent fixed bin;
272 dcl 1 mfloat aligned auto,
273 2 exp fixed bin (7) unal,
274 2 mantissa bit (64) unal;
275
276 dcl s360mant bit (56), s360exp bit (7);
277 dcl s360mantf fixed bin (56), s360expf fixed bin (7);
278
279 dcl (word1, word2) bit (36) aligned;
280
281
282
283 declare float builtin;
284
285
286
287 xx:
288 word1 = pack (substr (aplsv_float, 1, 36));
289 word2 = pack (substr (aplsv_float, 37, 36));
290
291 yyy:
292 s360mant =substr (word1, 5 + 8) || substr (word2, 5);
293 s360mantf = fixed (s360mant, 56);
294 float_result = float (s360mantf);
295 if float_result = 0e0 then return (0e0);
296 if substr (word1, 5, 1) then float_result = - float_result;
297 s360exp = substr (word1, 6, 7);
298 s360expf = fixed (s360exp, 7);
299 exponent = (s360expf -64) * 4 - 56;
300 unspec (mfloat) = unspec (float_result);
301 if mfloat.exp + exponent > 127 then do;
302 call ioa_ ("Number too large. ^f supplied.", TheBiggestNumberWeveGot);
303 call print_losing_flonum;
304 float_result = TheBiggestNumberWeveGot;
305 end;
306 else if mfloat.exp +exponent < -128 then do;
307 call ioa_ ("Number too small. ^f supplied.", TheSmallestNumberWeveGot);
308 call print_losing_flonum;
309 float_result = TheSmallestNumberWeveGot;
310 end;
311 else do;
312 mfloat.exp = mfloat.exp + exponent;
313 unspec (float_result) = unspec (mfloat);
314 end;
315 return (float_result);
316
317 print_losing_flonum: proc;
318
319 dcl flt_exponent float bin (63),
320 int_exponent fixed bin;
321 dcl (float, floor, log10) builtin;
322
323 flt_exponent = (s360expf - 64) * log10 (16e0);
324 int_exponent = floor (flt_exponent);
325 flt_exponent = flt_exponent - float (int_exponent);
326
327 call ioa_ ("Losing number = .^3.4b*16**^d = ^.5fe^d",
328 substr (s360mant, 1, 12), s360expf - 64,
329 float_result * (2e0 ** -56) * 10 ** flt_exponent,
330 int_exponent);
331 return;
332
333 end print_losing_flonum;
334 end cv_float;
335 ^L
336 cvf32: proc (bits32) returns (fixed bin (35));
337
338 dcl bits32 bit (32);
339 dcl f35 fixed bin (35) aligned;
340 if substr (bits32, 1, 1) then unspec (f35) = "1111"b || bits32;
341 else unspec (f35) = "0000"b || bits32;
342 return (f35);
343
344 end cvf32;
345
346 cvb36f32: proc (bits36) returns (fixed bin (35));
347
348 dcl bits36 bit (36) aligned;
349
350 return (fixed (pack (bits36), 35));
351
352 end cvb36f32;
353
354