1 /****^  *********************************************************
  2         *                                                       *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1990 *
  4         *                                                       *
  5         * Copyright (c) 1972 by Massachusetts Institute of      *
  6         * Technology and Honeywell Information Systems, Inc.    *
  7         *                                                       *
  8         ********************************************************* */
  9 
 10 
 11 
 12 /****^  HISTORY COMMENTS:
 13   1) change(90-05-28,Blackmore), approve(90-03-10,MCR8163), audit(90-06-04,Vu),
 14      install(90-06-19,MR12.4-1015):
 15      Fix a problem in ask_ that causes bad interactions with exec_com.
 16                                                    END HISTORY COMMENTS */
 17 
 18 
 19 ask_: proc (prompt, ans);
 20 
 21 /* Terminal input processor, with goodies.
 22 
 23  THE PROMPTING ENTRIES:  prompt for more input if they don't get whats wanted.
 24 
 25    .      call ask_ (ctl_string, answer, ioa_args ... )
 26    will get a word from user_input. If the current line is empty,
 27    the program will format a prompting message, using the first arg as a control string
 28    and arguments from the third on as input for conversion. This message will be typed out.
 29 
 30    .      call ask_$ask_int (ctl_string, int, ioa_args)
 31    will do the same thing but return an integer. The typed number
 32    may be integer or floating, positive or negative. Dollar signs and
 33    commas will be ignored.
 34 
 35    .      call ask_$ask_flo (ctl_string, flo, ioa_args ... )
 36    .      call ask_$ask_line (ctl_string, line, ioa_args ... )
 37    will return, respectively, a floating number and the rest of the line
 38    .      call ask_$ask_yn (ctl_string, ans, ioa_args... )
 39    will return either the character string "yes" or "no"
 40    .      call ask_$ask_nf (ctl_string, ans, ioa_args ... )
 41    will return either the character string "on" or "off"
 42 
 43 
 44 THE CHECKING ENTRIES:  return 'flag' to indicate success or failure.
 45 
 46    .      call ask_$ask_c (ans, flag)
 47    will set flag nonzero and return into ans if anything is there
 48    similarly,
 49    .      call ask_$ask_cint (int, flag)
 50    .      call ask_$ask_cflo (flo, flag)
 51    .      call ask_$ask_cline (line, flag)
 52    .      call ask_$ask_cyn (ans, flag)
 53    .      call ask_$ask_cnf (ans, flag)
 54 
 55 
 56 THE PEEKING ENTRIES:  don't change current position in input line.
 57 
 58    .      call ask_$ask_n (ans, flag)
 59    .      call ask_$ask_nline (line, flag)
 60    will work like 'ask_c' but leaves the next word there.
 61 
 62    .      call ask_$ask_nflo (flo, flag)
 63    .      call ask_$ask_nint (int, flag)
 64    .      call ask_$ask_nyn (ans, flag)
 65    .      call ask_$ask_nnf (ans, flag)
 66    are also peek entries, but will return flag as -1 if there
 67    is something on the line but it's not a number (or yes or no, or on or off).
 68 
 69 
 70 OTHER ENTRIES:
 71 
 72    .      call ask_$ask_clr
 73    to reset the line buffer to empty, on the first call or in case of error.
 74    (note that you don't want to pass int static between progs)
 75 
 76    .      call ask_$ask_prompt (ctl_string, ioa_args ... )
 77    causes a new inputline to be prompted for & read in
 78 
 79    .      call ask_$ask_setline (input)
 80    sets the input line. It can have a newline character or not.
 81 
 82 
 83  NOTE: the line buffer, its length and current index, are among the things kept
 84    in internal static storage by this subroutine.
 85 
 86 
 87    Initial coding 12/69, THVV
 88    Modified 7/70 to call formline_, THVV
 89    Modified 9/72 to call general_rs, THVV
 90    Modified 8/83 to allow "y" or "n" and add nf entries, Jim Lippard
 91    */
 92 
 93 dcl (addr, index, length, min, rtrim, substr) builtin;
 94 
 95 dcl (line char (128) aligned,                               /* Line typed by user. */
 96      empty bit (1) init ("1"b),                             /* TRUE if need another line. */
 97      i fixed bin init (1),                                  /* Index in line. */
 98      nchr fixed bin (21),                                   /* Length of line. */
 99      prompt_len fixed bin,                                  /* length of prompt */
100      blank char (1) init (" ") aligned,                     /* Constant blank. */
101      NL char (1) aligned init ("
102 "),                                                         /* Constant newline */
103      tab char (1) init ("     ") aligned) int static;                 /* Constant tab. */
104 
105 dcl  prompt char (*),                                       /* Arg to ask with. */
106      ans char (*),                                          /* Arg where answer goes. */
107      flag fixed bin,                                        /* 1 if more on line */
108      int fixed bin,                                         /* integer return */
109      flo float bin;                                         /* float return */
110 
111 dcl (start, j, tdg) fixed bin,                              /* Temps. */
112      arglistp ptr,                                          /* ptr to argument list */
113      ftm float bin (63),                                    /* answer for number conversion */
114      fpm float bin (63),                                    /* fraction part multiplier */
115      oldi fixed bin,                                        /* what 'i' was at entry. */
116      fracsw bit (1) aligned,                                /* TRUE when converting fraction */
117      tf char (4) aligned,                                   /* temp for yes/no code */
118     (flosw, intsw, linesw, csw, nsw, ynsw, nfsw, prmsw) bit (1) aligned init ("0"b);
119 
120 dcl 1 ll aligned based (addr (line)),                       /* Overlay structure for line. */
121     2 ch (0: 127) char (1) unaligned;                       /* ... as character array. */
122 
123 dcl  ioa_$nnl entry options (variable),
124      cu_$arg_list_ptr entry (ptr),
125      iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)),
126      iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
127      iox_$user_input ptr ext static,
128      iox_$user_output ptr ext static,
129      ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*) aligned, fixed bin,
130      bit (1) aligned, bit (1) aligned);
131 
132 dcl  NL_HT_SP char (3) internal static options (constant) init ("
133            ");
134 
135 dcl  code fixed bin (35);
136 
137 /* - - - - - - - */
138 
139           go to join;                                       /* Entry to return symbol. */
140 
141 ask_c:    entry (ans, flag);                                /* entry to see if symbol, get if so */
142 
143           csw = "1"b;
144           go to join;
145 
146 ask_int:  entry (prompt, int);                              /* entry to get integer */
147 
148           intsw = "1"b;
149           go to join;
150 
151 ask_cint: entry (int, flag);                                /* entry to get integer if there */
152 
153           intsw, csw = "1"b;
154           go to join;
155 
156 ask_flo:  entry (prompt, flo);                              /* entry to get float */
157 
158           flosw = "1"b;
159           go to join;
160 
161 ask_cflo: entry (flo, flag);                                /* entry to get float if there */
162 
163           flosw, csw = "1"b;
164           go to join;
165 
166 ask_line: entry (prompt, ans);                              /* entry to get rest of line */
167 
168           linesw = "1"b;
169           go to join;
170 
171 ask_cline: entry (ans, flag);                               /* entry to get rest of line if there */
172 
173           linesw, csw = "1"b;
174           go to join;
175 
176 ask_n:    entry (ans, flag);                                /* peek entry */
177 
178           csw, nsw = "1"b;
179           go to join;
180 
181 ask_nint: entry (int, flag);                                /* Entry to peek at next integer */
182 
183           csw, intsw, nsw = "1"b;
184           go to join;
185 
186 ask_nflo: entry (flo, flag);                                /* Entry to peek at next floating */
187 
188           csw, nsw, flosw = "1"b;
189           go to join;
190 
191 ask_nline: entry (ans, flag);                               /* Entry to peek at rest of line */
192 
193           csw, nsw, linesw = "1"b;
194           go to join;
195 
196 ask_prompt: entry (prompt);                                 /* Entry to prompt & fill line */
197 
198           empty, prmsw = "1"b;
199           go to join;
200 
201 ask_yn:   entry (prompt, ans);
202 
203           ynsw = "1"b;
204           go to join;
205 
206 ask_cyn:  entry (ans, flag);
207 
208           csw, ynsw = "1"b;
209           go to join;
210 
211 ask_nyn:  entry (ans, flag);
212 
213           csw, nsw, ynsw = "1"b;
214           go to join;
215 
216 ask_nf:   entry (prompt, ans);
217 
218           nfsw = "1"b;
219           go to join;
220 
221 ask_cnf:  entry (ans, flag);
222 
223           csw, nfsw = "1"b;
224           go to join;
225 
226 ask_nnf:  entry (ans, flag);
227 
228           csw, nsw, nfsw = "1"b;
229           go to join;
230 
231 /* - - - - - - - - - - - - begin execution - - - - */
232 
233 join:     if empty then do;                                 /* If no line in buffer. */
234 mt:            if csw then do;                              /* if just looking, */
235                     flag = 0;                               /* report failure */
236                     return;                                 /* and go */
237                end;
238 read:          prompt_len = 120;                            /* Construct prompt */
239                if prmsw then j = 2;                         /* optional ioa args start at 2 */
240                else j = 3;                                  /* ... or 3, depending on entry */
241                call cu_$arg_list_ptr (arglistp);
242                call ioa_$general_rs (arglistp, 1, j, line, prompt_len, "1"b, "0"b);
243                nchr = prompt_len;
244                call iox_$put_chars (iox_$user_output, addr (line), nchr, code); /* Prompt the user. */
245 reread:
246                line = "";
247                nchr = 0;
248                call iox_$get_line (iox_$user_input, addr (line), 128, nchr, code); /* Get new line into buffer. */
249                nchr = length (rtrim (substr (line, 1, nchr), NL_HT_SP));
250                if nchr = 0 then go to read;                 /* If line is empty, get another */
251                empty = "0"b;                                /* Mark that we have it. */
252                i = 0;                                       /* Start with char. 1. */
253                if prmsw then return;                        /* go home if just prompt & read */
254           end;
255           oldi = i;                                         /* save starting position, for 'n' ents */
256 
257 findb:    if ch (i) ^= tab then if ch (i) ^= blank then go to first;
258           i = i + 1;                                        /* Skip over blank before symbol. */
259           if i >= nchr then go to mt;                       /* If chars left, keep looking. */
260           go to findb;                                      /* Keep looking. */
261 
262 first:    start = i;                                        /* Found start of symbol. */
263           if linesw then do;                                /* Does user want all of the rest? */
264                ans = substr (line, start+1, nchr-i);        /* yes */
265                if ^nsw then empty = "1"b;                   /* Buffer now empty, unless peek */
266                go to exit;
267           end;
268 finde:    if ch (i) = blank then go to last;                /* Look for end. */
269           if ch (i) = tab then go to last;                  /* ... */
270           i = i + 1;                                        /* ... */
271           if i >= nchr then go to last;                     /* If out of chars, give it out */
272           go to finde;                                      /* Keep looking. */
273 
274 last:     if intsw then go to do_num;                       /* Found symbol end. Number conversion? */
275           if flosw then do;                                 /* ... */
276 do_num:        fracsw = "0"b;                               /* set up */
277                fpm = 1.0e0;                                 /* ... */
278                ftm = 0.0e0;                                 /* ... */
279                if ch (start) = "$" then start = start + 1;  /* skip dollar sign */
280                if ch (start) = "-" then start = start + 1;  /* skip minus, come back for it */
281 
282                do j = start to i-1;                         /* Look at each char in symbol */
283                     if ch (j) = "," then;                   /* Ignore commas */
284                     else if ch (j) = "." then fracsw = "1"b; /* Decimal point starts fraction */
285                     else do;                                /* Turn char into digit */
286                          tdg = index ("0123456789", ch (j)) - 1;
287                          if tdg < 0 then do;
288 badd:                         if csw then do;               /* If conditional, get out. */
289 fail:                              flag = -1;               /* something there, but she's no lady */
290                                    i = oldi;                /* reset buffer index */
291                                    return;                  /* .. and go */
292                               end;
293                               call ioa_$nnl ("""^a"" non-numeric. Please retype: ",
294                               substr (line, start+1, i-start));
295                               go to reread;                 /* get fresh line */
296                          end;
297                          if fracsw then do;                 /* OK digit. Fraction? */
298                               fpm = fpm * 10.0e0;           /* yes, compute place */
299                               ftm = ftm + tdg/fpm;          /* insert digit */
300                          end;
301                          else ftm = 10.0e0*ftm + tdg;       /* insert integer digit */
302                     end;
303                end;
304                if ch (start-1) = "-" then ftm = -ftm;       /* sign control */
305                if intsw then int = ftm;                     /* return value */
306                else flo = ftm;                              /* ... */
307           end;
308           else if ynsw then do;                             /* Insist on yes or no? */
309                tf = substr (line, start+1, i-start);        /* Get answer */
310                if tf = "yes" | tf = "y" then do;
311                     ans = "yes";
312                     go to oky;
313                end;
314                else if tf = "no" | tf = "n" then do;
315                     ans = "no";
316                     go to oky;
317                end;
318                if csw then go to fail;                      /* Answer neither yes nor no. If conditional, exit */
319                call ioa_$nnl ("""^a"" is not ""yes"" or ""no"".  Please retype:  ", substr (line, start+1, i-start));
320                go to reread;
321           end;
322      else if nfsw then do;
323                tf = substr (line, start+1, i-start);
324                if tf = "on" then do;
325                     ans = "on";
326                     goto oky;
327                     end;
328                else if tf = "off" then do;
329                          ans = "off";
330                          goto oky;
331                          end;
332                if csw then go to fail;
333                call ioa_$nnl ("""^a"" is not ""on"" or ""off"". Please retype:  ", substr (line, start+1, i-start));
334                go to reread;
335      end;
336           else ans = substr (line, start+1, i-start);       /* one symbol wanted */
337 oky:                                                        /* Return symbol. */
338 
339 exit:     if csw then flag = 1;                             /* if conditional, report OK */
340           if nsw then i = oldi;                             /* if peeking, reset buffer ptr */
341           else if i >= nchr then empty = "1"b;              /* Not peeking. Is buffer empty? */
342           return;                                           /* And exit. */
343 
344 /* - - - */
345 
346 ask_clr:  entry;                                            /* Entry point to clear switches. */
347 
348           empty = "1"b;                                     /* Force read on next call. */
349           return;                                           /* Exit. */
350 
351 /* - - - - - - - - - - */
352 
353 ask_setline: entry (input);                                 /* Entry point to set input line */
354 
355 dcl  input char (*);
356 
357           line = input;                                     /* fill internal static buffer */
358           nchr = min (length (input), 128);                 /* now trim the line. start at end */
359           i = 0;
360           do while (nchr > 0);                              /* Trim trailing blanks and tabs off line. */
361                if ch (nchr) ^= blank then if ch (nchr) ^= tab then if ch (nchr) ^= NL then go to sltx;
362                nchr = nchr - 1;
363           end;
364 sltx:     if nchr > 0 then empty = "0"b;
365 
366      end ask_;