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 /****^  HISTORY COMMENTS:
 15   1) change(86-09-03,Oke), approve(86-09-03,MCR7543), audit(86-09-30,JRGray),
 16      install(86-10-08,MR12.0-1180):
 17      Extend decimal input
 18      processing to permit 1 or 2 word values.  User explicitly requests
 19      double precision integer decimal input by using a "L" suffix.
 20      Previously only single word values were generated, with no detected
 21      errors.  Permits double-word decimal literals to be generated.  Needed
 22      by the C compiler.
 23                                                    END HISTORY COMMENTS */
 24 
 25 /* Evaluate decimal literal field, return results and break.
 26 
 27    Fixed and real constants may be single or double precision.  Decevl is
 28    called from pass1 and pass2 (for dec pseudo-op) and by litevl (for
 29    literals).  The parameter type is used by litevl in case of du or dl
 30    modifier requiring a truncation of results.  Note that according to bsa
 31    standards, fields may be separated by commas or blanks.  Machine language
 32    subroutines are used to manipulate the double precision words.
 33 
 34    Last modified:
 35           by RHG on 22 sept 1970 to handle multi-line ascii literals properly
 36    Last modified:
 37           by BLW on 8 Sept 1973 to use accurate conversion routines.  Machine
 38           language subroutine is no longer used to manipulate double precision
 39           words.  decevl_ was converted to version 2 pl1 with minimum changes
 40           needed.
 41    Modified 7 July 1980 by M. N. Davidoff to issue "E" diagnostic instead of raising size, also cleaned it up some.
 42 */
 43 /* format: style2 */
 44 decevl_:
 45      procedure (rslts, type) returns (fixed bin (35));
 46 
 47           declare rslts                  (10) fixed bin (35);
 48           declare type                   fixed bin (26);
 49 
 50 /* automatic */
 51 
 52           declare 1 attr,
 53                     2 binary             bit (1),
 54                     2 double             bit (1),
 55                     2 float              bit (1);
 56           declare binpt                  fixed bin (26);
 57           declare buffer                 char (64);
 58           declare double                 bit (1) aligned;
 59           declare first                  bit (1) aligned;
 60           declare next_sw                bit (1) aligned;
 61           declare prec                   fixed bin (35);
 62           declare saw_point              bit (1) aligned;
 63           declare scale                  fixed bin (26);
 64           declare 1 x_structure          aligned,           /* NOTE: x must start on an even boundary. */
 65                     2 pad1_for_alignment fixed bin (71),
 66                     2 x                  (3) fixed bin (26);
 67           declare xp                     fixed bin (26);
 68 
 69 /* based */
 70 
 71           declare 1 brk_overlay          aligned based (addr (brk (2))),
 72                     2 skip               char (3) unal,
 73                     2 ch                 char (1) unal;
 74           declare 1 number               aligned based (addr (buffer)),
 75                     2 sign               char (1) unal,
 76                     2 digit              (prec) char (1) unal,
 77                     2 skip               bit (1) unal,
 78                     2 exponent           fixed bin (7) unal;
 79 
 80 /* builtin */
 81 
 82           declare (addr, byte, divide, length, max, min, rank, string, substr, unspec)
 83                                          builtin;
 84 
 85 /* condition */
 86 
 87           declare (overflow, size)       condition;
 88 
 89 /* external static */
 90 
 91           declare eb_data_$iasc          fixed bin (35) external static;
 92           declare eb_data_$iflt          fixed bin (35) external static;
 93           declare eb_data_$ifxd          fixed bin (35) external static;
 94           declare eb_data_$iint          fixed bin (35) external static;
 95 
 96 /* entry */
 97 
 98           declare assign_                entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
 99           declare inputs_$ascii_literal  entry;
100           declare inputs_$next           entry;
101           declare inputs_$nxtnb          entry;
102 ^L
103 %include varcom;
104 %include erflgs;
105 %include codtab;
106 %include std_descriptor_types;
107 ^L
108 /* program */
109 
110           double = ""b;                           /* Assume single prec int */
111           xp = 0;
112           saw_point = "0"b;
113           string (attr) = ""b;
114           first = "1"b;
115           prec = 0;
116           scale = 0;
117           binpt = 71;
118           number.sign = "+";
119 
120           on overflow, size goto return_from_size;
121 
122 /* main loop for collecting digits, check for sign, point, and a, b, d, or e
123    fields following number. */
124 
125           do while ("1"b);
126                next_sw = "1"b;
127 
128                if brk (1) = inum
129                then do;
130                          if attr.float
131                          then scale = scale + 1;
132 
133                          prec = prec + 1;
134                          number.digit (prec) = ch;
135                     end;
136 
137                else if brk (1) = ipoint
138                then do;
139                          saw_point = "1"b;
140                          attr.float = "1"b;
141                     end;
142 
143                else if brk (1) = iminus
144                then number.sign = "-";
145 
146                else if brk (1) = iplus
147                then ;
148 
149                else
150 label_220:
151                     if brk (1) = ilet
152                then begin;
153                          declare char                   char (1) aligned;
154 
155 /* letter encountered, evaluate b, d, or e field. */
156 
157                          char = byte (brk (2));
158 
159                          if char = "a" & ^attr.binary & ^attr.float & number.sign ^= "-"
160                          then begin;
161                                    declare chars                  char (32);
162                                    declare i                      fixed bin;
163                                    declare word_count             fixed bin;
164 
165                                    declare char_array             (8) char (4) defined (chars);
166 
167 /* ascii literal, pack characters into rslts and return count. */
168 
169                                    call assign_ (addr (x (1)), 2 * real_fix_bin_2_dtype, 71, addr (buffer),
170                                         2 * real_fix_dec_9bit_ls_dtype, prec);
171 
172                                    type = eb_data_$iasc;
173                                    x (2) = min (x (2), length (chars));
174                                    word_count = max (divide (x (2) + 3, 4, 17), 1);
175                                    unspec (chars) = ""b;
176 
177                                    do i = 1 to x (2);
178                                         call inputs_$ascii_literal;
179                                         substr (chars, i, 1) = byte (brk (2));
180                                    end;
181 
182                                    do i = 1 to word_count;
183                                         unspec (rslts (i)) = unspec (char_array (i));
184                                    end;
185 
186                                    call inputs_$next;
187 
188                                    return (word_count);
189                               end;
190 
191                          else if char = "b" & ^attr.binary
192                          then do;
193                                    attr.binary = "1"b;
194                                    binpt = evaluate_integer_field ();
195                               end;
196 
197                          else if char = "L" & ^double
198                               then do;
199                                    call inputs_$next;
200                                    double = "1"b;
201                               end;
202                          else do;
203                                    if char = "d"
204                                    then attr.double = "1"b;
205 
206                                    else if char ^= "e"
207                                    then prnte = 1;          /* TRUE */
208 
209                                    attr.float = "1"b;
210                                    xp = evaluate_integer_field ();
211                               end;
212 
213                          goto label_220;
214                     end;
215 
216                else if ^first
217                then do;
218 
219 /* end of field, convert number to proper format, set type, return results and
220    break, and set value to number of words. */
221 
222                          if ^attr.binary & ^attr.float
223                          then do;
224                                    type = eb_data_$iint;
225                                    call assign_ (addr (x (1)), 2 * real_fix_bin_2_dtype, 71, addr (buffer),
226                                         2 * real_fix_dec_9bit_ls_dtype, prec);
227 
228 /* if requested precision double then we supply two words. */
229 
230                                    if double then do;
231                                         rslts (1) = x (1);
232                                         rslts (2) = x (2);
233                                         return (2);
234                                    end;
235 
236 /* Original assumption - return just a single word. */
237 
238                                    rslts (1) = x (2);
239 
240                                    return (1);
241                               end;
242 
243                          number.exponent = xp - scale;
244 
245                          if attr.binary
246                          then do;
247                                    type = eb_data_$ifxd;
248 
249                                    if prnte ^= 1
250                                    then call assign_ (addr (x (1)), 2 * real_fix_bin_2_dtype, (71 - binpt) * 1f18b + 71,
251                                              addr (buffer), 2 * real_flt_dec_9bit_dtype, prec);
252                               end;
253 
254                          else do;
255                                    type = eb_data_$iflt;
256                                    call assign_ (addr (x (1)), 2 * real_flt_bin_2_dtype, 63, addr (buffer),
257                                         2 * real_flt_dec_9bit_dtype, prec);
258                               end;
259 
260                          rslts (1) = x (1);
261                          rslts (2) = x (2);
262 
263                          if attr.double
264                          then return (2);
265                          else return (1);
266                     end;
267 
268                else do;
269                          call inputs_$nxtnb;
270                          next_sw = "0"b;
271                     end;
272 
273                if next_sw
274                then call inputs_$next;
275 
276                first = "0"b;
277           end;
278 
279 /* A size condition occured.  This was probably in assign_, but could have
280    been in evaluate_integer_field.  Just return something so the rest of the
281    program will get parsed.  If the size condition occured in the call to
282    assign_ in the ascii literal, or during evaluate_integer_field, the current
283    input character is not advanced passed this literal so other syntax errors
284    on the input line may result. */
285 
286 return_from_size:
287           prnte = 1;                                        /* TRUE */
288           type = eb_data_$iint;
289           rslts (1) = 0;
290 
291           return (1);
292 ^L
293 evaluate_integer_field:
294      procedure returns (fixed bin (26));
295 
296           declare int                    fixed bin (26);
297           declare sign                   fixed bin;
298 
299           sign = 1;
300           int = 0;
301           first = "0"b;
302 
303           call inputs_$next;
304           do while (brk (1) = iplus | brk (1) = iminus | brk (1) = inum);
305                if brk (1) = iminus
306                then sign = -1;
307 
308                else if brk (1) = inum
309                then int = 10 * int + brk (2) - rank ("0");
310 
311                call inputs_$next;
312           end;
313 
314           return (sign * int);
315      end evaluate_integer_field;
316 
317      end decevl_;