1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 litevl_:
 14           procedure (ad, admod, txtern);
 15 
 16 /* Modified 740820 by PG to fix ancient bug (from the FORTRAN version, apparently) whereby
 17    parameters of the itsevl and itbevl entries were used as temporaries by the code of other entries! */
 18 /*        Modified on 08/06/73 at 12:56:08 by R F Mabee.
 19           by R F Mabee in June 1973 to add BCD literals.
 20           by R F Mabee on 22 November 1972 to allow user-defined internal symbols as base names in ITB.
 21           by R F Mabee on 2 November 1972 to fix bugs with parentheses around literals.
 22           by R F Mabee on 13 June 1972 to change followon pointer format and repair clobbered source.
 23           by RHG on 22 Sept 1970 to check for nl or; during aci literal
 24 */
 25 
 26 /* LITEVL:
 27           routine to evaluate literal constants in variable field. */
 28 /*        octal, decimal, and vfd literals are evaluated and tabulated */
 29 /*      litevl also checks for dl or du modifier for immediate operand. */
 30 /*      for this reason decevl (called by litevl) must return type */
 31 /*      of literal evaluated. */
 32 
 33 
 34 /* INCLUDE FILES USED BY LITEVL */
 35 
 36 % include concom;
 37 % include varcom;
 38 % include codtab;
 39 % include erflgs;
 40 % include lclit;
 41 % include alm_options;
 42 
 43 /* END OF THE INCLUDE FILES */
 44 /*^L*/
 45 
 46 /* PARAMETERS */
 47 
 48 declare xrslts (8) fixed bin(35);
 49 
 50 /* EXTERNAL ENTRIES USED BY LITEVL */
 51 
 52 declare   utils_$putach ext entry (fixed bin (26), fixed bin (26), fixed bin (26)),
 53           getbit_$getbit_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)),
 54           getid_$getid_ ext entry,
 55           inputs_$next ext entry,
 56           utils_$makins ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 57           modevl_$modevl_ ext entry (fixed bin (26)) returns (fixed bin (26)),
 58           expevl_$expevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 59           table_$table_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 60           vfdevl_$vfdevl_ ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 61           octevl_$octevl_ ext entry (fixed bin (26)) returns (fixed bin (26)),
 62           decevl_$decevl_ ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 63           utils_$ls ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 64           utils_$rs ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 65           utils_$and ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 66           glpl_$setblk ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 67           glpl_$storr ext entry (fixed bin (26), fixed bin (26)) ,
 68           glpl_$crh ext entry (fixed bin (26)) returns (fixed bin (26)),
 69           glpl_$clh ext entry (fixed bin (26)) returns (fixed bin (26)),
 70           glpl_$cwrd ext entry (fixed bin) returns (fixed bin),
 71           glpl_$glwrd ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26));
 72 
 73 
 74 /* EXTERNAL DATA USED BY LITEVL */
 75 
 76 declare   (eb_data_$jba,      eb_data_$jbi,       eb_data_$jbm,       eb_data_$jbo,
 77           eb_data_$jbv,       eb_data_$ibtb,      eb_data_$ibts,      eb_data_$iasc,
 78           eb_data_$ibtp,      eb_data_$jbh,
 79           eb_data_$ifxd,      eb_data_$iint,      eb_data_$ioct,      eb_data_$ivfd,
 80           eb_data_$imach,     eb_data_$iitb,      eb_data_$iits,      eb_data_$ierr ) ext fixed bin (35);
 81 
 82  declare  eb_data_$bcd_table (0:127) ext unaligned bit (6);
 83 
 84 declare    eb_data_$lavptr ext ptr;
 85 
 86 
 87 /* AUTOMATIC DATA USED BY LITEVL */
 88 
 89 declare    (ad,     admod,    ipair (2)) fixed bin (26);
 90 declare (ipmod,     iprht,    ipval,    j,        junk,     k,        lcptr,    nprime,   tbscl, lcptrx,
 91           txtern,    rleft, xn,         bcdlet,   type,     flags,    i,        iaddr,    ipbas ) fixed bin (26);
 92 dcl iplft fixed bin (26);
 93 declare   parentheses fixed binary;     /* Count of nesting parentheses to be paired at end. */
 94 
 95 declare   1 literal aligned,
 96           2 (block (2),rslts (8)) fixed bin (26);
 97 
 98 declare    n fixed bin (26) defined block (2);
 99 
100 declare   its_or_itb_entry bit (1) aligned initial ("0"b);  /* make sure it always has a good value */
101 
102 /* BASED OVERLAYS USED BY LITEVL */
103 
104 declare   1 word based aligned,
105             2 left   bit (18) unaligned,
106             2 right  bit (18) unaligned;
107 
108  declare  bcd (1:6) based unaligned bit (6);
109 
110 
111 
112 
113 /*      main entry, get next character and branch on literal type. */
114           tbscl = 0 /*FALSE*/;          /*This was not in the Fortran -- tres, tres mal code */
115           parentheses = 0;
116 label_100:
117           call inputs_$next;
118           lcptr = 0;
119           if (brk (1) = inum | brk (1) = iplus | brk (1) = iminus | brk (1) = ipoint)
120           then do;
121                     /* must be a decimal or aci literal */
122 
123                     n = decevl_$decevl_ (rslts (1), type);
124                     go to label_400;
125                end;
126 
127           if (brk (1) = ilet) then goto label_300;
128           if (brk (1) ^= ilpar) then goto label_370;
129           parentheses = parentheses + 1;
130           goto label_100;
131 
132 /*      break is letter, branch on type. */
133 label_300:
134           if (brk (2) = eb_data_$jba) then goto label_310;
135           if (brk (2) = eb_data_$jbo) then goto label_320;
136           if (brk (2) = eb_data_$jbv) then goto label_330;
137           if (brk (2) = eb_data_$jbm) then goto label_335;
138           if brk (2) = eb_data_$jbh then goto label_bcd;
139 
140           if (brk (2) ^= eb_data_$jbi) then goto label_305;
141           call getid_$getid_;
142           if (brk (1) ^= ilpar) then goto label_370;
143           parentheses = parentheses + 1;
144           if (sym (1) = eb_data_$ibtb) then goto label_340;
145           if (sym (1) = eb_data_$ibts) then goto label_355;
146           if sym (1) = eb_data_$ibtp then goto label_340;
147 label_305:
148           goto label_370;
149 
150 /*      routine for aci literal. */
151 label_310:
152           n = 1;
153           type = eb_data_$iasc;
154           rslts (1) = 0;
155           do i = 1 to 4;
156                call inputs_$next;
157                if brk (1) = inl then goto label_400;
158                call utils_$putach (rslts (1),i,brk (2));
159           end;
160 
161           call inputs_$next;
162           goto label_400;
163 
164 /*        routine for bcd literal. */
165 label_bcd:
166           n = 1;
167           type = eb_data_$iasc;
168           rslts (1) = 0;
169           do i = 1 to 6;
170                     call inputs_$next;
171                     if brk (1) = inl then goto label_400;
172                     addr (rslts (1)) -> bcd (i) = eb_data_$bcd_table (brk (2));
173                     end;
174           call inputs_$next;
175           goto label_400;
176 
177 /*      routine for octal literals. */
178 label_320:
179           n = octevl_$octevl_ (rslts (1));
180           type = eb_data_$ioct;
181           goto label_400;
182 
183 /*      routine for variable field literals. */
184 label_330:
185           n = vfdevl_$vfdevl_ (rslts (1),flags);
186           lcptr = flags;
187           type = eb_data_$ivfd;
188           goto label_400;
189 
190 /*      machine literals not yet coded. */
191 label_335:
192           goto label_370;
193 
194 /*      entry for itb type literal. */
195 itbevl:   entry (ipair, xrslts);
196 
197           its_or_itb_entry = "1"b;                          /* note that we came in here */
198 
199           tbscl = 1;          /*TRUE*/
200 label_340:
201           iprht = mitb;
202           type = eb_data_$iitb;
203           call getid_$getid_;
204           if (^ (sym (1) ^= 0  &  brk (1) = icomma)) then goto label_350;
205           do i = 1 to 8;
206                if (sym (1)  ^=  symbas (i)) then goto label_345;
207                iplft = 32768* (i-1);
208                goto label_360;
209 label_345:
210           end;
211 
212           if table_$table_ (iserch,sym (1),iplft,clint,junk) ^= 0 then goto label_357;
213 label_350:
214           junk = expevl_$expevl_ (0, iplft, iaddr );
215           if (iaddr ^= 0) then prntr = 1;         /*TRUE*/
216 label_357:
217           iplft = 32768*iplft;
218           goto label_360;
219 
220 /*      entry for its type literals. */
221 itsevl:   entry (ipair, xrslts);
222 
223           its_or_itb_entry = "1"b;                          /* note that we came in here */
224 
225           tbscl = 1;          /*TRUE*/
226 label_355:
227           iprht = mits;
228           type = eb_data_$iits;
229           call getid_$getid_;
230           junk = expevl_$expevl_ (0, iplft, iaddr );
231           if (iaddr ^= 0) then prntr = 1;         /*TRUE*/
232           if tnewmachine ^= 0 then iplft = utils_$and (iplft, (fivsev));
233 label_360:
234           if (brk (1) ^= icomma) then goto label_370;
235           call getid_$getid_;
236           junk = expevl_$expevl_ (0, ipval, iaddr );
237           rleft = 0;
238           if (iaddr  =  0) then goto label_361;
239           ipval = ipval + glpl_$clh (iaddr+3);
240           if (tbscl ^= 0  |  iaddr  =  0) then goto label_363;
241           rslts (1) = 0;
242           rslts (2) = glpl_$glwrd (iaddr,0);
243           lcptr = glpl_$setblk (rslts (1),2);
244           goto label_361;
245 label_363:
246           call getbit_$getbit_ (iaddr,ipbas,/* ipb29 */  0 ,rleft);
247 label_361:
248           ipmod = 0;
249           if (brk (1) ^= icomma) then goto label_362;
250           ipmod = modevl_$modevl_ (brk (1) );
251 label_362:
252 
253           rslts (1) = glpl_$glwrd (iplft,iprht);
254           rslts (2) = utils_$makins (ipbas,ipval,0,/* ipb29 */  0 ,ipmod);
255           n = 2;
256           if (tbscl = 0) then goto label_400;
257 label_365:
258           ipair (1) = rslts (1);
259           ipair (2) = rslts (2);
260           rslts (1) = 0;
261           rslts (2) = glpl_$glwrd (rleft,0);
262           go to return_from_its_itb;
263 
264 /*        illegal literal type. */
265 label_370:
266           n = 1;
267           rslts (1) = 0;
268           rslts (2) = 0;
269           rleft = 0;
270           type = eb_data_$ierr;
271           prntf = 1;          /*TRUE*/
272           if (tbscl ^= 0) then goto label_365;
273           rslts (1) = 0;
274           rslts (2) = 0;
275           call inputs_$next;
276           goto label_400;
277 
278 /*        entry to define a literal in ext vector. */
279 litasn:   entry (ad, xrslts, xn, lcptrx );
280 
281           lcptr = lcptrx;
282           n = xn;
283           if (n > 8) then n = 8;
284           do i = 1 to n;
285                rslts (i) = xrslts (i);
286           end;
287           goto label_500;
288 
289 
290 /*        literal evaluated, check for du or dl modifier. */
291 label_400:
292           admod = 0;
293           do while (parentheses > 0 & brk (1) = irpar);     /* Pair off parends. */
294                     call inputs_$next ();
295                     parentheses = parentheses - 1;
296                     end;
297           if (brk (1) ^= icomma | txtern = 0 | parentheses ^= 0) then goto label_500;
298           admod = modevl_$modevl_ (brk (1) );
299           if (n >= 2) then goto label_500;
300           if (admod ^= mdu  &  admod ^= mdl) then goto label_500;
301           if (type = eb_data_$imach | type = eb_data_$ivfd | type = eb_data_$ioct
302           | type = eb_data_$iint | type = eb_data_$ifxd) then goto label_410;
303                     ad = utils_$rs (rslts (1),18);
304                     goto label_420;
305 label_410:
306 
307                     ad = utils_$and (rslts (1),sixsev);
308 label_420:
309 
310           n = 0;
311           goto label_700;
312 
313 
314 /*        search literal list for this literal and assign if not there. */
315 /*        funny business because of equivalence between n and block (2) */
316 /*        and desire to put lcptr in left half of block (2). */
317 label_500:
318           j = litlst;
319           nprime = n;
320           block (2) = glpl_$glwrd (lcptr,n);
321           litc = glpl_$crh (lplit+1);
322 label_510:
323           if (j = 0) then goto label_540;
324           if (glpl_$cwrd (j+1) ^= nprime) then goto label_530;
325 do_520:   do k = 1 to nprime;
326           if (glpl_$cwrd (j+k+1) ^= rslts (k)) then goto label_530;
327 label_520:          end do_520;
328                     ad = glpl_$clh (j);
329           goto label_700;
330 label_530:
331           j = glpl_$crh (j);
332           goto label_510;
333 
334 /*        not found in list, assign this literal. */
335 label_540:
336           if (nprime > 1  &  mod (litc,2) ^= 0) then litc = litc+1;
337           block (1) = utils_$ls (litc,18);
338           j = glpl_$setblk (block (1),nprime+2);
339           ndltls -> word.right = addr (j ) -> word.right;
340           ndltls = ptr (eb_data_$lavptr, j );
341           ad = litc;
342           litc = litc+nprime;
343 
344 
345 /*        final return section. */
346 label_700:
347           call glpl_$storr (lplit+1,litc);
348 
349           /* if we came in the itbevl or itsevl entries, we must simulate passing "rslts" by reference.
350              (since rslts is not a parameter to all entry points, but is used as a temporary in all
351              entry points, we cannot just make it a real parameter. sigh!) */
352 
353 return_from_its_itb:
354           if its_or_itb_entry
355           then do;
356                     xrslts (1) = rslts (1);
357                     xrslts (2) = rslts (2);
358                end;
359 
360           return;
361 
362           end litevl_;