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 /* ASCEVL_ - program to evaluate the ACI, ACC, and BCI pseudo-ops.
 14    Returns the converted string and word count, and next break. */
 15 
 16 ascevl_$accevl:
 17      procedure (rslts) returns (fixed binary);
 18 
 19 /*        Modified 3/6/77 by NIM to implement ac4 pseudo-op.
 20           Modified 740830 by PG to allow optional length field to specify padding. Program was rewritten.
 21    Modified on 01/15/73 at 01:59:12 by R F Mabee.
 22    by R F Mabee on 15 January 1973 to add BCD strings.
 23    by R F Mabee on 16 August 1972 to fix some bugs in listing ACC statements.
 24    by RHG on 23 Sept 1970 to call inputs_$ascii_literal */
 25 
 26 /* PARAMETERS */
 27 
 28 declare  rslts (42) fixed binary (35) parameter;
 29 
 30 /* BUILTINS */
 31 
 32 declare (addr, bin, bit, ceil, copy, divide, floor, hbound, length, mod, substr) builtin;
 33 
 34 /* EXTERNAL ENTRIES CALLED BY ASCEVL */
 35 
 36 declare  inputs_$next external entry,
 37          inputs_$ascii_literal external entry,
 38          inputs_$nxtnb external entry,
 39          varevl_ entry (fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26), fixed bin (26),
 40          fixed bin (26)) returns (fixed bin (26));
 41 
 42 /* AUTOMATIC DATA USED BY ASCEVL */
 43 
 44 declare (pad_length, pad_start, delta, n_words, max_length, out, chars_per_word) fixed bin;
 45 declare  quote fixed binary (35);
 46 declare (acc_type, too_long) bit (1) aligned;
 47 declare (basno, value, admod, b29, iaddr) fixed bin (26);
 48 declare  string_ptr ptr;
 49 
 50 /* BASED STRUCTURES */
 51 
 52 declare  ascii (1:168) based (string_ptr) unaligned bit (9),
 53          ascii_string char (168) based (string_ptr) unaligned,
 54          bcd (1:252) based (string_ptr) unaligned bit (6),
 55          bcd_string bit (252*6) based (string_ptr) unaligned,
 56          asc4 bit (42*36) based (string_ptr) unaligned;
 57 
 58 /* EXTERNAL DATA */
 59 
 60 declare  eb_data_$bcd_table (0:127) external unaligned bit (6);
 61 
 62 /* INCLUDE FILES FOR ASCEVL */
 63 
 64 % include varcom;
 65 % include concom;
 66 % include codtab;
 67 % include erflgs;
 68 ^L
 69 /* program */
 70 
 71                                                             /* ACC pseudo-op. */
 72           chars_per_word = 4;
 73           max_length = hbound (ascii (*), 1);
 74           acc_type = "1"b;
 75           go to begin;
 76 
 77 ascevl_$acievl:                                             /* ACI pseudo-op. */
 78           entry (rslts) returns (fixed binary);
 79           chars_per_word = 4;
 80           max_length = hbound (ascii (*), 1);
 81           acc_type = "0"b;
 82           go to begin;
 83 
 84 ascevl_$ac4evl:                                             /* AC4 pseudo-op. */
 85           entry (rslts) returns (fixed binary);
 86           chars_per_word = 8;
 87           max_length = divide (length (asc4), 4.5, 17, 0);
 88           acc_type = "0"b;
 89           go to begin;
 90 
 91 ascevl_$bcdevl:                                             /* BCI pseudo-op. */
 92           entry (rslts) returns (fixed binary);
 93           chars_per_word = 6;
 94           max_length = hbound (bcd (*), 1);
 95           acc_type = "0"b;
 96 
 97 begin:
 98           too_long = "0"b;
 99 
100           if acc_type then
101                out = 2;
102           else
103                out = 1;                                     /* skip over count position if acc */
104 
105           string_ptr = addr (rslts);                        /* where to store chars */
106 
107           call inputs_$nxtnb;
108           quote = brk (2);                                  /* use the actual ASCII character as the bounding character in binary */
109 
110           do while ("1"b);
111                call inputs_$ascii_literal;                  /* get next character */
112                if brk (2) = quote then do;                  /* if termination character */
113                     call inputs_$next;                      /* get next character */
114                     if brk (2) ^= quote then do;            /* two termination chars in a row means insert one of them */
115 
116 /* check for optional length field. */
117                          if brk (1) = icomma then do;
118                               if (varevl_ (invrvl, basno, value, admod, b29, iaddr) = 0) then
119                                    go to undefined_symbol_error;
120 
121                               if iaddr ^= 0 then
122                                    go to lc_error;
123 
124                               if value > max_length then do;
125                                    too_long = "1"b;
126                                    value = max_length;
127                               end;
128 
129                               delta = value - out + 1;
130 
131                               if delta < 0 then
132                                    too_long = "1"b;
133                               else if delta > 0 then do;    /* avoid stupid IPR fault */
134                                    if chars_per_word = 4 then
135                                         substr (ascii_string, out, delta) = " ";
136                                    else if chars_per_word = 6 then
137                                         substr (bcd_string, 6 * out - 5, 6 * delta) = copy ("20"b3, delta);
138                                    else do;
139                                         pad_start = floor (out * 4.5) - 3;
140                                         pad_length = ceil (value * 4.5) + 1 - pad_start;
141                                         substr (asc4, pad_start, pad_length) = "0"b;
142                                    end;
143                                    out = out + delta;
144                               end;
145                          end;
146 error_return:
147                          n_words = divide (out - 1 + chars_per_word - 1, chars_per_word, 18, 0);
148                          delta = chars_per_word * n_words - out + 1;
149 
150                          if delta > 0 then                  /* avoid IPR fault */
151                               if chars_per_word = 4 then
152                                    substr (ascii_string, out, delta) = (3) "^@"; /* \000 */
153                               else if chars_per_word = 6 then
154                                    substr (bcd_string, 6 * out - 5, 6 * delta) = (30)"0"b;
155                               else
156                                    substr (asc4, floor (out * 4.5) - 3, floor (4.5 * delta)) = "0"b;
157 
158                          if acc_type then
159                               ascii (1) = bit (bin (out - 2, 9), 9);
160 
161                          if too_long then
162                               prnte = 1;
163 
164                          return (n_words);
165                     end;
166                end;
167 
168                if out > max_length then
169                     too_long = "1"b;
170                else do;
171                     if chars_per_word = 4 then              /* put this char in result string */
172                          ascii (out) = bit (bin (brk (2), 9), 9);
173                     else if chars_per_word = 6 then
174                          bcd (out) = eb_data_$bcd_table (brk (2));
175                     else do;
176                          pad_start = ceil (out * 4.5) - 3;
177                          if mod (out, 2) ^= 0 then
178                               substr (asc4, pad_start - 1, 1) = "0"b;
179                          substr (asc4, pad_start, 4) = substr (unspec (brk (2)), 33, 4);
180                     end;
181                     out = out + 1;
182                end;
183           end;
184 
185 lc_error:
186           prnte = 1;
187           go to error_return;
188 
189 undefined_symbol_error:
190           prntu = 1;
191           go to error_return;
192 
193      end ascevl_$accevl;