1 iso_date: proc;
  2 
  3 /* Multics active function of zero or one argument and zero or more
  4    control arguments to return a date in ISO YYMMDD or YYYYMMDD
  5    forms, with or without separators between components.
  6 
  7    John C. Klensin, 30 September 1982
  8    last modified, jck, 13 Dec 82: correct usage message.
  9 */
 10 /* Copyright (c) 1982 Massachusetts Institute of Technology */
 11 
 12 dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
 13      nargs fixed bin,
 14      max_length fixed bin (21),
 15      rtn_string_ptr ptr,
 16      return_string char (max_length) varying based (rtn_string_ptr),
 17     (cu_$arg_ptr, cu_$af_arg_ptr) entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
 18      ap ptr,
 19      al fixed bin (21),
 20      arg char (al) based (ap),
 21      err fixed bin (35);
 22 dcl  is_af bit (1) aligned;
 23 dcl  get_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable;
 24 
 25 dcl  separator char (1) varying aligned,
 26      year char (4) varying aligned,
 27      month char (4) varying aligned,
 28      day char (2);
 29 dcl  final_date char (12) varying aligned;
 30 
 31 dcl (com_err_, active_fnc_err_) entry options (variable),
 32      err_routine entry options (variable) variable;
 33 dcl  prog char (8) aligned initial ("iso_date") static internal options (constant);
 34 dcl  ii fixed bin;
 35 dcl  have_date bit (1) aligned,
 36      roman_month bit (1),
 37      actual_date fixed bin (71);
 38 dcl  mmddyy_string char (8);
 39 dcl  date_time_ entry (fixed bin (71), char (*)),
 40      convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
 41 dcl  full_year bit (1);
 42 dcl (error_table_$not_act_fnc,
 43      error_table_$badopt) static external fixed bin (35);
 44 dcl  ioa_ entry options (variable);
 45 
 46 dcl  month_pict picture "99",
 47      roman_months (12) char (4) varying aligned static internal options (constant)
 48      init ("I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX", "X", "XI", "XII");
 49 
 50 dcl (addr, null, substr, decimal) builtin;
 51 
 52 /* end of declarations */
 53 
 54 /* find out how many args, and whether or not active function */
 55           call cu_$af_return_arg (nargs, rtn_string_ptr, max_length, err);
 56           if err = 0 then do;
 57                err_routine = active_fnc_err_;
 58                get_arg = cu_$af_arg_ptr;
 59                is_af = "1"b;
 60           end;
 61           else if err = error_table_$not_act_fnc then do;
 62                err_routine = com_err_;
 63                get_arg = cu_$arg_ptr;
 64                is_af = "0"b;
 65           end;
 66           else do;
 67                call com_err_ (err, prog, "");
 68                return;
 69           end;
 70 
 71 /* initialize command arg loop */
 72           full_year,                                        /* default is two digits */
 73                roman_month,                                 /* off unless asked for */
 74                have_date = "0"b;                            /* not yet */
 75           separator = ".";
 76 
 77           do ii = 1 to nargs;
 78                call get_arg (ii, ap, al, err);
 79 
 80                if substr (arg, 1, 1) ^= "-" then do;        /* must be a date */
 81                     if have_date then do;
 82                          call err_routine (0, prog, "date already specified: ^a", arg);
 83                          return;
 84                     end;
 85                     call convert_date_to_binary_ (arg, actual_date, err);
 86                     if err ^= 0 then do;
 87                          call err_routine (err, prog, arg);
 88                          return;
 89                     end;
 90                     have_date = "1"b;
 91                end;
 92 
 93                else if arg = "-nsep" | arg = "-no_separator" then
 94                     separator = "";
 95 
 96                else if arg = "-separator" | arg = "-sep" then do;
 97                     call get_arg (ii+1, ap, al, err);
 98                     if err ^= 0 then do;
 99                          call err_routine (err, prog, arg);
100                          return;
101                     end;
102                     separator = arg;
103                     ii = ii + 1;
104                end;
105 
106                else if arg = "-roman_month" | arg = "-roman" then
107                     roman_month = "1"b;
108 
109                else if arg = "-full_year" then
110                     full_year = "1"b;
111                else if arg = "-short_year" then
112                     full_year = "0"b;
113 
114                else if arg = "-help" then do;
115                     call err_routine (0, prog,
116                          "Usage: ^a {date} {-nsep|-separator} {-full_year|-short_year} {-roman_month}", prog);
117                     return;
118                end;
119 
120                else do;
121                     call err_routine (error_table_$badopt, prog, arg);
122                     return;
123                end;
124           end;
125 
126 /* verify that we have a date.  If not, use the one now */
127           if ^have_date then do;
128                call convert_date_to_binary_ ("", actual_date, err);
129                if err ^= 0 then do;
130                     call err_routine (err, prog, "current date");
131                     return;
132                end;
133           end;
134 
135 /* and convert it back to a character string containing only the date */
136           call date_time_ (actual_date, mmddyy_string);     /* in MM/DD/YY form */
137 
138 /* and build components */
139           if ^roman_month then
140                month = substr (mmddyy_string, 1, 2);
141           else do;
142                month_pict = decimal (substr (mmddyy_string, 1, 2), 2);
143                month = roman_months (month_pict);
144           end;
145           day = substr (mmddyy_string, 4, 2);
146           if full_year then
147                year = "19" || substr (mmddyy_string, 7, 2);
148           else year = substr (mmddyy_string, 7, 2);
149 
150 
151 /* create the output */
152           final_date = year || separator || month || separator || day;
153 
154           if is_af then
155                return_string = final_date;
156           else
157           call ioa_ ("^a", final_date);
158 
159           return;
160      end iso_date;