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 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
 17      audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
 18      Modified to support *heap references.
 19                                                    END HISTORY COMMENTS */
 20 
 21 
 22 varevl_:
 23      procedure (xwhat, xbasno, xval, xadmod, xb29, xaddr) returns (fixed bin (26));
 24                                                             /*  evaluate variable fields for the Multics assembler (ma_6180). */
 25 
 26 
 27 /*   Modified 3/8/77 by Noel I. Morris to handle segment$symbol.
 28         Modified for separate static on 06/15/75 by Eugene E Wiatrowski
 29           Modified 740905 by PG to know about pr0...pr7.
 30    by RFM on 15 January 1973 to add an option to not read the modifier.
 31    by RHG on 15 June 1971 to add "(" and ")" to the list of legal field terminators (for "call", etc)
 32    by RFM and RHG on 22 November 1972 to _^Hn_^Ho_^Ht set prntr on expevl_ error.
 33    by RHG on 2 June 1971 to set prntr on expevl_ error
 34    by RHG on 25 May 1971 to allow "," to terminate a field too
 35    by RHG on 29 March 1971 at 1703 to spot illegal field terminator
 36    by NA on June 28, 1970 at 2159 for the new CODTAB
 37 */
 38 
 39 /* There are six modes of entry to VAREVL. Two are for external */
 40 /* references, two for internal references, and two for boolean */
 41 /* references. the routines are careful to generate the proper */
 42 /* linkages for external references, to evaluate literals */
 43 /* properly, and to check for errors of all types. parentheses */
 44 /* are allowed in the internal expressions for nesting. */
 45 
 46 
 47 /* INCLUDE FILES FOR VAREVL */
 48 
 49 % include concom;
 50 % include varcom;
 51 % include codtab;
 52 % include erflgs;
 53 % include lcsect;
 54 % include lclit;
 55 /* ^L */
 56 
 57 /* INTERBAL STATIC DATA */
 58 declare  ixvrvl_notag fixed bin init (0);
 59 
 60 /*  EXTERNAL ENTRIES USED BY VAREVL */
 61 
 62 declare  getid_$getid_ ext entry,
 63          getid_$getnam ext entry,
 64          prnter_$prnter_ entry (char (*), fixed bin),
 65          utils_$abort ext entry,
 66          inputs_$next ext entry,
 67          litevl_$litevl_ entry (fixed bin (26), fixed bin (26), fixed bin (26));
 68 
 69 /* EXTERNAL FUNCTIONS USED BY VAREVL */
 70 
 71 declare  lstman_$namasn entry (fixed bin (26)) returns (fixed bin (26)),
 72          lstman_$blkasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 73          lstman_$lnkasn ext entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 74          table_ entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)),
 75          glpl_$clh entry (fixed bin) returns (fixed bin),
 76          modevl_$modevl_ entry (fixed bin (26)) returns (fixed bin (26)),
 77          expevl_$expevl_ entry (fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26));
 78 
 79 /*  EXTERNAL DATA USED BY VAREVL */
 80 
 81 declare (eb_data_$asym (2), eb_data_$atext (2), eb_data_$alink (2), eb_data_$astat (2), eb_data_$asys (2)) ext fixed bin (35);
 82 declare eb_data_$aheap(2) ext fixed bin(35);
 83 
 84 /* LABEL VARIABLES USED BY VAREVL */
 85 
 86 
 87 declare  evlrtn label local;
 88 
 89 /*  AUTOMATIC DATA USED BY VAREVL */
 90 
 91 declare (admod, b29, basno, blk, i, iaddr,
 92          inexp, junk, snlnk, tbool, tmpno, tself, txnam,
 93          txtern, type, val, varevl_answer, xaddr, xadmod,
 94          xbasno, xb29, xnlnk, xval, xwhat) fixed bin (26);
 95 
 96 /* BASED */
 97 
 98 declare   1 acc aligned based (addr (eb_data_$varcom.sym (1))),
 99             2 count unaligned fixed bin (8),
100             2 string unaligned char (3);
101 
102 /* ^L */
103 /* - - - - - MAIN ENTRY POINT, Check type of call and branch to it. */
104 
105           iaddr = 0;
106           tbool = 0;                                        /* FALSE */
107           if xwhat = ixvrvl then go to label_200;
108           if xwhat = ixvrvl_notag then goto label_200;
109           if xwhat = ixvrvp then go to label_210;
110           if xwhat = invrvl then go to label_130;
111           if xwhat = invrvp then go to label_160;
112           if xwhat = ibvrvl then go to label_110;
113           if xwhat = ibvrvp then go to label_140;
114 
115 
116           call prnter_$prnter_ ("fatal error in the assembler (VAREVL)", 101);
117           call utils_$abort;
118 
119 /* boolean entry without current break. */
120 label_110:
121           tbool = 1;                                        /* TRUE */
122 
123 /* arithmetic entry without current break. */
124 label_130:
125           call getid_$getid_;
126           go to label_170;
127 
128 /* boolean entry with current break. */
129 label_140:
130           tbool = 1;                                        /* TRUE */
131 
132 /* normal entry with current break. */
133 label_160:
134           sym (1) = 0;
135 label_170:
136           admod = 0;
137           varevl_answer = 1;                                /* TRUE */
138           txtern = 0;                                       /* FALSE */
139           if (brk (1) = iequal & sym (1) = 0) then go to label_500;
140           evlrtn = label_1100;
141           go to label_3000;
142 
143 /* process possible external field without current break. */
144 label_200:
145           call getid_$getid_;
146           go to label_220;
147 
148 
149 /* process possible external field with current break. */
150 label_210:
151           sym (1) = 0;
152 label_220:
153           tbool = 0;                                        /* FALSE */
154           inexp = 0;
155           txtern = 1;                                       /* TRUE */
156           varevl_answer = 1;                                /* TRUE */
157 
158 
159 /* check first break for possible external symbol. */
160           if (brk (1) = ilpb & sym (1) = 0) then go to label_300;
161           if (brk (1) = ivlin & sym (1) ^= 0) then go to label_400;
162           if (brk (1) = idolr & sym (1) ^= 0) then go to label_290;
163           if (brk (1) = iequal & sym (1) = 0) then go to label_500;
164           if (brk (1) = istar | brk (1) = islash | sym (1) = 0) then go to label_600;
165           go to label_700;
166 
167 
168 
169 
170 /* process segname$symbol */
171 label_290:
172           tself = 0;
173           snlnk = lstman_$namasn (sym (1));
174           call getid_$getid_;
175 
176           if sym (1) ^= 0 then do;
177                xnlnk = lstman_$namasn (sym (1));
178                sym (1) = 0;
179                go to label_320;
180           end;
181 
182           else do;
183                xnlnk = 0;
184                go to label_312;
185           end;
186 
187 
188 
189 /* process external symbol in pointed brackets. */
190 label_300:
191           call getid_$getnam;
192           if (sym (1) = 0 | brk (1) ^= irpb) then go to label_2000;
193           call inputs_$next;
194           if (brk (1) ^= ivlin) then go to label_2000;
195           tself = 0;                                        /* FALSE */
196           if (sym (1) ^= eb_data_$atext (1) | sym (2) ^= eb_data_$atext (2)) then go to label_302;
197           tself = 1;                                        /* TRUE */
198           snlnk = 0;
199           go to label_310;
200 label_302:
201           if (sym (1) ^= eb_data_$alink (1) | sym (2) ^= eb_data_$alink (2)) then go to label_304;
202           tself = 1;                                        /* TRUE */
203           snlnk = 1;
204           go to label_310;
205 label_304:
206           if (sym (1) ^= eb_data_$asym (1) | sym (2) ^= eb_data_$asym (2)) then go to label_305;
207           tself = 1;                                        /* TRUE */
208           snlnk = 2;
209           go to label_310;
210 label_305:
211           if (sym (1) ^= eb_data_$astat (1) | sym (2) ^= eb_data_$astat (2)) then go to label_306;
212           tself = 1;
213           snlnk = 4;
214           go to label_310;
215 label_306:
216           if (sym (1) ^= eb_data_$asys (1) | sym (2) ^= eb_data_$asys (2)) then go to label_307;
217           tself = 1;
218           snlnk = 5;
219           go to label_310;
220 label_307:
221           /* add support for *heap links */
222           if (sym (1) = eb_data_$aheap (1) | sym (2) = eb_data_$aheap (2)) then do;
223                     tself = 1;
224                     snlnk = 6;
225                     goto label_310;
226             end;
227           tself = 0;                                        /* FALSE */
228           snlnk = lstman_$namasn (sym (1));
229 
230 /* type 3 address, external name without external symbol. */
231 label_310:
232           call check_external_name;
233           if (txnam ^= 0) then go to label_320;
234 label_312:
235           type = 3;
236           if (tself ^= 0) then type = 1;
237           evlrtn = label_330;
238           go to label_3000;
239 
240 
241 /* type 4 address, external name with external symbol. */
242 label_320:
243           type = 4;
244           if (tself ^= 0) then type = 5;
245           evlrtn = label_330;
246           go to label_3100;
247 
248 
249 /* generate type block for external name and external symbol. */
250 label_330:
251           blk = lstman_$blkasn (type, snlnk, xnlnk, 0);
252           go to label_1000;
253 
254 
255 
256 
257 /* process base number in front of vertical line. */
258 label_400:
259           if acc.count = 3
260           then if substr (acc.string, 1, 2) = "pr"
261                then do;
262                          basno = index ("01234567", substr (acc.string, 3, 1)) - 1;
263 
264                          if basno ^= -1           /* if pr0...pr7 */
265                          then go to label_420;
266                     end;
267 
268           do i = 1 to 8;
269                basno = i - 1;
270                if (sym (1) = symbas (i)) then go to label_420;
271           end;
272 
273           if (table_ (iserch, sym (1), basno, (clint), junk) ^= 0) then go to label_420;
274           basno = 0;
275           varevl_answer = 0;                                /* FALSE */
276           prntu = 1;                                        /* TRUE */
277 
278 
279 label_420:
280           call check_external_name;
281           if (txnam ^= 0) then go to label_440;
282 
283 
284 /* type 6 address, base specified without external symbol. */
285           type = 6;
286           evlrtn = label_1000;
287           go to label_3000;
288 
289 
290 /* type 2 address, base specified with external symbol. */
291 label_440:
292           type = 2;
293           evlrtn = label_450;
294           go to label_3100;
295 
296 
297 /* generate type block for base register and external symbol. */
298 label_450:
299           blk = lstman_$blkasn (type, basno * 32768, xnlnk, 0); /* utils_$ls (basno, 15) */
300           go to label_1000;
301 
302 
303 
304 
305 /* break is =, evaluate literal. */
306 label_500:
307           call litevl_$litevl_ (inexp, admod, txtern);
308           type = 0;
309           if (admod = mdu | admod = mdl) then go to label_1010;
310           iaddr = lplit;
311           go to label_1010;
312 
313 
314 
315 
316 /* star or slash break implies internal, go to it. */
317 label_600:
318           go to label_710;
319 
320 
321 
322 
323 /* plus or minus break, segref or basref symbol possible. */
324 label_700:
325           if (table_ (iserch, sym (1), val, (clext), junk) ^= 0) then go to label_720;
326           if (table_ (iserch, sym (1), val, (clstk), junk) ^= 0) then go to label_730;
327 
328 
329 /* internal symbol, process it. */
330 label_710:
331           evlrtn = label_1000;
332           type = 0;
333           go to label_3000;
334 
335 
336 /* segref or basref symbol, setup block and type. */
337 label_720:
338           blk = val;
339           type = glpl_$clh (blk + 1);
340           sym (1) = 0;
341           evlrtn = label_1000;
342           go to label_3100;
343 
344 
345 /* stack reference, set relative pointer and type. */
346 label_730:
347           tmpno = val;
348           type = 7;
349           sym (1) = 0;
350           evlrtn = label_1000;
351           go to label_3100;
352 
353 /* common entry after evaluating variable field, get modifier, */
354 /* establish linkage, address, local modifier, and b29, */
355 /* and return to caller with terminal break character. */
356 
357 
358 label_1000:
359           admod = 0;
360           if brk (1) = icomma then if xwhat ^= ixvrvl_notag then admod = modevl_$modevl_ (brk (1));
361 label_1010:
362           go to address_type (type);
363 
364 /* type 0, normal address, internal and b29 off. */
365 label_1100:
366 address_type (0):
367           if (brk (1) ^= ivlin) then go to label_1110;
368           basno = inexp;
369           if txtern ^= 0 then goto label_420;
370 label_1110:
371 
372           basno = 0;
373           val = inexp;
374           b29 = 0;
375           go to label_1900;
376 
377 
378 /* types 1 thru 5, reference requires linkage through type-block. */
379 address_type (1):
380 address_type (2):
381 address_type (3):
382 address_type (4):
383 address_type (5):
384           val = lstman_$lnkasn (blk, inexp, admod, iaddr);
385           basno = lp;
386           admod = mri;
387           b29 = 1;
388           iaddr = lpsect;
389           go to label_1900;
390 
391 
392 /* type 6, augmented reference requiring no linkage. */
393 address_type (6):
394           val = inexp;
395           b29 = 1;
396           go to label_1900;
397 
398 
399 /* stack reference, generate reference without linkage. */
400 address_type (7):
401           val = tmpno+inexp;
402           basno = sp;
403           b29 = 1;
404           if (iaddr ^= 0) then prntr = 1;                   /* TRUE */
405           iaddr = 0;
406           go to label_1900;
407 
408 /* common return section, set external values and return. */
409 label_1900:
410           i = brk (1);
411           if i ^= isp then if i ^= inl then if i ^= iquot then if i ^= icomma
412                               then if i ^= irpar then if i ^= ilpar then prnte = 1;
413 label_1905:
414           xbasno = basno;
415           xval = val;
416           xadmod = admod;
417           xb29 = b29;
418           xaddr = iaddr;
419           return (varevl_answer);
420 
421 
422 /* field error, set f flag and make null return. */
423 label_2000:
424           prntf = 1;                                        /* TRUE */
425           varevl_answer = 0;                                /* FALSE */
426           basno = 0;
427           val = 0;
428           admod = 0;
429           b29 = 0;
430           go to label_1905;
431 
432 /* interlude to internal variable field evaluation routine. this */
433 /* routine evaluates expressions consisting only of internal re- */
434 /* ferences using a stack evaluation method. nested parentheses are */
435 /* allowed, and are taken to delimit subexpressions. the interlude */
436 /* checks for call requirements and checks the results for field */
437 /* errors, any such causing varevl_answer to be false. */
438 
439 
440 /* normal entry, break in brk, and perhaps symbol in sym. */
441 label_3000:
442           junk = expevl_$expevl_ (tbool, inexp, iaddr);
443 label_3010:
444           go to evlrtn;
445 
446 
447 /* entry after external symbol encountered. symbol must be zero, */
448 /* and break must be + or -, anything else terminates scan. */
449 label_3100:
450           if (sym (1) = 0 & (brk (1) = iplus | brk (1) = iminus)) then go to label_3000;
451           go to label_3010;
452 
453 /* chkxnm, internal subroutine used to check for external name */
454 /* after a vertical line. */
455 
456 check_external_name:
457           procedure;
458 
459                call getid_$getid_;
460                if (brk (1) ^= ilsb | sym (1) ^= 0)
461                     then do;
462                     xnlnk = 0;
463                     txnam = 0;                              /* FALSE */
464                     return;
465                end;
466 
467                call getid_$getid_;
468                if (brk (1) ^= irsb | sym (1) = 0) then go to label_2000;
469                xnlnk = lstman_$namasn (sym (1));
470                txnam = 1;                                   /* TRUE */
471                call getid_$getid_;
472                return;
473 
474           end check_external_name;
475 
476      end varevl_;