1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  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 equal: proc;
 14 
 15 /* Comparison and boolean active functions.
 16 
 17    The following functions compare arbitrary strings by collating sequence:
 18 
 19           equal A B           "true" if A = B, "false" otherwise.
 20           less A B            "true" if A < B, "false" otherwise.
 21           greater A B         "true" if A > B, "false" otherwise.
 22 
 23    The following compare numbers; an error is reported if both arguments are
 24    not character string representations of valid PL/I real constants.
 25    Comparisons are done using float dec (59) arithmetic.
 26 
 27           nequal A B          "true" if A = B, "false" otherwise.
 28           nless A B           "true" if A < B, "false" otherwise.
 29           ngreater A B        "true" if A > B, "false" otherwise.
 30 
 31    The following perform logical operations on arguments having the
 32    values true and false:
 33 
 34           not A               "true" if A = "false", "false" if A = "true".
 35           and A1 A2 ... An    "true" if all Ai are "true", "false" otherwise.
 36           or A1 A2 ... An     "true" if any Ai is "true", "false" otherwise.
 37 
 38    All of these active functions print their result when called as commands.
 39 
 40  Initial version 3/4/74 by Barry L. Wolman */
 41 /* Time comparison functions added 11/28/78 by Jim Homan */
 42 /* Rewritten 01/18/80 by S. Herbst */
 43 /* Bug fixed in time comparisons 04/14/80 S. Herbst */
 44 /* Changed and, or to accept 0 args or 1 arg 09/16/82 S. Herbst */
 45 /* Added -date to date_time comparison commands 10/26/82 S. Herbst */
 46 /* Fixed dteq and friends to not reject negative times 11/23/82 S. Herbst */
 47 /* Added the date_time_valid function 11/23/82 J. A. Bush */
 48 /* removed a portion, creating date_time_equal.pl1 02/07/84 J A Falksen */
 49 
 50           dcl     arg1                   char (arg_len (1)) based (arg_ptr (1));
 51           dcl     arg2                   char (arg_len (2)) based (arg_ptr (2));
 52 
 53           dcl     return_arg             char (return_len) varying based (return_ptr);
 54 
 55           dcl     (bad_arg, usage)       char (168);
 56           dcl     myname                 char (32);
 57 
 58           dcl     arg_ptr                (2) ptr;
 59           dcl     return_ptr             ptr;
 60 
 61           dcl     (af_sw, bool_value)    bit (1);
 62 
 63           dcl     (number1, number2)     float dec (59);
 64 
 65           dcl     arg_len                (2) fixed bin;
 66           dcl     (arg_count, i, return_len) fixed bin;
 67           dcl     code                   fixed bin (35);
 68 
 69           dcl     error_table_$not_act_fnc fixed bin (35) ext;
 70 
 71           dcl     get_arg                entry (fixed bin, ptr, fixed bin, fixed bin (35))automatic;
 72           dcl     complain               entry variable options (variable);
 73 
 74           dcl     (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
 75           dcl     (com_err_, com_err_$suppress_name) entry options (variable);
 76           dcl     cu_$af_return_arg      entry (fixed bin, ptr, fixed bin, fixed bin (35));
 77           dcl     cu_$arg_ptr            entry (fixed bin, ptr, fixed bin, fixed bin (35));
 78           dcl     cu_$af_arg_ptr         entry (fixed bin, ptr, fixed bin, fixed bin (35));
 79           dcl     ioa_                   entry options (variable);
 80 
 81           dcl     convert                builtin;
 82 
 83           dcl     conversion             condition;
 84                                                             /*^L*/
 85           myname = "equal";
 86           usage = "string1 string2";
 87 
 88           call get_args;
 89 
 90           if arg1 = arg2 then go to TRUE;
 91           else go to FALSE;
 92 
 93 
 94 TRUE:     if af_sw then return_arg = "true";
 95           else call ioa_ ("true");
 96           return;
 97 
 98 FALSE:    if af_sw then return_arg = "false";
 99           else call ioa_ ("false");
100           return;
101 
102 USAGE:    if af_sw then call active_fnc_err_$suppress_name (0, myname, "Usage:  ^a ^a", myname, usage);
103           else call com_err_$suppress_name (0, myname, "Usage:  ^a ^a", myname, usage);
104 
105 RETURN:   return;
106 
107 
108 less: entry;
109 
110           myname = "less";
111           usage = "string1 string2";
112 
113           call get_args;
114 
115           if arg1 < arg2 then go to TRUE;
116           else go to FALSE;
117 
118 
119 greater: entry;
120 
121           myname = "greater";
122           usage = "string1 string2";
123 
124           call get_args;
125 
126           if arg1 > arg2 then go to TRUE;
127           else go to FALSE;
128 
129 
130 nequal: entry;
131 
132           myname = "nequal";
133           usage = "num1 num2";
134 
135           call get_args;
136           call convert_numbers;
137 
138           if number1 = number2 then go to TRUE;
139           else go to FALSE;
140 
141 
142 nless: entry;
143 
144           myname = "nless";
145           usage = "num1 num2";
146 
147           call get_args;
148           call convert_numbers;
149 
150           if number1 < number2 then go to TRUE;
151           else go to FALSE;
152 
153 
154 ngreater: entry;
155 
156           myname = "ngreater";
157           usage = "num1 num2";
158 
159           call get_args;
160           call convert_numbers;
161 
162           if number1 > number2 then go to TRUE;
163           else go to FALSE;
164 
165 and: entry;
166 
167           myname = "and";
168           usage = "true_false_args";
169 
170           call get_count;
171           if arg_count = 0 then bool_value = "1"b;          /* and-identity */
172           else bool_value = get_boolean (1);
173           do i = 2 to arg_count;
174                bool_value = bool_value & get_boolean (i);
175           end;
176 
177           if bool_value then go to TRUE;
178           else go to FALSE;
179 
180 
181 or:  entry;
182 
183           myname = "or";
184           usage = "true_false_args";
185 
186           call get_count;
187           if arg_count = 0 then bool_value = "0"b;          /* or-identity */
188           else bool_value = get_boolean (1);
189           do i = 2 to arg_count;
190                bool_value = bool_value | get_boolean (i);
191           end;
192 
193           if bool_value then go to TRUE;
194           else go to FALSE;
195 
196 
197 not: entry;
198 
199           myname = "not";
200           usage = "true_or_false";
201 
202           call get_count;
203           if arg_count ^= 1 then go to USAGE;
204           if get_boolean (1) then go to FALSE;
205           else go to TRUE;
206                                                             /*^L*/
207 get_count: proc;
208 
209 /* This internal procedure tests for af invocation and gets argument count. */
210 
211           call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
212 
213           if code = error_table_$not_act_fnc then do;
214                     af_sw = "0"b;
215                     complain = com_err_;
216                     get_arg = cu_$arg_ptr;
217                end;
218           else do;
219                     af_sw = "1"b;
220                     complain = active_fnc_err_;
221                     get_arg = cu_$af_arg_ptr;
222                end;
223 
224      end get_count;
225 
226 
227 
228 get_args: proc;
229 
230 /* This internal procedure gets two arguments. */
231 
232           dcl     j                      fixed bin;
233 
234           call get_count;
235 
236           j = 0;
237 
238           if arg_count ^= 2 then go to USAGE;
239           call get_arg (1, arg_ptr (1), arg_len (1), code);
240           call get_arg (2, arg_ptr (2), arg_len (2), code);
241 
242      end get_args;
243 
244 
245 
246 get_boolean: proc (arg_index) returns (bit (1) aligned);
247 
248 /* This internal procedure gets a single true or false argument. */
249 
250           dcl  arg_index                 fixed bin;
251 
252           call get_arg (arg_index, arg_ptr (1), arg_len (1), code);
253 
254           if arg1 = "true" then return ("1"b);
255           else if arg1 = "false" then return ("0"b);
256           else do;
257                     call complain (0, myname, "Must be true or false, not ""^a""", arg1);
258                     go to RETURN;
259                end;
260 
261      end get_boolean;
262                                                             /*^L*/
263 convert_numbers: proc;
264 
265 /* This internal procedure converts both arguments to real numbers. */
266 
267           on conversion begin;
268                     bad_arg = arg1;
269                     go to BAD;
270                end;
271           number1 = convert (number1, arg1);
272           revert conversion;
273 
274           on conversion begin;
275                     bad_arg = arg2;
276                     go to BAD;
277                end;
278           number2 = convert (number2, arg2);
279           revert conversion;
280 
281           return;
282 
283 BAD:      call complain (0, myname, "Invalid number ^a", bad_arg);
284           go to RETURN;
285 
286      end convert_numbers;
287 
288 
289 
290      end equal;