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  modevl_:
 14      procedure ( dummy /* normally BRK */ ) returns ( fixed bin(17) );
 15 /*
 16           Last modified on 07/06/72 at 22:26:10 by R F Mabee.
 17                     by RFM on 6 July 1972 to add itp modifier.
 18                     by RHG on 17 Sept 1970 to fix bug in octal modifiers
 19                     by RHG on 28 August 1970 at 0916 to allow octal modifiers
 20                     by Nate Adleman on June 28, 1970 at 2037 for the new CODTAB
 21 */
 22                     /* MODEVL:   evaluate address modifier, if any. */
 23 
 24                     /* Possible modifier types are: (r), *(r), (r)*, and (it).
 25                        all modifiers are tested, but note that the index
 26                        pseudo - operation is not yet coded. However, all 645
 27                        modifiers are included. */
 28 
 29 /* INCLUDE FILES USED BY MODEVL */
 30 
 31 
 32 % include codtab;
 33 % include concom;
 34 % include erflgs;
 35 % include varcom;
 36 
 37 
 38 /* EXTERNAL ENTRIES USED BY MODEVL */
 39 
 40 declare   getid_$getid_ ext entry,
 41           inputs_$next ext entry ;
 42 
 43 /* EXTERNAL FUNCTIONS USED BY MODEVL */
 44 
 45 declare   table_$table_ ext entry (fixed bin (26), fixed bin (26), fixed bin, fixed bin (26), fixed bin) returns (fixed bin (26)),
 46           utils_$and ext entry (fixed bin, fixed bin) returns (fixed bin) ;
 47 
 48 
 49 /* EXTERNAL DATA USED BY MODEVL */
 50 
 51 declare ( eb_data_$itlist_ (0:20), eb_data_$rlist(0:15) ) external fixed bin(17);
 52 
 53 /* AUTOMATIC DATA USED BY MODEVL */
 54 
 55 declare ( i, ixr, junk, modevl_answer, dummy ) fixed bin (17) ;
 56 
 57 /* ^L */
 58 /*  -   -   -   -   -   -   -   -   -  PROGRAM STARTS HERE  -   -   -   -   -   -   -   -   -   -   -   -   -  */
 59 
 60 /* get first identifier and break and check for star. */
 61 label_100:
 62           call getid_$getid_;
 63           modevl_answer = 0;
 64           if (brk(1) = istar) then go to label_200;
 65           if (sym(1) = 0) then go to label_300;
 66           go to label_400;
 67 
 68 
 69 /* star encountered, check for *(r) or (r)* modifier. */
 70 label_200:
 71           if (sym(1) = 0) then go to label_210;
 72           modevl_answer = 16;
 73           call inputs_$next;
 74           go to label_230;
 75 label_210:
 76 
 77           call getid_$getid_;
 78           if (brk(1) ^= inum) then go to label_215;
 79           modevl_answer = brk(2) + 8;   /* actually brk(2)-"0"+56 */
 80           if modevl_answer >= 64 then goto non_octal;       /* make sure digit was octal */
 81           go to get_next;
 82 label_215:
 83           if (sym(1) ^= 0) then go to label_220;
 84           modevl_answer = 16;
 85           go to modevl_return;
 86 label_220:
 87 
 88           modevl_answer = 48;
 89 
 90 
 91 /* register involved, search rlist for it. */
 92 label_230:
 93 
 94 label_240:
 95           do i = 0 to 15;
 96                if (sym(1)  ^=  eb_data_$rlist(i)) then go to label_250;
 97                modevl_answer = modevl_answer + i;
 98                go to modevl_return;
 99 label_250:
100           end label_240;
101 
102 
103 
104 /* not in rlist, search table for index assignment. */
105 label_260:
106           if (table_$table_(iserch,sym(1),ixr,clint,junk) = 0) then go to label_280;
107           modevl_answer = modevl_answer + ixr + 8;
108           go to modevl_return;
109 
110 /* we get here when we were expecting an octal digit but got 8 or 9 */
111 
112 non_octal:          prnt7 = 1;
113 
114 /* undefined modifier, set flag and exit with null register. */
115 label_280:
116           prntt = 1;                                        /* TRUE */
117           go to label_310;
118 
119 
120 /* no *, no sym, check for digit. */
121 label_300:
122           if (brk(1) ^= inum) then go to label_310;
123           modevl_answer = brk(2) - 40;  /* actually brk(2)-"0"+8 */
124           if modevl_answer >= 16 then goto non_octal;       /* check digit was actually octal */
125           call inputs_$next;
126           if brk(1) = inum then         /*check for another digit*/
127                     do;
128                     if brk(2) >= 56 then goto non_octal;    /*check digit was actually octal*/
129                     modevl_answer = 8*modevl_answer+brk(2)-112;
130                     goto get_next;
131                     end;
132           if (brk(1) ^= istar) then go to modevl_return;
133           modevl_answer = modevl_answer + 16;
134           go to get_next;
135 
136 
137 /* null modifier, zero and exit. */
138 label_310:
139           modevl_answer = 0;
140           go to modevl_return;
141 
142 
143 /* no star, check in it list first. */
144 label_400:
145 
146           do i = 1 to eb_data_$itlist_ (0) by 2;            /* Length in first word; name, value in word pairs after. */
147                if (sym(1)  ^=  eb_data_$itlist_ (i)) then go to label_410;
148                modevl_answer = eb_data_$itlist_ (i + 1);
149                go to modevl_return;
150 label_410:
151           end label_400;
152 
153 /* not in itlist, go check rlist. */
154           modevl_answer = 0;
155           go to label_240;
156 
157 get_next: call inputs_$next;
158 
159 modevl_return:
160 
161           return( modevl_answer );
162 
163 
164 
165      end modevl_ ;