1
2
3
4
5
6
7
8
9
10
11
12 rank:
13 procedure;
14
15
16
17
18
19
20
21
22
23
24
25
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;
82 command = "1"b;
83 gripe = com_err_;
84 end;
85 else if code = 0
86 then do;
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;
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;
118 end;
119
120 else if (arg = "-octal" | arg = "-oc") & cname = "rank"
121
122 then octal_sw = "1"b;
123 else if (arg = "-decimal" | arg = "-dec") & cname = "rank"
124 then octal_sw = "0"b;
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"
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;
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;