1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         *********************************************************** */
  8 %;
  9 /* ******************************************************
 10    *                                                    *
 11    *                                                    *
 12    * Copyright (c) 1972 by Massachusetts Institute of   *
 13    * Technology and Honeywell Information Systems, Inc. *
 14    *                                                    *
 15    *                                                    *
 16    ****************************************************** */
 17 
 18 vfdevl_: vfdcnt:
 19 
 20           procedure (rslts, flags, k);  /* note that k is really the return value of vfdevl */
 21 
 22 /* vfdevl evaluate variable field expr and return results and break. */
 23 /* vfdevl returns at most 10 words in rslts, no modifiers are allowed */
 24 /* note that type #a# fields are allowed and yield right justified */
 25 /* ascii characters preceded by nulls. fields may be any number */
 26 /* of bits long, but only the rightmost 36 bits of any field are */
 27 /* evaluated, the leading (n-36) bits will be zeroes (nulls) . */
 28 /* flags argument is for possible future relocation bits. */
 29 
 30 
 31 /*        Modified for "vfd" pseudo-op on 12/15/75 by Eugene E Wiatrowski.
 32           Modified on 112372 at 03:01:33 by R F Mabee.
 33           by R F Mabee and RHG to straighten out prntr on expevl_ error error.
 34           by R F Mabee on 2 November 1972 to fix bug that terminated scan on 4 char field.
 35           by RHG on 1 April 1971 to fix bad expevl_ to set prntr, not prnte
 36           by NA on July 16, 1970 at 0918 to fix n > 36 fields */
 37 
 38 
 39 % include varcom;
 40 % include concom;
 41 % include erflgs;
 42 % include codtab;
 43 
 44 /* EXTERNAL ENTRIES */
 45 
 46 declare   inputs_$next ext entry,
 47           inputs_$nxtnb ext entry,
 48           getid_$getid_ ext entry;
 49 
 50 /* EXTERNAL FUNCTIONS */
 51 
 52 declare   utils_$ls ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)) ,
 53           utils_$rs ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)) ,
 54           glpl_$setblk ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (26)) ,
 55           expevl_$expevl_ ext entry (fixed bin (26), fixed bin (26), fixed bin (26)) returns (fixed bin (26)) ,
 56           utils_$or ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (35)),
 57           utils_$and ext entry (fixed bin (26), fixed bin (26)) returns (fixed bin (35));
 58 
 59 /* EXTERNAL DATA */
 60 
 61 declare    (eb_data_$jbo, eb_data_$jba, eb_data_$twop18) ext fixed bin (35);
 62 
 63 /* INTERNAL DATA */
 64 
 65 declare    rslts (128) fixed bin(35);
 66 declare    ( flags, val, word, lcvec (128) , trel, i, j, k, ibl, nn, iaddr, l, n, let) fixed bin (26);
 67 declare    vfd_buffer_size    init(128)           fixed bin int static;
 68 
 69 
 70 
 71 
 72           i = 1;
 73           rslts (1) = 0;
 74           j = 0;
 75           n = 0;
 76           let = 0;
 77 label_107:
 78 
 79           lcvec(*) = 0;
 80 
 81           trel = 0; /* FALSE */
 82           flags = 0;
 83           call inputs_$nxtnb;
 84           goto label_120;
 85 
 86 /* Count gathering loop.  */
 87 label_110:
 88           call inputs_$next;
 89 label_120:
 90           if (brk (1) = inum) then goto label_200;
 91           if (brk (1) = ilet) then goto label_210;
 92           if (brk (1) = islash) then goto label_300;
 93           goto label_530;
 94 
 95 /* process characters in count field. */
 96 label_200:
 97           n = 10*n+utils_$and (brk (2) , 15);
 98           goto label_110;
 99 
100 label_210:
101                     let = brk (2);
102                     goto label_110;
103 
104 /* slash found, branch to evaluate field. */
105 label_300:
106           if (let = 0) then goto label_310;
107           if (let = eb_data_$jbo) then goto label_320;
108           if (let = eb_data_$jba) then goto label_335;
109           goto label_530;
110 
111 label_310:
112           ibl = 0;
113           goto label_325;
114 
115 label_320:
116           ibl = 1;
117 label_325:
118           call getid_$getid_;
119           nn = expevl_$expevl_ (ibl, val, iaddr);
120           if (iaddr = 0) then goto label_400;
121           if (n >= 18 & val < eb_data_$twop18) then goto label_326;
122                     prntr = 1;          /*TRUE*/
123                     goto label_400;
124 
125 label_326:
126           k = j+n;
127           l = 0;
128 label_327:
129           if (k <=  36) then goto label_328;
130                     k = k-36;
131                     l = l+1;
132                     goto label_327;
133 
134 label_328:
135           if (k ^= 18) then goto label_329;
136                     l = l+i;
137                     lcvec (l) = utils_$ls (iaddr, 18);
138                     trel = 1; /*TRUE*/
139                     goto label_400;
140 
141 label_329:
142           if (k ^= 36) then goto label_330;
143                     l = l+i;
144                     lcvec (l) = utils_$or (lcvec (l) , iaddr);
145                     trel = 1; /*TRUE*/
146                     goto label_400;
147 
148 label_330:
149           prntr = 1;          /*TRUE*/
150           goto label_400;
151 
152 label_335:
153           val = 0;
154 
155 label_337:
156           call inputs_$next;
157           if (brk (1) = icomma | brk (1) = inl) then goto label_400;
158           val = utils_$or (512*val, brk (2) );
159           goto label_337;
160 
161 
162 /* field evaluated, insert in output buffer. */
163 label_400:
164           if n <= 35 then val = utils_$and (val, utils_$rs (-1, 36 - n) );
165 label_420:
166           if ( (j+n) < 36) then goto label_440;
167           n = n- (36-j);
168           rslts (i) = utils_$or (utils_$ls (word, 36-j) , utils_$rs (val, n) );
169           j = 0;
170           i = i+1;
171           if (i > vfd_buffer_size) then goto label_530;
172 label_430:
173           if (n < 36) then goto label_440;
174                     n = n-36;
175                     rslts (i) = utils_$rs (val, n);
176                     i = i+1;
177                     if (i > vfd_buffer_size) then goto label_530;
178                     goto label_430;
179 
180 label_440:
181           if n > 35 then word = val;
182           else word = utils_$or (utils_$ls (word, n) , utils_$and (val, utils_$rs (-1, 36-n) ) );
183           j = j+n;
184           n = 0;
185           let = 0;
186           if (brk (1) = icomma) then goto label_110;
187 
188 /* all done, position last word, and return to caller. */
189 label_500:
190           if (j = 0) then goto label_510;
191           rslts (i) = utils_$ls (word, 36-j);
192           k = i;
193           goto label_520;
194 
195 
196 
197 /* overflow return, set flags and return partial buffer. */
198 
199 label_530:
200 
201           prnte = 1;
202           goto label_500;
203 
204 
205 label_510:
206 
207           k = i-1;
208           if (i = 1) then k = 1;
209 label_520:
210 
211           if (trel ^=  0) then flags = glpl_$setblk (lcvec (1) , k);
212 
213 end vfdevl_;