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 underline:          procedure;                              /* active function which returns its input args,  */
 12                                                             /* separated by blanks and underlined, as a       */
 13                                                             /* quoted string.                                 */
 14 
 15      dcl                                                    /*        automatic variables                     */
 16           Larg                          fixed bin,          /* length of an input arg.                        */
 17           Lcom                          fixed bin,          /* length of command's output string.             */
 18           Lret                          fixed bin,          /* maximum length of our return value.            */
 19           Nargs                         fixed bin,          /* number of arguments we were passed.            */
 20           Parg                          ptr,                /* ptr to an input argument.                      */
 21           Parg_list                     ptr,                /* ptr to caller's argument list.                 */
 22           Pret                          ptr,                /* ptr to our return value.                       */
 23           code                          fixed bin (35),     /* an error code value.                           */
 24           i                             fixed bin;          /* a do-group index.                              */
 25 
 26 
 27      dcl                                                    /*        based variables                         */
 28           arg_array (Larg)              char(1) based (Parg),
 29                                                             /* an input argument.                             */
 30           arg_char                      char(1) based (Parg),
 31                                                             /* next char of our input argument.               */
 32           ret                           char(Lret) varying based (Pret);
 33                                                             /* overlay for portions of our return value.      */
 34 
 35 
 36      dcl (addr, length, substr)         builtin;
 37 
 38 
 39      dcl                                                    /*        entries                                 */
 40           cu_$af_return_arg             entry (fixed bin, ptr, fixed bin, fixed bin(35)),
 41           cu_$arg_count                 entry returns (fixed bin),
 42           cu_$arg_list_ptr              entry returns (ptr),
 43           cu_$arg_ptr                   entry (fixed bin, ptr, fixed bin, fixed bin(35)),
 44           cu_$arg_ptr_rel               entry (fixed bin, ptr, fixed bin, fixed bin(35), ptr),
 45           iox_$put_chars                entry (ptr, ptr, fixed bin, fixed bin(35));
 46 
 47 
 48      dcl                                                    /*        static variables                        */
 49           BS_UNDERSCORE                 char(2) aligned int static options(constant) init ("^H_"),
 50           NL                            char(1) aligned int static options(constant) init ("
 51 "),
 52           QUOTE                         char(1) aligned int static options(constant) init (""""),
 53           QUOTE_QUOTE                   char(2) aligned int static options(constant) init (""""""),
 54           SPACE                         char(1) aligned int static options(constant) init (" "),
 55           UNDERSCORE_BS                 char(2) aligned int static options(constant) init ("_^H"),
 56           iox_$user_output              ptr ext static;
 57 ^L
 58 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 59 
 60 
 61           call cu_$af_return_arg (Nargs, Pret, Lret, code); /* see how we were called.                        */
 62           if code = 0 then do;                              /* as an active function.                         */
 63                if Nargs = 0 then do;                        /* no input args.  Return a null string.          */
 64                     ret = QUOTE_QUOTE;
 65                     return;
 66                     end;
 67                ret = QUOTE;
 68                do i = 1 to Nargs;                           /* add args to return string one by one.                    */
 69                     call cu_$arg_ptr (i, Parg, Larg, code);
 70                     do while (Larg > 0);                    /* double any quotes while copying arg.           */
 71                          if      arg_char < SPACE then
 72                               ret = ret || arg_char;
 73                          else if arg_char = SPACE then
 74                               ret = ret || "_";             /* convert spaces to _s.                          */
 75                          else if arg_char = QUOTE then do;  /* double quotes as we go. (""^H_)                */
 76                               ret = ret || QUOTE_QUOTE;
 77                               ret = ret || BS_UNDERSCORE;
 78                               end;
 79                          else if arg_char < "_" then do;
 80                               ret = ret || arg_char;        /* canonicalize the string as we go.              */
 81                               ret = ret || BS_UNDERSCORE;
 82                               end;
 83                          else if arg_char > "_" then do;
 84                               ret = ret || UNDERSCORE_BS;
 85                               ret = ret || arg_char;
 86                               end;
 87                          else
 88                               ret = ret || "_";
 89                          if Larg > 1 then Parg = addr(arg_array(2));
 90                          Larg = Larg - 1;
 91                          end;
 92                     ret = ret || SPACE;                     /* separate args by a space in output string.     */
 93                     end;
 94                if substr(ret,length(ret)) = SPACE then      /* remove space after last argument.              */
 95                     ret = substr(ret,1,length(ret)-1);
 96                ret = ret || QUOTE;
 97                end;
 98           else do;                                          /* command merely output's its args, separated by */
 99                Nargs = cu_$arg_count();                     /* blanks.                                        */
100                Lcom = 0;                                    /* compute max length of output string.           */
101                do i = 1 to Nargs;
102                     call cu_$arg_ptr(i, Parg, Larg, code);
103                     Lcom = Lcom + Larg*3 + 1;
104                     end;
105                if Nargs > 0 then do;
106                     Parg_list = cu_$arg_list_ptr();
107 begin;
108      dcl  com                           char(Lcom) varying aligned init ("");
109                     do i = 1 to Nargs;
110                          call cu_$arg_ptr_rel (i, Parg, Larg, code, Parg_list);
111                          do while (Larg > 0);               /* no doubling of quotes needed here.             */
112                               if      arg_char < SPACE then
113                                    com = com || arg_char;
114                               else if arg_char = SPACE then
115                                    com = com || "_";        /* convert spaces to _s.                          */
116                               else if arg_char < "_" then do;
117                                    com = com || arg_char;   /* canonicalize the string as we go.              */
118                                    com = com || BS_UNDERSCORE;
119                                    end;
120                               else if arg_char > "_" then do;
121                                    com = com || UNDERSCORE_BS;
122                                    com = com || arg_char;
123                                    end;
124                               else
125                                    com = com || "_";
126                               if Larg > 1 then Parg = addr(arg_array(2));
127                               Larg = Larg - 1;
128                               end;
129                          com = com || " ";
130                          end;
131                     if substr(com,length(com)) = SPACE then /* remove space after last argument.              */
132                          com = substr(com,1,length(com)-1);
133                     call iox_$put_chars (iox_$user_output, addr(substr(com,1)), length(com), code);
134           end;
135                     end;
136                call iox_$put_chars (iox_$user_output, addr(NL), 1, code);
137                end;
138 
139           end underline;