1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 
 12 
 13 /****^  HISTORY COMMENTS:
 14   1) change(2021-12-05,GDixon), approve(2022-07-13,MCR10101),
 15      audit(2022-07-27,Swenson):
 16      A) Remove code for converting integer string to float dec(59)
 17         (with support for bases 2, 4, 8, 10, 16 via radix indicator:
 18          b q o x).
 19      B) Replace with call to cv_fixed_point_string_ which does same
 20         type of conversion, and supports additional radix indicator
 21         formats.
 22      C) For binary and octal command/AFs with "u" (for unspec) input
 23         value, supply leading 0's for binary/octal digits zero-suppressed
 24         by numeric_to_ascii_base_.
 25   2) change(2022-05-12,GDixon), approve(2022-07-13,MCR10101),
 26      audit(2022-07-27,Swenson):
 27      A) Use new calling sequence for numeric_to_ascii_base_.
 28      B) Add radix entry point supporting all numbering systems between
 29         2 and 16 inclusive.
 30                                                    END HISTORY COMMENTS */
 31 
 32 
 33 hexadecimal: hex: proc;
 34 
 35 /* Implements the hexadecimal, decimal, octal, binary and radix command/afs.
 36    Written 03/09/81 S. Herbst */
 37 
 38 
 39 /* Based */
 40 
 41 dcl  arg char (arg_len) based (arg_ptr);
 42 dcl  return_arg char (return_len) varying based (return_ptr);
 43 
 44 
 45 /* Automatic */
 46 
 47 dcl  ME char (32);
 48 dcl  val_str char (256) varying;
 49 
 50 dcl  af_sw bit (1) aligned;
 51 
 52 dcl (arg_ptr, return_ptr) ptr;
 53 
 54 dcl  char8 char (8);
 55 dcl  float59 float dec (59);
 56 dcl  fixed71 fixed bin (71);
 57 dcl  required_unspec_chars fixed bin;
 58 dcl  NO_UNSPEC_CHARS fixed bin int static options(constant) init(0);
 59 dcl (arg_len, return_len) fixed bin (21);
 60 dcl (arg_count, arg_index, base) fixed bin;
 61 dcl  code fixed bin (35);
 62 
 63 dcl (error_table_$bad_arg,
 64      error_table_$bad_conversion,
 65      error_table_$not_act_fnc) fixed bin (35) ext static;
 66 
 67 dcl  complain entry variable options (variable);
 68 
 69 dcl (active_fnc_err_, active_fnc_err_$af_suppress_name) entry options (variable);
 70 dcl (com_err_, com_err_$suppress_name) entry options (variable);
 71 dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 72 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 73 dcl  cv_fixed_point_string_ entry (char(*), fixed bin, bit(*), fixed bin(35)) returns(float dec(59));
 74 dcl (ioa_, ioa_$nnl) entry options (variable);
 75 dcl  numeric_to_ascii_base_ entry (float dec(59), fixed bin, fixed bin) returns(char(256) var);
 76 
 77 dcl  WHITESPACE  char (2) static options (constant) init ("           ");     /* SP HT */
 78 
 79 dcl (convert, copy, divide, index, length, low, max, substr, verify, unspec) builtin;
 80 %page;
 81 
 82           ME = "hexadecimal";
 83           base = 16;
 84           go to START;
 85 
 86 decimal: dec: entry;
 87 
 88           ME = "decimal";
 89           base = 10;
 90           go to START;
 91 
 92 octal: oct: entry;
 93 
 94           ME = "octal";
 95           base = 8;
 96           go to START;
 97 
 98 binary: bin: entry;
 99 
100           ME = "binary";
101           base = 2;
102           go to START;
103 
104 radix:    entry;
105 
106           ME = "radix";
107           base = 0;
108           go to START;
109 
110 
111 START:
112           call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
113           if code = error_table_$not_act_fnc then do;
114                if arg_count = 0 then do;
115 BAD_COM_SYNTAX:     call com_err_$suppress_name (0, ME, "Syntax:  ^a ^[BASE ^]NUM_ARGS", ME, base = 0);
116                     return;
117                end;
118                af_sw = "0"b;
119                complain = com_err_;
120           end;
121           else if code = 0 then do;
122                if arg_count = 0 then do;
123 BAD_AF_SYNTAX:      call active_fnc_err_$af_suppress_name (0, ME, "Syntax:  [^a ^[BASE ^]NUM_ARGS]", ME, base = 0);
124                     return;
125                end;
126                af_sw = "1"b;
127                complain = active_fnc_err_;
128                return_arg = "";
129           end;
130           else do;
131                call active_fnc_err_ (code, ME);
132                return;
133           end;
134 
135           if  base = 0  then do;                            /* Get BASE arg for radix command/af                      */
136                if  arg_count = 1  then do;
137                     if af_sw then  go to BAD_AF_SYNTAX;
138                     else  go to BAD_COM_SYNTAX;
139                end;
140                else do;
141                     arg_index = 1;
142                     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
143 
144                     if  verify(arg, "0123456789") = 0  then do;
145                          base = convert(base, arg);
146                          if  2 <= base  &  base <= 16  then;
147                          else do;
148                               call complain( error_table_$bad_arg, ME,
149                                    "^a^/  Supported numbering systems: 2 <= BASE <= 16", arg);
150                               return;
151                          end;
152                     end;
153                     else do;
154                          call complain( error_table_$bad_conversion, ME,
155                               "^a^/  radix supports only a BASE in the range:  2 <= BASE <= 16", arg);
156                          return;
157                     end;
158                end;
159           end;
160           else arg_index = 0;
161 
162 PROCESS_ARGS:
163           do arg_index = arg_index+1 to arg_count;
164                required_unspec_chars = NO_UNSPEC_CHARS;     /* Setup of non-unspec output.                            */
165 
166                call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
167 
168 dcl  BASE_10 fixed bin int static options (constant) init (10);
169 
170                float59 = cv_fixed_point_string_ (arg, BASE_10, FIXED_POINT_EXPONENT, code);
171                                                             /* Let subroutine do the conversion work.  It handles     */
172                                                             /*  radix chars more completely than PL/1 convert.        */
173 
174                if code = error_table_$bad_conversion &
175                   substr (arg, arg_len, 1) = "u" then do;   /* cv_fixed_point_string_ does not support "u" radix      */
176                     arg_len = arg_len - 1;                  /*  indicator.  Continue to support that conversion here. */
177                     if arg_len > 8 then do;
178                          call complain (0, ME, """u"" conversion only allows 8 characters.  ^au", arg);
179                          return;
180                     end;
181                     char8 = low (8 - arg_len) || arg;
182                     unspec (fixed71) = unspec (char8);
183                     float59 = fixed71;
184 
185                     if  base = 2  then                      /* Binary output requires 9 bits for each unspec(char)    */
186                          required_unspec_chars = arg_len * BITS_PER_CHAR;
187                     else if  base = 8  then                 /* Octal output requires 3 digits for each unspec(char)   */
188                          required_unspec_chars = arg_len * divide( BITS_PER_CHAR, 3, 17, 0 );
189                end;
190                else if code ^= 0 then do;
191                     if (index(WHITESPACE, substr(arg, 1, 1)) > 0) |
192                        (index(WHITESPACE, substr(arg, arg_len, 1)) > 0) then
193                          call complain (code, ME, """^a""", arg);
194                     else call complain (code, ME, "^a", arg);
195                     return;
196                end;
197 
198                val_str = numeric_to_ascii_base_ (float59, 0, base);
199                if  required_unspec_chars > 0  then          /* Supply leading 0's for bin/oct unspec output.          */
200                     val_str = copy("0", max(0, required_unspec_chars - (length(val_str)-1) ) )  || val_str;
201                                                             /*  val_str ends with radix sub-field: either 'b' or 'o'  */
202 APPEND:
203                if af_sw then do;
204                     if return_arg ^= "" then return_arg = return_arg || " ";
205                     return_arg = return_arg || val_str;
206                end;
207                else call ioa_$nnl ("^a ", val_str);
208 NEXT_ARG:
209           end PROCESS_ARGS;
210 
211           if ^af_sw then call ioa_ ("");
212 %page;
213 %include cv_fixed_point_string_;
214 %include system_constants;
215 
216      end hexadecimal;