1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  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 (         /*  1*/     "free_$free_",
104           /*  2*/     "stat_",
105           /*  3*/     "area_",
106           /*  4*/     "system_condition_",
107           /*  5*/     "alloc_",
108           /*  6*/     "bound_",
109           /*  7*/     "on_data_$get_onloc",
110           /*  8*/     "on_data_$get_onfield",
111           /*  9*/     "on_data_$get_onchar",
112           /* 10*/     "on_data_$get_oncode",
113           /* 11*/     "on_data_$set_onchar",
114           /* 12*/     "on_data_$get_onfile",
115           /* 13*/     "on_data_$get_onkey",
116           /* 14*/     "on_data_$getonsource",
117           /* 15*/     "datmk_",
118           /* 16*/     "snap_",
119           /* 17*/     "xp2_",
120           /* 18*/     "dxp1_",
121           /* 19*/     "cxp1_",
122           /* 20*/     "dcxp1_",
123           /* 21*/     "xp3_",
124           /* 22*/     "dxp2_",
125           /* 23*/     "cxp2_",
126           /* 24*/     "dcxp2_",
127           /* 25*/     "sqrt_",
128           /* 26*/     "dsqrt_",
129           /* 27*/     "csqrt_",
130           /* 28*/     "dcsqrt_",
131           /* 29*/     "exp_",
132           /* 30*/     "dexp_",
133           /* 31*/     "cexp_",
134           /* 32*/     "dcexp_",
135           /* 33*/     "log_",
136           /* 34*/     "dlog_",
137           /* 35*/     "clog_",
138           /* 36*/     "dclog_",
139           /* 37*/     "log_$log2_",
140           /* 38*/     "dlog_$dlog2_",
141           /* 39*/     "clog_$clog2_",
142           /* 40*/     "dclog_$dclog2_",
143           /* 41*/     "log_$log10_",
144           /* 42*/     "dlog_$dlog10_",
145           /* 43*/     "clog_$clog10_",
146           /* 44*/     "dclog_$dclog10_",
147           /* 45*/     "log_$atanh_",
148           /* 46*/     "dlog_$datanh_",
149           /* 47*/     "catan_$catanh_",
150           /* 48*/     "dcatan_$dcatanh_",
151           /* 49*/     "log_$lone_",
152           /* 50*/     "dlog_$dlone_",
153           /* 51*/     "clog_$clone_",
154           /* 52*/     "dclog_$dclone_",
155           /* 53*/     "sin_",
156           /* 54*/     "dsin_",
157           /* 55*/     "csin_",
158           /* 56*/     "dcsin_",
159           /* 57*/     "sin_$sind_",
160           /* 58*/     "dsin_$dsind_",
161           /* 59*/     "csin_$csind_",
162           /* 60*/     "dcsin_$dcsind_",
163           /* 61*/     "sin_$cos_",
164           /* 62*/     "dsin_$dcos_",
165           /* 63*/     "csin_$ccos_",
166           /* 64*/     "dcsin_$dccos_",
167           /* 65*/     "sin_$cosd_",
168           /* 66*/     "dsin_$dcosd_",
169           /* 67*/     "csin_$ccosd_",
170           /* 68*/     "dcsin_$dccosd_",
171           /* 69*/     "tan_",
172           /* 70*/     "dtan_",
173           /* 71*/     "csin_$ctan_",
174           /* 72*/     "dcsin_$dctan_",
175           /* 73*/     "tan_$tand_",
176           /* 74*/     "dtan_$dtand_",
177           /* 75*/     "csin_$ctand_",
178           /* 76*/     "dcsin_$dctand_",
179           /* 77*/     "asin_",
180           /* 78*/     "dasin_",
181           /* 79*/     "casin_",
182           /* 80*/     "dcasin_",
183           /* 81*/     "asin_$asind_",
184           /* 82*/     "dasin_$dasind_",
185           /* 83*/     "casin_$casind_",
186           /* 84*/     "dcasin_$dcasind_",
187           /* 85*/     "asin_$acos_",
188           /* 86*/     "dasin_$dacos_",
189           /* 87*/     "casin_$cacos_",
190           /* 88*/     "dcasin_$dcacos_",
191           /* 89*/     "asin_$acosd_",
192           /* 90*/     "dasin_$dacosd_",
193           /* 91*/     "casin_$cacosd_",
194           /* 92*/     "dcasin_$dcacosd_",
195           /* 93*/     "asin_$atan_",
196           /* 94*/     "dasin_$datan_",
197           /* 95*/     "catan_",
198           /* 96*/     "dcatan_",
199           /* 97*/     "asin_$atand_",
200           /* 98*/     "dasin_$datand_",
201           /* 99*/     "catan_$catand_",
202           /*100*/     "dcatan_$dcatand_",
203           /*101*/     "atan2_",
204           /*102*/     "datan2_",
205           /*103*/     "catan2_",
206           /*104*/     "dcatan2_",
207           /*105*/     "atan2_$atand2_",
208           /*106*/     "datan2_$datand2_",
209           /*107*/     "catan2_$catand2_",
210           /*108*/     "dcatan2_$dcatand2_",
211           /*109*/     "sinh_",
212           /*110*/     "dsinh_",
213           /*111*/     "csin_$csinh_",
214           /*112*/     "dcsin_$dcsinh_",
215           /*113*/     "sinh_$cosh_",
216           /*114*/     "dsinh_$dcosh_",
217           /*115*/     "csin_$ccosh_",
218           /*116*/     "dcsin_$dccosh_",
219           /*117*/     "tanh_",
220           /*118*/     "dtanh_",
221           /*119*/     "csin_$ctanh_",
222           /*120*/     "dcsin_$dctanh_",
223           /*121*/     "asinh_",
224           /*122*/     "dasinh_",
225           /*123*/     "casin_$casinh_",
226           /*124*/     "dcasin_$dcasinh_",
227           /*125*/     "asinh_$acosh_",
228           /*126*/     "dasinh_$dacosh_",
229           /*127*/     "casin_$cacosh_",
230           /*128*/     "dcasin_$dcacosh_",
231           /*129*/     "erf_",
232           /*130*/     "derf_",
233           /*131*/     "cerf_",
234           /*132*/     "dcerf_",
235           /*133*/     "erf_$erfc_",
236           /*134*/     "derf_$derfc_",
237           /*135*/     "cerf_$cerfc_",
238           /*136*/     "dcerf_$dcerfc_",
239           /*137*/     "exerfc_",
240           /*138*/     "dexerfc_",
241           /*139*/     "cexerfc_",
242           /*140*/     "dcexerfc_",
243           /*141*/     "cabs_",
244           /*142*/     "dcabs_",
245           /*143*/     "cfmp_",
246           /*144*/     "dcfmp_",
247           /*145*/     "cfdp_",
248           /*146*/     "dcfdp_",
249           /*147*/     "iexp_",
250           /*148*/     "round_",
251           /*149*/     "round_$expon_",
252           /*150*/     "round_$adexp_",
253           /*151*/     "freen_",
254           /*152*/     "plio_$plio_sw_",
255           /*153*/     "plio_$open1",
256           /*154*/     "plio_$close",
257           /*155*/     "plio_$get_value_data",
258           /*156*/     "plio_$put_value_data",
259           /*157*/     "plio_$get_value_list",
260           /*158*/     "plio_$put_value_list",
261           /*159*/     "plio_$get_value_edit",
262           /*160*/     "plio_$put_value_edit",
263           /*161*/     "area_assign_",
264           /*162*/     "exit_",
265           /*163*/     "stop_",
266           /*164*/     "char_to_arith_",
267           /*165*/     "char_to_bit_",
268           /*166*/     "arith_to_char_",
269           /*167*/     "bit_to_char_",
270           /*168*/     "ftnio_$init",
271           /*169*/     "ftnio_",
272           /*170*/     "ftnio_$finish",
273           /*171*/     "diexp_",
274           /*172*/     "arith_to_arith_",
275           /*173*/     "bit_to_arith_",
276           /*174*/     "arith_to_bit_",
277           /*175*/     "decimal_op_",
278           /*176*/     "multi_decimal_op_",
279           /*177*/     "plio2_$set_pageno",
280           /*178*/     "pl1_before_bit_",
281           /*179*/     "pl1_before_char_",
282           /*180*/     "translate_$trans_2_",
283           /*181*/     "translate_$trans_3_",
284           /*182*/     "complex_decimal_op_",
285           /*183*/     "plio2_$get_lineno",
286           /*184*/     "plio2_$get_pageno",
287           /*185*/     "pl1_valid_picture_",
288           /*186*/     "pl1_date_",
289           /*187*/     "pl1_time_",
290           /*188*/     "pl1_after_bit_",
291           /*189*/     "pl1_after_char_",
292           /*190*/     "pl1_decat_bit_",
293           /*191*/     "pl1_decat_char_",
294           /*192*/     "alloc_$storage_",
295           /*193*/     "complex_binary_op_",
296           /*194*/     "on_data_$setonsource",
297           /*195*/     "decimal_exp_",
298           /*196*/     "decimal_exp2_",
299           /*197*/     "xp22_",
300           /*198*/     "dxp12_",
301           /*199*/     "cxp12_",
302           /*200*/     "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            /* free_$free_      */
328           |  i = 3            /* area_            */
329           |  i = 5            /* alloc_           */
330           |  i = 151          /* freen_           */
331           |  i = 192          /* alloc_$storage   */
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;                       /* no left parn */
359           go to error_finish;
360 
361 error2:   error_number=162;                       /* Name1 is not an identifier */
362           go to error_finish;
363 
364 error3:   error_number=163;                       /* Name1 could not be matched with a reserved name. */
365           go to error_finish;
366 
367 error4:   error_number=164;                       /* No comma */
368           go to error_finish;
369 
370 error5:   error_number=165;                       /* Name2 is not an identifier. */
371           go to error_finish;
372 
373 error6:   error_number=166;                       /* No matching right parn */
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;