1
2
3
4
5
6
7
8
9
10
11 reserve$declare_lib: proc(number) returns(ptr);
12
13 dcl (p,q,s) ptr,
14 (error_number,i,k,m,n,number) fixed bin(15),
15 test_string char(20) varying aligned,
16
17 (declared_array,renamed_array) bit(216) aligned int static,
18 parallel_ptr_number fixed bin(15) int static,
19 parallel_ptr(40) ptr int static,
20
21 pl1_stat_$use_old_area bit(1) aligned ext static,
22
23 pl1_stat_$root ptr ext static;
24
25 dcl (addr,length,null,substr) builtin;
26
27 %include language_utility;
28 %include boundary;
29 %include declare_type;
30 %include op_codes;
31 %include operator;
32 %include parameter;
33 %include reference;
34 %include symbol;
35 %include system;
36 %include token;
37 %include token_list;
38 %include token_types;
39 ^L
40 p=reserve$read_lib(number);
41
42 if substr(declared_array,number,1)
43 then do;
44 s=p->token.declaration;
45 do while(s->symbol.block_node^=pl1_stat_$root);
46 s=s->symbol.multi_use;
47 if s=null then goto dcl_entry;
48 end;
49
50 return(s->symbol.reference);
51 end;
52
53 dcl_entry:
54 substr(declared_array,number,1)="1"b;
55 s=create_symbol(pl1_stat_$root,p,by_compiler);
56 s->symbol.boundary=mod2_;
57 s->symbol.allocate ,
58 s->symbol.entry ,
59 s->symbol.constant ,
60 s->symbol.external ,
61 s->symbol.irreducible = "1"b;
62
63 return(s->symbol.reference);
64
65 read_lib: entry(number) returns(ptr);
66
67 if substr(renamed_array,number,1)
68 then do;
69 test_string=reserved_name(number);
70 m=length(test_string);
71 do i=1 to 39 by 2;
72 p=parallel_ptr(i);
73 n=p->token.size;
74 if m=n
75 then if p->token.string=test_string
76 then do;
77 p=parallel_ptr(i+1);
78 goto read_lib_ret;
79 end;
80 if n=2*m+1
81 then if p->token.string=substr(test_string,1,m)||"$"||substr(test_string,1,m)
82 then do;
83 p=parallel_ptr(i+1);
84 goto read_lib_ret;
85 end;
86 end;
87 end;
88 else p=create_token((reserved_name(number)),identifier);
89
90 read_lib_ret:
91 return(p);
92
93 reserve$clear: entry returns(ptr);
94
95 parallel_ptr_number=0;
96 declared_array ,
97 renamed_array = "0"b;
98
99 return(null);
100 ^L
101 dcl number_of_reserved_names fixed bin(15) int static initial(200),
102 reserved_name(200) char(20) varying aligned int static init
103 ( "free_$free_",
104 "stat_",
105 "area_",
106 "system_condition_",
107 "alloc_",
108 "bound_",
109 "on_data_$get_onloc",
110 "on_data_$get_onfield",
111 "on_data_$get_onchar",
112 "on_data_$get_oncode",
113 "on_data_$set_onchar",
114 "on_data_$get_onfile",
115 "on_data_$get_onkey",
116 "on_data_$getonsource",
117 "datmk_",
118 "snap_",
119 "xp2_",
120 "dxp1_",
121 "cxp1_",
122 "dcxp1_",
123 "xp3_",
124 "dxp2_",
125 "cxp2_",
126 "dcxp2_",
127 "sqrt_",
128 "dsqrt_",
129 "csqrt_",
130 "dcsqrt_",
131 "exp_",
132 "dexp_",
133 "cexp_",
134 "dcexp_",
135 "log_",
136 "dlog_",
137 "clog_",
138 "dclog_",
139 "log_$log2_",
140 "dlog_$dlog2_",
141 "clog_$clog2_",
142 "dclog_$dclog2_",
143 "log_$log10_",
144 "dlog_$dlog10_",
145 "clog_$clog10_",
146 "dclog_$dclog10_",
147 "log_$atanh_",
148 "dlog_$datanh_",
149 "catan_$catanh_",
150 "dcatan_$dcatanh_",
151 "log_$lone_",
152 "dlog_$dlone_",
153 "clog_$clone_",
154 "dclog_$dclone_",
155 "sin_",
156 "dsin_",
157 "csin_",
158 "dcsin_",
159 "sin_$sind_",
160 "dsin_$dsind_",
161 "csin_$csind_",
162 "dcsin_$dcsind_",
163 "sin_$cos_",
164 "dsin_$dcos_",
165 "csin_$ccos_",
166 "dcsin_$dccos_",
167 "sin_$cosd_",
168 "dsin_$dcosd_",
169 "csin_$ccosd_",
170 "dcsin_$dccosd_",
171 "tan_",
172 "dtan_",
173 "csin_$ctan_",
174 "dcsin_$dctan_",
175 "tan_$tand_",
176 "dtan_$dtand_",
177 "csin_$ctand_",
178 "dcsin_$dctand_",
179 "asin_",
180 "dasin_",
181 "casin_",
182 "dcasin_",
183 "asin_$asind_",
184 "dasin_$dasind_",
185 "casin_$casind_",
186 "dcasin_$dcasind_",
187 "asin_$acos_",
188 "dasin_$dacos_",
189 "casin_$cacos_",
190 "dcasin_$dcacos_",
191 "asin_$acosd_",
192 "dasin_$dacosd_",
193 "casin_$cacosd_",
194 "dcasin_$dcacosd_",
195 "asin_$atan_",
196 "dasin_$datan_",
197 "catan_",
198 "dcatan_",
199 "asin_$atand_",
200 "dasin_$datand_",
201 "catan_$catand_",
202 "dcatan_$dcatand_",
203 "atan2_",
204 "datan2_",
205 "catan2_",
206 "dcatan2_",
207 "atan2_$atand2_",
208 "datan2_$datand2_",
209 "catan2_$catand2_",
210 "dcatan2_$dcatand2_",
211 "sinh_",
212 "dsinh_",
213 "csin_$csinh_",
214 "dcsin_$dcsinh_",
215 "sinh_$cosh_",
216 "dsinh_$dcosh_",
217 "csin_$ccosh_",
218 "dcsin_$dccosh_",
219 "tanh_",
220 "dtanh_",
221 "csin_$ctanh_",
222 "dcsin_$dctanh_",
223 "asinh_",
224 "dasinh_",
225 "casin_$casinh_",
226 "dcasin_$dcasinh_",
227 "asinh_$acosh_",
228 "dasinh_$dacosh_",
229 "casin_$cacosh_",
230 "dcasin_$dcacosh_",
231 "erf_",
232 "derf_",
233 "cerf_",
234 "dcerf_",
235 "erf_$erfc_",
236 "derf_$derfc_",
237 "cerf_$cerfc_",
238 "dcerf_$dcerfc_",
239 "exerfc_",
240 "dexerfc_",
241 "cexerfc_",
242 "dcexerfc_",
243 "cabs_",
244 "dcabs_",
245 "cfmp_",
246 "dcfmp_",
247 "cfdp_",
248 "dcfdp_",
249 "iexp_",
250 "round_",
251 "round_$expon_",
252 "round_$adexp_",
253 "freen_",
254 "plio_$plio_sw_",
255 "plio_$open1",
256 "plio_$close",
257 "plio_$get_value_data",
258 "plio_$put_value_data",
259 "plio_$get_value_list",
260 "plio_$put_value_list",
261 "plio_$get_value_edit",
262 "plio_$put_value_edit",
263 "area_assign_",
264 "exit_",
265 "stop_",
266 "char_to_arith_",
267 "char_to_bit_",
268 "arith_to_char_",
269 "bit_to_char_",
270 "ftnio_$init",
271 "ftnio_",
272 "ftnio_$finish",
273 "diexp_",
274 "arith_to_arith_",
275 "bit_to_arith_",
276 "arith_to_bit_",
277 "decimal_op_",
278 "multi_decimal_op_",
279 "plio2_$set_pageno",
280 "pl1_before_bit_",
281 "pl1_before_char_",
282 "translate_$trans_2_",
283 "translate_$trans_3_",
284 "complex_decimal_op_",
285 "plio2_$get_lineno",
286 "plio2_$get_pageno",
287 "pl1_valid_picture_",
288 "pl1_date_",
289 "pl1_time_",
290 "pl1_after_bit_",
291 "pl1_after_char_",
292 "pl1_decat_bit_",
293 "pl1_decat_char_",
294 "alloc_$storage_",
295 "complex_binary_op_",
296 "on_data_$setonsource",
297 "decimal_exp_",
298 "decimal_exp2_",
299 "xp22_",
300 "dxp12_",
301 "cxp12_",
302 "dcxp12_"
303 );
304 ^L
305 rename_parse: entry(number,return_bit);
306
307 dcl return_bit bit(1) aligned;
308
309 k=number+1;
310
311 if t_table.type ^= left_parn then go to error1;
312
313 l: k=k+1;
314 if t_table.type ^= left_parn then go to error1;
315
316 k=k+1;
317 if t_table.type ^= identifier then go to error2;
318
319 test_string=t_table.string;
320 do i=1 to number_of_reserved_names;
321 if reserved_name(i)=test_string then goto replace;
322 end;
323
324 go to error3;
325
326 replace:
327 if i = 1
328 | i = 3
329 | i = 5
330 | i = 151
331 | i = 192
332 then pl1_stat_$use_old_area = "1"b;
333
334 k=k+1;
335 if t_table.type ^= comma then go to error4;
336
337 k=k+1;
338 if t_table.type ^= identifier then go to error5;
339
340 parallel_ptr_number=parallel_ptr_number+2;
341 if parallel_ptr_number>40 then goto error7;
342
343 substr(renamed_array,i,1)="1"b;
344 parallel_ptr(parallel_ptr_number-1)=token_list(k-2);
345 parallel_ptr(parallel_ptr_number)=token_list(k);
346
347 k=k+1;
348 if t_table.type ^= right_parn then go to error6;
349
350 k=k+1;
351 if t_table.type = comma then go to l;
352 if t_table.type ^= right_parn then go to error6;
353
354 number=k+1;
355 return_bit="1"b;
356 return;
357
358 error1: error_number=161;
359 go to error_finish;
360
361 error2: error_number=162;
362 go to error_finish;
363
364 error3: error_number=163;
365 go to error_finish;
366
367 error4: error_number=164;
368 go to error_finish;
369
370 error5: error_number=165;
371 go to error_finish;
372
373 error6: error_number=166;
374 goto error_finish;
375
376 error7: error_number=94;
377
378 error_finish:
379 call parse_error(error_number,token_list(k));
380 return_bit="0"b;
381
382 end reserve$declare_lib;