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 /* format: style2 */
 12 rank:
 13      procedure;
 14 
 15 /* **********************************************************************
 16    *  Active function/command to implement the PL/I builtin functions   *
 17    *  rank and byte.                                                    *
 18    *                                                                    *
 19    *  Written August 1981 by Warren Johnson.                            *
 20    *  Modified as per MCR for installation, November 1981, Benson I.    *
 21    *                                                       Margulies    *
 22    *  Modified to fix NNo and other problems, BIM, 10/82                *
 23    *  Modified to fix "byte 32" and "byte 34" (i.e. to use requote_     *
 24    *    before calling ioa_), June 1983, Chris Jones                    *
 25    *  Modified to fix arg processing errors, 1 Nov 1983 C Spitzer       *
 26    ********************************************************************** */
 27 
 28           dcl     active_fnc_err_        entry options (variable);
 29           dcl     com_err_               entry options (variable);
 30           dcl     cu_$af_return_arg      entry (fixed, ptr, fixed (21), fixed (35));
 31           dcl     cu_$arg_ptr            entry (fixed, ptr, fixed (21), fixed (35));
 32           dcl     cv_dec_check_          entry (char (*), fixed (35)) returns (fixed (35));
 33           dcl     cv_oct_check_          entry (char (*), fixed (35)) returns (fixed (35));
 34           dcl     ioa_                   entry options (variable);
 35           dcl     ioa_$rsnnl             entry options (variable);
 36           dcl     requote_string_        entry (char (*)) returns (char (*));
 37 
 38           dcl     (rank, byte, rtrim, substr, length, before, index)
 39                                          builtin;
 40 
 41           dcl     error_table_$badopt    fixed (35) external;
 42           dcl     error_table_$bigarg    fixed (35) external;
 43           dcl     error_table_$noarg     fixed (35) external;
 44           dcl     error_table_$not_act_fnc
 45                                          fixed (35) external;
 46           dcl     error_table_$too_many_args
 47                                          fixed (35) external;
 48 
 49           dcl     error_table_$smallarg  fixed bin (35) ext static;
 50           dcl     error_table_$bad_conversion
 51                                          fixed bin (35) ext static;
 52 
 53           dcl     gripe                  entry variable options (variable);
 54 
 55           dcl     (nargs, i)             fixed;
 56           dcl     (rsl, argl)            fixed (21);
 57           dcl     (rv, code)             fixed (35);
 58 
 59           dcl     (argp, rsp)            ptr;
 60 
 61           dcl     rs                     char (rsl) varying based (rsp);
 62           dcl     arg                    char (argl) based (argp);
 63           dcl     cname                  char (4);
 64           dcl     have_main_arg          bit (1) aligned;
 65           dcl     main_arg               char (32);
 66 
 67           dcl     (command, octal_sw)    bit (1);
 68 %page;
 69           cname = "rank";
 70           go to JOIN;
 71 
 72 byte:
 73      entry;
 74 
 75           cname = "byte";
 76 
 77 JOIN:
 78           octal_sw = "0"b;
 79           call cu_$af_return_arg (nargs, rsp, rsl, code);
 80           if code = error_table_$not_act_fnc
 81           then do;                                          /* called as a command */
 82                     command = "1"b;
 83                     gripe = com_err_;
 84                end;
 85           else if code = 0
 86           then do;                                          /* active function */
 87                     command = "0"b;
 88                     gripe = active_fnc_err_;
 89                end;
 90           else do;
 91                     call com_err_ (code, cname);
 92                     return;
 93                end;
 94 
 95           if nargs = 0
 96           then do;                                          /* one input arg required, one optional */
 97 USAGE:
 98                     call gripe (error_table_$noarg, cname, "^/Usage is: ^[[^]^a ^[CHAR^;NO^] {-control_args}^[]^]",
 99                          ^command, cname, cname = "rank", ^command);
100                     return;
101                end;
102 
103           have_main_arg = "0"b;
104 
105           do i = 1 to nargs;
106                call cu_$arg_ptr (i, argp, argl, (0));
107 
108                if ^(length (arg) > 1 & char (arg, 1) = "-")
109                then do;
110                          if have_main_arg
111                          then do;
112                                    call com_err_ (error_table_$too_many_args, cname,
113                                         "Only one character may be specified. ^a is the second.", arg);
114                                    return;
115                               end;
116                          have_main_arg = "1"b;
117                          main_arg = arg;                    /* so, it can be truncated */
118                     end;
119 
120                else if (arg = "-octal" | arg = "-oc") & cname = "rank"
121                                                             /* not on byte */
122                then octal_sw = "1"b;
123                else if (arg = "-decimal" | arg = "-dec") & cname = "rank"
124                then octal_sw = "0"b;                        /* allow defaulting */
125                else do;
126                          call gripe (error_table_$badopt, cname, arg);
127                          return;
128                     end;
129           end;
130 
131           if ^have_main_arg
132           then go to USAGE;
133 
134           if cname = "rank"                                 /* RANK */
135           then do;
136                     if length (rtrim (main_arg)) > 1
137                     then do;
138                               call gripe (error_table_$bigarg, cname,
139                                    "Only one character may be given. ""^a"" is too long.", main_arg);
140                               return;
141                          end;
142 
143 
144                     rv = rank (char (main_arg, 1));
145                     if octal_sw
146                     then if command
147                          then call ioa_ ("^o", rv);
148                          else call ioa_$rsnnl ("^o", rs, (rsl), rv);
149                     else if command
150                     then call ioa_ ("^d", rv);
151                     else call ioa_$rsnnl ("^d", rs, (rsl), rv);
152                end;
153 
154           else do;                                          /* BYTE */
155                     if character (reverse (rtrim (main_arg)), 1) = "o"
156                     then rv = cv_oct_check_ (before (main_arg, "o"), code);
157                     else rv = cv_dec_check_ (main_arg, code);
158                     if code ^= 0
159                     then do;
160                               call gripe (error_table_$bad_conversion, cname, "Invalid number: ^a.", main_arg);
161                               return;
162                          end;
163                     else if rv < 0 | rv > 511
164                     then do;
165                               call gripe (0, cname, "Number out of range: ^a.", main_arg);
166                               return;
167                          end;
168                     else if command
169                     then call ioa_ ("^a", requote_string_ (byte (rv)));
170                     else rs = byte (rv);
171                end;
172 
173           if ^command
174           then rs = requote_string_ ((rs));
175 
176           return;
177 
178      end rank;