date_time.pl1                   08/30/84  1204.9rew 08/29/84  1113.5       94572



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */




/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
date_time: proc;


/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*							       */
/*  See the control string table at the end of this list for a description   */
/*  of the formats used by the various entries to this command.	       */
/*							       */
/*  SYNTAX AS A COMMAND:					       */
/*							       */
/*  fnc_name {convert_date_to_binary_args} {-control_args}		       */
/*							       */
/*  SYNTAX AS AN ACTIVE FUNCTION:				       */
/*							       */
/* [fnc_name {convert_date_to_binary_args} {-control_args}]		       */
/*							       */
/*  ARGUMENTS:						       */
/*							       */
/*  fnc_name						       */
/*     is the name of the active function to be invoked.		       */
/*  convert_date_to_binary_args				       */
/*     one or more arguments which could be strung together and passed to    */
/*     convert_date_to_binary_ to indicate the date about which information  */
/*     is desired.						       */
/*							       */
/*  CONTROL ARGUMENTS:					       */
/*							       */
/*  -zone XXX						       */
/*     specifies the zone which is to be used to express the result.	       */
/*     calendar clock defaults to GMT, all else to process default.	       */
/*  -language XXX, -lang XXX					       */
/*     specifies the language in which month-names, day-names, and	       */
/*     zone-names are to be expressed.  All functions default to process     */
/*     default.						       */
/*							       */
/*							       */
/*  SYNTAX AS A COMMAND:					       */
/*							       */
/*  clock FORMAT {date-time-string} {-control_args}		       */
/*							       */
/* SYNTAX AS AN ACTIVE FUNCTION:				       */
/*							       */
/*  [clock FORMAT {date-time-string} {-control_args}]		       */
/*							       */
/*  FORMAT is a string which is is acceptable to date_time_$format	       */
/*							       */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* Status:						       */
/*   1) 11/11/72- Gary C. Dixon	CREATED			       */
/*   2) 06/12/78- jaf	Added calendar_clock and clock functions.      */
/*	   		Added -zone and -language arguments.	       */
/*  			Changed to call date_time_$format	       */
/*   3) 03/30/83- jaf	Prepare for new date/time system.	       */
/*			Added -time_zone, -tz to cover date_time       */
/*			Fix up to match MCRed control strings	       */
/*							       */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

      me = "date_time";
      ctl = "^my/^dm/^yc  ^Hd^99v.9MH ^xxxxza^xxxda";
      quote = "1"b;
      goto common_quote;

calendar_clock: entry;
      me = "calendar_clock";
      ctl = "calendar_clock";
      goto common;

clock: entry;

      me = "clock";
      call cu_$arg_ptr (1, arg_p, arg_l, code);
      if (code ^= 0)
      then argno = -1;		/* ERROR:  format_string missing.    */
      else do;
         argno = 2;
         ctl = arg;
      end;
      quote = "0"b;
      goto clock_common;

date: entry;
      me = "date";
      ctl = "^my/^dm/^yc";
      goto common;

day: entry;
      me = "day";
      ctl = "^Z9dm";
      goto common;

day_name: entry;
      me = "day_name";
      ctl = "^dn";
      goto common;

hour: entry;
      me = "hour";
      ctl = "^Z9Hd";
      goto common;

long_date: entry;
      me = "long_date";
      ctl = "^mn ^Z9dm, ^9999yc";
      quote = "1"b;
      goto common_quote;

long_year: entry;
      me = "long_year";
      ctl = "^9999yc";
      goto common;

minute: entry;
      me = "minute";
      ctl = "^Z9MH";
      goto common;

month: entry;
      me = "month";
      ctl = "^Z9my";
      goto common;

month_name: entry;
      me = "month_name";
      ctl = "^mn";
      goto common;

time: entry;
      me = "time";
      ctl = "^Hd:^MH";
      goto common;

year: entry;
      me = "year";
      ctl = "^yc";
      goto common;


common:
      quote = "0"b;
common_quote:
      argno = 1;
clock_common:
      lzone, llanguage = "";
/**** Assume we were called as an active function.  Get ptr & length of our  */
/****  return argument, and count of our input arguments.		       */
      call cu_$af_return_arg (arg_ct, ret_p, ret_l, code);
      if code = 0			/* if called as an active function,  */
      then do;
         command = "0"b;
         err = active_fnc_err_;
         get_arg = cu_$af_arg_ptr;
         ret = "";
      end;
      else if code = error_table_$not_act_fnc /* if called as a command,     */
      then do;
         command = "1"b;		/* indicate so		       */
         get_arg = cu_$arg_ptr;
         err = com_err_;
      end;
      else do;			/* WHAT ELSE IS THERE?!	       */
         command = "0"b;		/* if some unknown error occurs,     */
         err = active_fnc_err_;	/* ..report it to user as if we were */
         go to bad_call;		/* ..called as an active fnc	       */
      end;
      if argno = -1			/* Report missing format_string in   */
      then do;			/* ..clock entry.		       */
         code = error_table_$noarg;
         go to bad_call;
      end;

      result = "";
      state = 0;
      do i = argno to arg_ct;		/* string input arguments together,  */
				/* ..separated by blanks, in our     */
         result = result || " ";	/* ..result argument (a temporary).  */
         call get_arg (i, arg_p, arg_l, code);
         if (state = 1)		/* -zone last		       */
         then do;
	  state = 0;
	  lzone = arg;
         end;
         else if (state = 2)		/* -lang last		       */
         then do;
	  state = 0;
	  llanguage = arg;
         end;
         else do;
	  if (arg = "-zone")
	  | (arg = "-time_zone") | (arg = "-tz")  /* (OBSOLETE)	       */
	  then state = 1;
	  else if (arg = "-language") | (arg = "-lang")
	  then state = 2;
	  else result = result || arg;
         end;
      end;
      if (state ^= 0)
      then goto arg_error;
      errloc = 0;
      call convert_date_to_binary_  ((result), clock_value, code);
      if code ^= 0			/* if error in input arguments,      */
      then do;			/* ..tell user.		       */
         call err (code, me,
	  "^/Date/Time args were: ^va^[ -zone ^a^;^s^]^[ -lang ^a^;^s^]",
	  length (result), result, (lzone ^= ""), lzone,
	  (llanguage ^= ""), llanguage);
         return;
      end;
      tzone = lzone;		/* Process defaults		       */
      tlanguage = llanguage;		/* ..done in $format	       */
      if (me = "calendar_clock")	/* Output values in GMT,	       */
      then do;			/* ..english by default.	       */
         if lzone = ""
         then tzone = "gmt";
         if llanguage = ""
         then tlanguage = "english";
      end;

      on condition (sub_error_) call sub_err_handler;
      result = date_time_$format ((ctl), clock_value, tzone, tlanguage);
      if ^command & quote
      then result = """" || result || """";

exit:
      if command			/* print command's result	       */
      then call ioa_ ("^va", length (result), result);
      else ret = result;		/* return AFs result	       */
      return;%page;
dcl sub_error_	condition;
sub_err_handler: proc;
         condition_info_ptr = addr (c_info);
         condition_info.version = condition_info_version_1;
         call find_condition_info_ (null (), condition_info_ptr, code);
         if (code ^= 0)
         then call com_err_ (code, me||"(sub_error_)" );
         sub_error_info_ptr = condition_info.info_ptr;
         if (sub_error_info.name ^= "date_time_$format")
         then do;
	  call continue_to_signal_ (code);
	  return;
         end;
         call com_err_ (sub_error_info.status_code, me, "^a",
	   sub_error_info.info_string);
         goto exit;


dcl 1 c_info	like condition_info;
dcl code		fixed bin (35);
dcl continue_to_signal_ entry (fixed bin(35));
dcl find_condition_info_ entry (ptr, ptr, fixed bin(35));
%include condition_info;
%include condition_info_header;
%include sub_error_info;
      end sub_err_handler;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


bad_call:
      call err (code, me, "
Usage:^-^[^;[^]^a ^[format_string ^]{convert_date_to_binary_args} {-control_args}^[^;]^]",
         command, me, (me = "clock"), command);
      return;


arg_error:
      call err (error_table_$noarg, me,
         "^/^a requires a ^[zone^;language^] name operand.", arg, state);
      return;

dcl active_fnc_err_ entry options (variable);
dcl arg		char (arg_l) based (arg_p);
dcl arg_ct	fixed bin;
dcl arg_l		fixed bin;
dcl arg_p		ptr;
dcl argno		fixed bin;
dcl clock_value	fixed bin (71);
dcl code		fixed bin (35);
dcl com_err_	entry options (variable);
dcl command	bit (1);
dcl convert_date_to_binary_
		entry (char (*), fixed bin (71), fixed bin (35));
dcl ctl		char (256) var;
dcl cu_$af_arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$af_return_arg
		entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl date_time_$format	entry (char(*), fixed bin(71), char(*), char(*))
		returns(char(250) var);
dcl error_table_$not_act_fnc
		fixed bin (35) ext static;
dcl err		entry automatic options (variable);
dcl errloc	fixed bin;
dcl get_arg	entry (fixed bin, ptr, fixed bin, fixed bin (35)) automatic;
dcl error_table_$noarg
		fixed bin (35) ext static;
dcl i		fixed bin;
dcl ioa_		entry options (variable);
dcl llanguage	char (32);
dcl lzone		char (32);
dcl me		char (16);
dcl quote		bit (1);
dcl result	char (250) var;
dcl ret		char (ret_l) var based (ret_p);
dcl ret_l		fixed bin;
dcl ret_p		ptr;
dcl state		fixed bin;
dcl tlanguage	char (32);
dcl tzone		char (32);

dcl (addr, length, null) builtin;

   end date_time;




		    date_time_equal.pl1             12/13/84  1338.8rew 12/13/84  1140.1       64206



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */

/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

date_time_equal: dteq: time_equal: teq: proc;

/* These active functions compare date-time values; an error is reported if
   either argument is unacceptable to convert_date_to_binary_$relative.

	date_time_equal A B		"true" if A = B, "false" otherwise.
	date_time_before A B	"true" if A < B, "false" otherwise.
	date_time_after A B		"true" if A > B, "false" otherwise.
	date_time_valid A		"true" if A = time value acceptable
				to the convert_date_to_binary_
				subroutine, "false" otherwise

   All of these active functions print their result when called as commands.

 Initial version 3/4/74 by Barry L. Wolman */
/* Time comparison functions added 11/28/78 by Jim Homan */
/* Rewritten 01/18/80 by S. Herbst */
/* Bug fixed in time comparisons 04/14/80 S. Herbst */
/* Changed and, or to accept 0 args or 1 arg 09/16/82 S. Herbst */
/* Added -date to date_time comparison commands 10/26/82 S. Herbst */
/* Fixed dteq and friends to not reject negative times 11/23/82 S. Herbst */
/* Added the date_time_valid function 11/23/82 J. A. Bush */
/* removed a portion, creating date_time_equal.pl1 02/07/84 J A Falksen */
/* Fixed a long-standing bug in dtv relating to multiple args. 84-11-13 jaf */

dcl arg		char (alen) based (aptr);
dcl arg1		char (arg_len (1)) based (arg_ptr (1));
dcl arg2		char (arg_len (2)) based (arg_ptr (2));

dcl return_arg	char (return_len) varying based (return_ptr);

dcl (bad_arg, usage) char (168);
dcl myname	char (32);
dcl date_time_string char (128)var;

dcl arg_ptr	(2) ptr;
dcl (aptr, return_ptr) ptr;

dcl (af_sw, date_sw) bit (1);

dcl (arg_len	(2)) fixed bin;
dcl (alen, arg_count, i, return_len) fixed bin;
dcl code		fixed bin (35);
dcl (now, time1, time2) fixed bin (71);

dcl error_table_$not_act_fnc fixed bin (35) ext;

dcl get_arg	entry (fixed bin, ptr, fixed bin, fixed bin (35)) automatic;
dcl complain	entry variable options (variable);

dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl convert_date_to_binary_$relative
		entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$af_arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl ioa_		entry options (variable);

dcl (addr, clock) builtin;


      myname = "date_time_equal";
      usage = "date_time1 date_time2 {-control_arg}";

      call get_args;
      call convert_times;

      if time1 = time2
      then go to TRUE;
      else go to FALSE;


date_time_before: dtbe: time_before: tbe: entry;

      myname = "date_time_before";
      usage = "date_time1 date_time2 {-control_arg}";

      call get_args;
      call convert_times;

      if time1 < time2
      then go to TRUE;
      else go to FALSE;


date_time_after: dtaf: time_after: taf: entry;

      myname = "date_time_after";
      usage = "date_time1 date_time2 {-control_arg}";

      call get_args;
      call convert_times;

      if time1 > time2
      then go to TRUE;
      else go to FALSE;

date_time_valid: dtv: entry;

      myname = "date_time_valid";
      usage = "date_time string";

      call get_count;
      if arg_count = 0
      then go to USAGE;
      call get_arg (1, aptr, alen, code); /* get the first arg */
      date_time_string = arg;
      if arg_count > 1 		/* if more than 1 arg */
      then do i = 2 to arg_count;	/* get the rest and || together */
         call get_arg (i, aptr, alen, code);
         date_time_string = date_time_string || " " || arg;
      end;
      call convert_date_to_binary_ ((date_time_string), time1, code);
      if code = 0
      then go to TRUE;
      else go to FALSE;
				/**/
TRUE: if af_sw
      then return_arg = "true";
      else call ioa_ ("true");
      return;

FALSE:
      if af_sw   
      then return_arg = "false";
      else call ioa_ ("false");
      return;

USAGE:
      if af_sw
      then call active_fnc_err_$suppress_name (0, myname, "Usage:  ^a ^a", myname, usage);
      else call com_err_$suppress_name (0, myname, "Usage:  ^a ^a", myname, usage);

RETURN:
      return;


get_count: proc;

/* This internal procedure tests for af invocation and gets argument count. */

      call cu_$af_return_arg (arg_count, return_ptr, return_len, code);

      if code = error_table_$not_act_fnc
      then do;
         af_sw = "0"b;
         complain = com_err_;
         get_arg = cu_$arg_ptr;
      end;
      else do;
         af_sw = "1"b;
         complain = active_fnc_err_;
         get_arg = cu_$af_arg_ptr;
      end;

   end get_count;



get_args: proc;

/* This internal procedure gets two arguments. */

dcl (i, j)	fixed bin;

      call get_count;

      j = 0;
      date_sw = "0"b;

      do i = 1 to arg_count;

         call get_arg (i, aptr, alen, code);

         if (arg = "-date") | (arg = "-dt")
         then date_sw = "1"b;
         else do;			/* other arg */
	  j = j + 1;
	  if j > 2
	  then go to USAGE;
	  arg_ptr (j) = aptr;
	  arg_len (j) = alen;
         end;
      end;
      if j < 2
      then go to USAGE;

   end get_args;


convert_times: proc;

/* This internal procedure converts both arguments to clock values. */

      now = clock ();

      call convert_date_to_binary_$relative (arg1, time1, now, code);
      if code ^= 0
      then do;
         bad_arg = arg1;
         go to BAD_TIME;
      end;

      call convert_date_to_binary_$relative (arg2, time2, now, code);
      if code ^= 0
      then do;
         bad_arg = arg2;
         go to BAD_TIME;
      end;

      if date_sw
      then do;		/* compare date only */
         call make_date (time1);
         call make_date (time2);
      end;

      return;

BAD_TIME: call complain (code, myname, "^a", bad_arg);
      go to RETURN;

make_date: proc (A_time);

dcl A_time	fixed bin (71);

      tv.version = Vtime_value_3;
      call date_time_$from_clock (A_time, "", addr (tv), code);
      A_time = tv.dc;

dcl date_time_$from_clock entry (fixed bin (71), char (*), ptr, fixed bin (35));

dcl 1 tv		like time_value;
%include time_value;

   end make_date;

   end convert_times;

   end date_time_equal;




		    date_time_interval.pl1          12/13/84  1338.8rew 12/13/84  1140.2      156897



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */

/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

date_time_interval: dti: proc;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*							       */
/* Names: date_time_interval, dti                                            */
/*                                                                           */
/* SYNTAX AS A COMMAND:                                                      */
/*    dti {date1} date2 {-control_args}				       */
/*                                                                           */
/* SYNTAX AS AN ACTIVE FUNCTION:                                             */
/*    [dti {date1} date2 {-control_args}]                                    */
/*                                                                           */
/* FUNCTION:                                                                 */
/* returns  the difference  between 2  date values,  relative to the         */
/* first, in offset terms:                                                   */
/*   "0 yr 0 mo -2 da -6 hr 0 min -4.64 sec"                                 */
/* The user is  able to specify that the result  be only in terms of         */
/* certain units.                                                            */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* date1                                                                     */
/*    is  the  beginning of  the  interval.  If  not  specified, the         */
/*    current time is used.                                                  */
/* date2                                                                     */
/*    is the  end of the interval.   If the end is  earlier than the         */
/*    beginning, all numbers will be preceeded by a minus sign.              */
/*                                                                           */
/* CONTROL ARGUMENTS:                                                        */
/* -brief, -bf                                                               */
/*    specifies that the units displayed  will be in the abbreviated         */
/*    form (Default).                                                        */
/* -fractional_digits {N}, -fd {N}                                           */
/*    specifies  the  maximum  number  of  fractional  digits  to be         */
/*    included on the smallest unit.  All trailing zeros are removed         */
/*    and then  the decimal point if  it is last.  N  may not exceed         */
/*    20.   Default is  2.  If  N is  not specified,  the maximum is         */
/*    used.                                                                  */
/* -zero_units, -zu                                                          */
/*    specifies that all units will be output even if their value is         */
/*    zero.                                                                  */
/*      Example:  "2 da 0 hr 0 min 4.2 sec"                                  */
/* -language X, -lang X                                                      */
/*    X  specifies  the  language  in  which  the  result  is  to be         */
/*    expressed.  This may  be in any of the  languages known to the         */
/*    date/time system.   If X is "system_lang",  the system default         */
/*    is  used.   If this  control argument  is not  given or  it is         */
/*    present with X being "", the per-process default is used.              */
/* -long, -lg                                                                */
/*    specifies   that   the  units   displayed   will  be   in  the         */
/*    singular/plural form.                                                  */
/* -no_zero_units, -nzu                                                      */
/*    specifies that any unit which has  a value of zero will not be         */
/*    included in the  output.  However, if all units  are zero, the         */
/*    smallest will be shown with the value of "0".  (Default)               */
/*      Example:  "2 da 4.2 sec"                                             */
/* -units STRs                                                               */
/*    specifies  that the  result is to  be expressed in  terms of a         */
/*    given  set of  units.  All  arguments following  -units on the         */
/*    command line are taken as the  set of units to use.  Therefore         */
/*    -units, if present, must be the last control argument present.         */
/*    The units may be entered in any language available on the site         */
/*    and  in any  order.  All units,  however, must be  in the same         */
/*    language.  These are the units which may be specified:                 */
/*          year month week day hour minute second microsecond               */
/*    The output will appear in the order shown in the list above.           */
/*                                                                           */
/* NOTES:                                                                    */
/* When no units have been specified, this set is used:                      */
/*    years months days hours minutes seconds                                */
/* A default result could look like this:                                    */
/*  "-2 da -6 hr -4.05 sec"                                                  */
/* But if the arguments given were:                                          */
/*   -fd -units hr min                                                       */
/* the same interval could be:                                               */
/*  -54hr -0.0676252166666666666666666666666666666666666666666666min         */
/*                                                                           */
/* Note  there is  a truncation in  the first instance  to 2 decimal         */
/* places with the corresponding loss of accuracy.                           */
/*							       */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* Status:						       */
/* 1) 83-02-14 JFalksen	Created				       */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *-* */%page;
/**** Assume we were called as an active function.  Get ptr & length of our  */
/****  return argument, and count of our input arguments.		       */
      lang_l = 0;
      lang_p = addr (ME);		/* need to point somewhere for ""    */
      lang_ctl_arg = "-default-";
      fractional_digits = 2;
      string (sw) = "010"b;
      toa.flag (*) = UNUSED;
      flag_sw = ""b;

      call cu_$af_return_arg (arg_ct, ret_p, ret_l, code);
      if code = 0			/* if called as an active function,  */
      then do;
         command = "0"b;
         err = active_fnc_err_;
         get_arg = cu_$af_arg_ptr;
         ret = "";
      end;
      else if code = error_table_$not_act_fnc /* if called as a command,     */
      then do;
         command = "1"b;		/* indicate so		       */
         get_arg = cu_$arg_ptr;
         err = com_err_;
      end;
      else do;			/* WHAT ELSE IS THERE?!	       */
         command = "0"b;		/* if some unknown error occurs,     */
         err = active_fnc_err_;	/* ..report it to user as if we were */
         go to bad_call;		/* ..called as an active fnc	       */
      end;
      if arg_ct = 0			/* Report missing format_string in   */
      then do;			/* ..clock entry.		       */
no_arg:
         code = error_table_$noarg;
bad_call:
         call err (code, ME,
	  "^/Usage:^-date_time_interval {from-time} to-time {-ctl_args}");
         return;
      end; %page;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* Process all arguments presented				       */
      result = "";
      smallest_unit, state, pos_ct, unit_ct = 0;
      do argno = 1 to arg_ct;
         call get_arg (argno, arg_p, arg_l, code);
         if (state = 1)
         then do;			/* -lang argument		       */
	  state = 0;
	  lang_p = arg_p;
	  lang_l = arg_l;
         end;
         else if (state = 2)
         then do;			/* -fractional_digits argument       */
	  state = 0;
	  if (index (arg, "-") = 1)
	  then goto an_arg;
	  if (verify (arg, " 0123456789") ^= 0)
	  then do;
	     call err (0, ME,
	        "Numeric value required. ^a ^a", last_arg, arg);
	     sw.error = "1"b;
	  end;
	  else do;
	     fractional_digits = convert (fractional_digits, arg);
	     if (fractional_digits > 20)
	     then do;
	        call err (0, ME,
		 "Value may not exceed 20. ^a ^a", last_arg, arg);
	        sw.error = "1"b;
	     end;
	  end;
         end;
         else if (state = 3)
         then do;			/* -units argument		       */
	  i = date_time_$get_time_info_index (arg, Offset_table);
	  if (i <= 0)
	  then do;
	     call err (0, ME, "Unknown offset name. ^a", arg);
	     sw.error = "1"b;
	  end;
	  else toa.flag (i) = INTEGER;
	  flag_sw = "1"b;
	  smallest_unit = max (i, smallest_unit);
	  unit_ct = unit_ct + 1;
         end;
         else if (index (arg, "-") = 1)
         then do;			/* it's a ctl_arg		       */
an_arg:
	  last_arg = arg;
	  if (arg = "-brief") | (arg = "-bf")
	  then sw.bf = "1"b;
	  else if (arg = "-fractional_digits") | (arg = "-fd")
	  then do;
	     state = 2;
	     fractional_digits = 20;	/* set default		       */
	  end;
	  else if (arg = "-language") | (arg = "-lang")
	  then do;
	     state = 1;
	     lang_ctl_arg = arg;
	  end;
	  else if (arg = "-long") | (arg = "-lg")
	  then sw.bf = ""b;
	  else if (arg = "-no_zero_units") | (arg = "-nzu")
	  then sw.izu = ""b;
	  else if (arg = "-units") | (arg = "-unit")
	  then state = 3;
	  else if (arg = "-zero_units") | (arg = "-zu")
	  then sw.izu = "1"b;
	  else do;
	     call err (error_table_$badopt, ME, "^a", arg);
	     sw.error = "1"b;
	  end;
         end;
         else do;			/* It must be a date argument	       */
	  if (pos_ct < dimension (pos_p, 1))
	  then do;		/* There are not too many dates      */
	     pos_ct = pos_ct + 1;
	     pos_p (pos_ct) = arg_p;
	     pos_l (pos_ct) = arg_l;
	  end;
	  else do;
	     call err (0, ME, "Invalid positional arg. ^a", arg);
	     sw.error = "1"b;
	  end;
         end;
      end;
      if (pos_ct = 0)
      then goto no_arg;
      if (pos_ct = 1)		/* Only 1 date given, let NOW be     */
      then do;			/* ..the start of interval.	       */
         pos_p (2) = pos_p (1);
         pos_l (2) = pos_l (1);
         pos_l (1) = 0;
      end;
      now_clock = clock();
      do argno = 1 to 2;
         arg_p = pos_p (argno);
         arg_l = pos_l (argno);
         call convert_date_to_binary_$relative (arg, cvalue (argno), now_clock, code);
         if (code ^= 0)
         then do;
	  call err (code, ME,
	     "^/^[from^;to^]-time value: ^a", argno, arg);
	  sw.error = "1"b;
         end;
      end;
      arg_p = lang_p;
      arg_l = lang_l;
      lang_index = date_time_$get_time_info_index (arg, Language_table);
				/* defaulting is taken care of       */
      if (lang_index <= 0)
      then do;
         call err (0, ME, "Unknown time language. ^a ^a", lang_ctl_arg, arg);
         sw.error = "1"b;
      end;
      if (state ^= 0) & (state ^= 2)
      then do;			/* ended in the middle of something  */
         if (state = 1) | (unit_ct = 0)
         then do;			/* ..and more is necessary.	       */
	  call err (0, ME,
	     "Missing value for -^[lang^;^;units^] argument.",
	     state);
	  sw.error = "1"b;
         end;
      end;
      if sw.error
      then return;%page;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* All args are processed.  Ready to do what is needed.		       */
      if ^flag_sw
      then do;			/* No units specified, set defaults  */
         toa.flag (1) = INTEGER;
         toa.flag (2) = INTEGER;
         toa.flag (4) = INTEGER;
         toa.flag (5) = INTEGER;
         toa.flag (6) = INTEGER;
         toa.flag (7) = INTEGER;
         smallest_unit = 7;
      end;
/**** If the fraction is wanted, show it to from_clock_interval	       */
      if (fractional_digits > 0)
      then toa.flag (smallest_unit) = FRACTION;
      toa.version = Vtime_offset_2;

      call date_time_$from_clock_interval (cvalue (1), cvalue (2), addr (toa), code);
      if (code ^= 0)
      then do;
         call err (code, ME, "Call to date_time_$from_clock failed.");
         return;
      end;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* All that's left now is to format the result so people can understand it.  */
      result = "";
      do i = 1 to 8;		/* go thru all the units	       */
         if (toa.flag (i) ^= UNUSED)
         then do;			/* this is a wanted unit	       */
	  fld24 = toa.val (i);
/****       if this is a not-zero value OR they want zero values	       */
/****       OR this is the last one and nothing has happened yet...DO IT     */
	  if (fld24 ^= 0) | sw.izu
	     | (i = smallest_unit) & (result = "")
	  then do;
	     if (toa.flag (i) ^= INTEGER)
	        | (i = smallest_unit)
	     then fd = fractional_digits;
	     else fd = 0;
	     if (fld24 < 0)		/* first take care of the sign       */
	     then do;
	        fld24 = - fld24;
	        result = result || "-";
	     end;
	     fldpic = fld24 + rounder (fd);
	     result = result || ltrim (substr (fldpic, 1, 26+fd));
	     result = rtrim (result, "0");  /* drop any trailing SPs       */
	     result = rtrim (result, ".");  /* and then the "." if last    */
	     result = result || " ";
/****          Units may be in singular/plural or short form.	       */
	     if sw.bf
	     then result = result || ti_offset.short (lang_index, i);
	     else do;
	        if (abs (fld24) = 1)
	        then result = result || ti_offset.singular (lang_index, i);
	        else result = result || ti_offset.plural (lang_index, i);
	     end;
	     result = result || " ";
	  end;
         end;			
      end;
      result = rtrim (result);

/**** It's easy when all the hard work is being done elsewhere.	       */

      if command			/* print command's result	       */
      then call ioa_ ("^va", length (result), result);
      else ret = result;		/* return AFs result	       */
      return; %page;
dcl arg		char (arg_l) based (arg_p);
dcl arg_ct	fixed bin;
dcl arg_l		fixed bin (21);
dcl argno		fixed bin;
dcl arg_p		ptr;
dcl code		fixed bin (35);
dcl command	bit (1);
dcl cvalue	(2) fixed bin (71);
dcl err		entry automatic options (variable);
dcl error_table_$badopt fixed bin (35) ext static;
dcl error_table_$not_act_fnc fixed bin (35) ext static;
dcl error_table_$noarg fixed bin (35) ext static;
dcl fd		fixed bin;
dcl flag_sw	bit (1);
dcl fld24		float dec (24);
dcl fldpic	pic "(24)-9v.(24)9";
dcl fractional_digits fixed bin;
dcl get_arg	entry (fixed bin, ptr, fixed bin (21),
		fixed bin (35)) automatic;
dcl i		fixed bin;
dcl lang_index	fixed bin;
dcl lang_ctl_arg	char (16);
dcl lang_l	fixed bin;
dcl lang_p	ptr;
dcl last_arg	char (32);
dcl ME		char (18) int static init ("date_time_interval");
dcl now_clock	fixed bin (71);
dcl pos_ct	fixed bin;	/* number of positional args	       */
dcl pos_l		(2) fixed bin;
dcl pos_p		(2) ptr;
dcl result	char (1024) var;
dcl ret		char (ret_l) var based (ret_p);
dcl ret_l		fixed bin (21);
dcl ret_p		ptr;
dcl rounder	(0:20) float dec (24) int static options (constant) init (
		.0,
		.05,
		.005,
		.0005,
		.00005,
		.000005,
		.0000005,
		.00000005,
		.000000005,
		.0000000005,
		.00000000005,
		.000000000005,
		.0000000000005,
		.00000000000005,
		.000000000000005,
		.0000000000000005,
		.00000000000000005,
		.000000000000000005,
		.0000000000000000005,
		.00000000000000000005,
		.000000000000000000005);

dcl smallest_unit	fixed bin;
dcl state		fixed bin;
dcl unit_ct	fixed bin;


dcl 1 sw,
      2 error	bit (1),
      2 bf	bit (1),
      2 izu	bit (1);


dcl active_fnc_err_ entry options (variable);
dcl com_err_	entry () options (variable);
dcl convert_date_to_binary_$relative
		entry (char (*), fixed bin (71), fixed bin (71),
		fixed bin (35));
dcl cu_$af_arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl date_time_$from_clock_interval
		entry (fixed bin (71), fixed bin (71), ptr, fixed bin (35));
dcl date_time_$get_time_info_index
		entry (char (*), fixed bin) returns (fixed bin);
dcl ioa_		entry () options (variable);

dcl 1 toa		like time_offset_array;
dcl (abs, addr, clock, convert, dimension, index, length, ltrim,
     max, rtrim, string, substr, verify
    )		builtin;

%include time_names;
%include time_info_search;
%include time_offset;
   end date_time_interval;




		    datebin_.pl1                    08/05/87  0808.5r   08/04/87  1539.4      116397



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


datebin_:
     procedure (Clock, Absda, Mo, Da, Yr, Hr, Min, Sec, Wkday, S) options (separate_static);

/* DATEBIN_ - utility functions for date conversion.

   Keith Willis July 1971

   Modified April 1976 by T. Casey, to:
   *	check the shift information that is now kept in whotab, as well as that in installation_parms;
   *	initiate whotab and installation_parms in an internal procedure and complain if unable to;
   *	add a test entry point to change sysdir and null ip and whoptr, forcing initiation of new tables.
   *	(the latter two features copied from system_info_)

   Modified March 1979 by G. Palter, to:
   *	fix the bug in the revert entry wherein any date in Jan or Feb which
   *	was beyond the end of Feb (eg: 2/29/79) was converted incorrectly.
   *	This bug caused users with a daily limit to not be allowed to login
   *	on the last day of February each year.

   Largely rewritten April 1980 by C. Hornig for per-process time zones.

   Modified July 1984 by Jim Lippard to use the system time zone when
          calculating the system shift.

   Modified Dec 1984 by JAFalksen to return the correct value for Absda
*/

dcl (Shift1, Shift2, Dayr_clk) fixed bin,		/* parameters */
    (Mo, Da, Yr, Hr, Min, Sec) fixed bin,
    (Absda, Wkday, S) fixed bin,
    (Dayr_mo, Datofirst) fixed bin,
    (Clock, Oldclock) fixed bin (71);

dcl sub_err_ entry options (variable);
dcl decode_clock_value_$all
         entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71),
         fixed bin, char (3), fixed bin, fixed bin, fixed bin (35));
dcl encode_clock_value_
         entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3),
         fixed bin (71), fixed bin (35));
dcl encode_clock_value_$offsets
         entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71),
         fixed bin, char (3), fixed bin (71), fixed bin (35));
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl sys_info$time_zone ext char (3);

dcl (ip, whoptr) ptr int static init (null);
dcl sysdir char (168) int static init (">system_control_dir");

dcl shift_from_whotab bit aligned;
dcl ec fixed bin (35);
dcl (clk, save_clock) fixed bin (71);
dcl (shift, day, month, year, hour, minute, second, day_of_week, abs_date, day_of_year) fixed bin;
dcl (sys_hour, sys_minute, sys_day_of_week) fixed bin;
dcl microsecond fixed bin (71);

dcl (binary, clock, divide, mod, null) builtin;

/* ======================================================= */

/* ENTRY:	datebin_ (clock, absda, mo, da, yr, hr, min, sec, wkday, s);

   clock (fixed bin (71))	is the time to be broken down (input)
   absda fixed bin		is the number of days since 1/1/1901 (output)
   mo fixed bin		is the month (output)
   da fixed bin		is the day of the month (output)
   yr fixed bin		is the year (01-99) (output)
   hr fixed bin		is the hour (0-23) (output)
   min fixed bin		is the minute (0-59) (output)
   sec fixed bin		is the second (0-59) (output)
   wkday fixed bin		is the day of the week (monday = 1, Sunday = 7) (output)
   s fixed bin		is the shift (from installation_parms) (0-7) (output)
*/

	Absda, Mo, Da, Yr, Hr, Min, Sec, Wkday, S = 0;	/* in case error */
	call decode_clock (Clock);
	call calc_shift;
	Absda = abs_date;
	Mo = month;
	Da = day;
	Yr = year;
	Hr = hour;
	Min = minute;
	Sec = second;
	Wkday = day_of_week;
	S = shift;
return_to_caller:
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$shift (Clock, s);

   clock (fixed bin (71))   is the clock reading (input)
   s (fixed bin)            is the shift for that clock reading (output) */

datebin_$shift:
     entry (Clock, S);

	S = -1;
	call decode_clock (Clock);
	call calc_shift;
	S = shift;
	return;

/* ------------------------------------------------------- */

/* ENTRY: datebin_$wkday(clock,wkday);

   clock(fixed bin(71))     is the number of microseconds since 000 GMT Jan. 1,1901(input)
   wkday(fixed bin)         is the current day of the week(Monday=1 and Sunday=7) (output)
*/

wkday:
     entry (Clock, Wkday);

	Wkday = 0;
	call decode_clock (Clock);
	Wkday = day_of_week;
	return;

/* ------------------------------------------------------- */

/* Entry: datebin_$time (clock, hr, min, sec);

   Clock (fixed bin (71))       is the number of microseconds since 000 GMT Jan. 1,1901 (input)
   hr (fixed bin)               is the current hour (output)
   min (fixed bin)              is the current minute (output)
   sec (fixed bin)              is the current second (output)
*/

time:
     entry (Clock, Hr, Min, Sec);

	Hr, Min, Sec = -1;				/* in case error */
	call decode_clock (Clock);
	Hr = hour;
	Min = minute;
	Sec = second;
	return;

/* ------------------------------------------------------- */

/* ENTRY: datebin_$dayr_clk (clock, dayr_clk);

   clock (fixed bin (71))         is the number of microseconds since 000 GMT Jan. 1,1901 (input)
   dayr_clk (fixed bin)               is the day of current year since Jan. 1 (output)
*/

dayr_clk:
     entry (Clock, Dayr_clk);

	Dayr_clk = -1;				/* in case error */
	call decode_clock (Clock);
	Dayr_clk = day_of_year;
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$revert (mo, da, yr, min, sec, clock);

   where all arguments are defined as above and first 5 are input while the last is output */

revert:
     entry (Mo, Da, Yr, Hr, Min, Sec, Clock);		/* build a clock reading given the month day year etc */

	call encode_clock_value_ (1, 2, 1901, 0, 0, 0, 0, 0, (""), save_clock, ec);
	call encode_clock_value_$offsets (save_clock, Mo - 1, Da - 2, Yr - 1901, Hr, Min, Sec, 0, 0, (""), Clock, ec);
	if ec ^= 0 then Clock = 0;
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$revertabs (absda, clock);

   absda (fixed bin)      is the number of days since Jan.1, 1901 (input)
   clock (fixed bin (71))      is the number of microseconds since Jan.1, 1901 00 GMT (output) */

revertabs:
     entry (Absda, Clock);				/* build a clock reading given the absolute day */

	Clock = 0;
	call encode_clock_value_ (12, 31, 1900, 0, 0, 0, 0, 0, "", save_clock, ec);
	call encode_clock_value_$offsets (save_clock, 0, Absda, 0, 0, 0, 0, 0, 0, "", Clock, ec);
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$clockathr (hr, clock);

   hr (fixed bin)         is the hour (local zone) that the clock is to be set to (input)
   clock (fixed bin (71))  is the number of microseconds since 000 GMT Jan.1, 1901  (output) */

clockathr:
     entry (Hr, Clock);				/* return a clock for hour=hr following clock now */

	call find_midnight (clock () - Hr * 3600000000);
	Clock = clk + 3600000000 * (24 + Hr);
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$datofirst (yr, datofirst);

   yr (fixed bin)        is the year (input)
   datofirst (fixed bin) is the number of days from Jan.1,1901 up to but not including Jan.1 of "yr" (output) */

datofirst:
     entry (Yr, Datofirst);

	call encode_clock_value_ (1, 1, Yr, 0, 0, 0, 0, 0, (""), clk, ec);
	call decode_clock (clk);
	Datofirst = abs_date;
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$dayr_mo (mo, da, yr, dayr_mo);

   mo (fixed bin)       is the month (input)
   da (fixed bin)       is the day of the month (input)
   yr (fixed bin)       is the year month and day belong to (input)
   dayr_mo (fixed bin)  is the day of the year =1-366 (output) */

dayr_mo:
     entry (Mo, Da, Yr, Dayr_mo);

	call encode_clock_value_ (Mo, Da, Yr, 0, 0, 0, 0, 0, (""), clk, ec);
	call decode_clock (clk);
	Dayr_mo = day_of_year;
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$last_midnight (clock);

   clock (fixed bin (71))   is the clock reading at midnight before "now" */

last_midnight:
     entry (Clock);

	call find_midnight (clock ());
	Clock = clk;
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$this_midnight (clock);

   clock (fixed bin (71)) is the clock reading as it will be at midnight tonight (output) */

this_midnight:
     entry (Clock);

	call find_midnight (clock ());
	Clock = clk + 86400000000;
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$preceding_midnight (oldclock, clock);

   oldclock (fixed bin (71))    is a calendar clock reading (input)
   clock (fixed bin (71))       is a clock reading for midnight of the preceding day (output) */

preceding_midnight:
     entry (Oldclock, Clock);

	call find_midnight (Oldclock);
	Clock = clk;
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$following_midnight (oldclock, clock);

   oldclock (fixed bin (71)) is a calendar clock reading (input)
   clock (fixed bin (71))    is a clock reading for midnight of that day (output) */

following_midnight:
     entry (Oldclock, Clock);

	call find_midnight (Oldclock);
	Clock = clk + 86400000000;
	return;

/* ------------------------------------------------------- */

/* ENTRY:	datebin_$next_shift_change (oldclock, newclock, shift, newshift);
   clock (fixed bin (71))	given clock reading (input)
   newclock (fixed bin (71))	clock reading for next shift change (output)
   shift (fixed bin)	shift at oldclock (output)
   newshift (fixed bin)	shift at clock (output) */

next_shift_change:
     entry (Oldclock, Clock, Shift1, Shift2);

	Clock = 0;				/* in case of error */
	Shift1, Shift2 = -1;			/* ... */
	call decode_clock (Oldclock);
	call calc_shift;
	Shift1 = shift;
	if shift_from_whotab then do;
	     Clock = whotab.next_shift_change_time;
	     call datebin_$shift (whotab.next_shift_change_time, Shift2);
	     end;
	else do;
	     minute = minute - mod (minute, 30);
	     call encode_clock_value_ (month, day, year, hour, minute, (0), (0), (0), (""), save_clock, ec);
	     do while ((shift = Shift1) & (save_clock - Oldclock < 7 * 86400000000));
		call encode_clock_value_$offsets (save_clock, 0, 0, 0, 0, 30, 0, 0, 0, (""), clk, ec);
		call decode_clock (clk);
		call calc_shift;
	     end;
	     Clock = clk;
	     Shift2 = shift;
	     end;
	return;

/* ---------------------------------------- */

decode_clock:
     procedure (Clock);
dcl Clock fixed bin (71);

	save_clock = Clock;
	call decode_clock_value_$all (save_clock, month, day, year, hour, minute, second, microsecond, day_of_week,
	     (""), abs_date, day_of_year, ec);
     end decode_clock;

/* ---------------------------------------- */

calc_shift:
     procedure;
	call decode_clock_value_$all (save_clock, (0), (0), (0), sys_hour, sys_minute, (0), (0), sys_day_of_week,
	     (sys_info$time_zone), (0), (0), ec);

	if ec ^= 0 then return;

	if ip = null () then do;
	     call hcs_$initiate (sysdir, "installation_parms", "", 0, 1, ip, ec);

	     if ip = null () then do;
		call sub_err_ (ec, "datebin_", "c", null (), (0), "^a>installation_parms", sysdir);
		goto return_to_caller;
		end;
	     end;
	if whoptr = null () then do;
	     call hcs_$initiate (sysdir, "whotab", "", 0, 1, whoptr, ec);
	     if whoptr = null () then do;
		call sub_err_ (ec, "datebin_", "c", null (), (0), "^a>whotab", sysdir);
		goto return_to_caller;
		end;
	     end;

	if (save_clock >= whotab.last_shift_change_time) & (save_clock < whotab.next_shift_change_time) then do;
	     shift_from_whotab = "1"b;
	     shift = whotab.shift;
	     end;
	else do;
	     shift_from_whotab = "0"b;
	     shift =
		binary (installation_parms.shifttab (48 * sys_day_of_week + 2 * sys_hour + divide (sys_minute, 30, 17, 0) - 47),
		3);
	     end;
     end calc_shift;

/* ------------------------------------------------------- */

find_midnight:
     procedure (Clock);
dcl Clock fixed bin (71) parameter;

	call decode_clock (Clock);
	call encode_clock_value_ (month, day, year, 0, 0, 0, 0, 0, (""), clk, ec);
     end find_midnight;

/* ------------------------------------------------------- */

test_datebin:
     entry (test_sysdir);
dcl test_sysdir char (*);

	sysdir = test_sysdir;
	ip, whoptr = null ();
	return;

/* ---------------------------------------- */

%include installation_parms;
%include whotab;

     end datebin_;




		    display_time_info.pl1           09/16/86  1116.3rew 09/16/86  0959.8      263187



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */

/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

dsti: display_time_info: proc;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*							       */
/* Names: display_time_info, dsti                                            */
/*                                                                           */
/* SYNTAX AS A COMMAND:                                                      */
/*     dsti -control_args                                                    */
/*                                                                           */
/* FUNCTION:                                                                 */
/* This command displays information selected from time_info_.               */
/*                                                                           */
/* CONTROL ARGUMENTS:                                                        */
/* -all, -a                                                                  */
/*    specifies all data are to be printed.                                  */
/* -day                                                                      */
/*    asks for a list of all the day names.                                  */
/* -format, -fmt                                                             */
/*    asks for  a list of all  the named formats known  on the site.         */
/*    These  are names  which may  be given  to date_time_$format in         */
/*    place  of  an  explicit  format string.   This  list  does not         */
/*    include  "date",  "date_time",  and  "time"  as  they  are not         */
/*    contained in time_info_.  Use print_time_defaults to see them.         */
/* -language, -lang                                                          */
/*    asks for a  list of all the time  languages available, showing         */
/*    the name of  each language IN each language.   This form would         */
/*    usually be used alone to enable a person to see what languages         */
/*    she can refer to.                                                      */
/* -language X, -lang X                                                      */
/*    asks for the output to be given in language X.  The default is         */
/*    to show requested data in the process default language.                */
/* -map                                                                      */
/*    asks for  a time zone map  of the world, with  all the defined         */
/*    time  zones and  their offsets.   Each zone  is at  its proper         */
/*    place on  this map.  The map  is horizontally broken according         */
/*    to the linelength currently in effect.                                 */
/* -month                                                                    */
/*    asks for a list of all the month names.                                */
/* -offset                                                                   */
/*    asks for all the offset words to be printed.                           */
/* -table X, -tb X                                                           */
/*    Specifies  the  pathname of  the table  to be  displayed.  The         */
/*    default is the reference name "time_info_".                            */
/* -token {X}                                                                */
/*    Displays  the structure  used for binary  searching the tokens         */
/*    declared  in  the table.   The display  shows all  words, with         */
/*    their meanings,  in all languages, grouped  by token.  A token         */
/*    is a  word converted to  lowercase.  If X is  given, then only         */
/*    the data for that token is  shown.  Since X represents a token         */
/*    and not a word, it must be entered in lowercase.                       */
/* -word                                                                     */
/*    asks for all of the miscellaneous words to be printed.                 */
/* -zone                                                                     */
/*    asks for a list of all the zones available.                            */
/*                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* Status:						       */
/* 1) 83-02-01 JFalksen	Created				       */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *-* */


/****^  HISTORY COMMENTS:
  1) change(86-08-15,GDixon), approve(86-09-04,MCR7532),
     audit(86-09-05,Martinson), install(86-09-16,MR12.0-1159):
     Add support for zone GMT+13 (New Zealand Daylight Time) to dsti -map.
     (phx18881)
                                                   END HISTORY COMMENTS */


%page;
      string (sw) = ""b;
      time_info, code_ext, lang_token, token_token, zone_token = "";
      litem_p, zitem_p = null();
      token_index = 0;

/**** Assume we were called as an active function.  Get ptr to/length of our */
/****  return argument, and count of our input arguments.		       */
      call cu_$af_return_arg (arg_ct, ret_p, ret_l, code);
      if code = 0			/* if called as an active function,  */
      then do;
         command = "0"b;
         err = active_fnc_err_;
         get_arg = cu_$af_arg_ptr;
      end;
      else if code = error_table_$not_act_fnc /* if called as a command,     */
      then do;
         command = "1"b;		/* indicate so		       */
         get_arg = cu_$arg_ptr;
         err = com_err_;
      end;
      else do;			/* if some unknown error occurs,     */
         command = "0"b;		/* ..report it to user as if we were */
         err = active_fnc_err_;	/* ..called as an active fnc	       */
         goto bad_call;
      end;
      if (arg_ct = 0)
      then do;
         code = error_table_$noarg;
         code_ext = "
Usage:	dsti -control_args";
         goto bad_call;
      end; %page;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* Process all the args given.				       */

      do arg_no = 1 to arg_ct;
         call get_arg (arg_no, arg_p, arg_l, code);
         if (arg = "-all") | (arg = "-a")
         then sw.all = "1"b;
         else if (arg = "-day")
	       | (arg = "-da") | (arg = "-days") /* (just to be friendly)       */
         then sw.day = "1"b;
         else if (arg = "-format") | (arg = "-fmt")
         then sw.format = "1"b;
         else if (arg = "-language") | (arg = "-lang")
         then do;
	  if (arg_no < arg_ct)
	  then do;
	     call get_arg (arg_no + 1, arg_p, arg_l, code);
	     if (index (arg, "-") ^= 1)
	     then do;
	        lang_token = arg;
	        arg_no = arg_no + 1;
	     end;
	     else sw.lang = "1"b;
	  end;
	  else sw.lang = "1"b;
         end;
         else if (arg = "-map")
         then sw.map = "1"b;
         else if (arg = "-month")
         then sw.month = "1"b;
         else if (arg = "-offset")
         then sw.offset = "1"b;
         else if (arg = "-table") | (arg = "-tb")
         then do;
	  if (arg_no < arg_ct)
	  then do;
	     call get_arg (arg_no + 1, arg_p, arg_l, code);
	     if (index (arg, "-") ^= 1)
	     then do;
	        time_info = arg || "|";
	        arg_no = arg_no + 1;
	     end;
	     else goto no_table;
	  end;
	  if (time_info = "|")
	  then do;
no_table:
	     call com_err_ (0, me, "Missing value for -table argument.");
	     sw.err = "1"b;
	  end;
         end;
         else if (arg = "-token")
         then do;
	  sw.token = "1"b;
	  if (arg_no < arg_ct)
	  then do;
	     call get_arg (arg_no + 1, arg_p, arg_l, code);
	     if (index (arg, "-") ^= 1)
	     then do;
	        token_token = arg;
	        arg_no = arg_no + 1;
	     end;
	  end;
         end;
         else if (arg = "-word") | (arg = "-words")
         then sw.word = "1"b;
         else if (arg = "-zone") | (arg = "-zones")
         then do;
	  sw.zone = "1"b;
	  if (arg_no < arg_ct)
	  then do;
	     call get_arg (arg_no + 1, arg_p, arg_l, code);
	     if (index (arg, "-") ^= 1)
	     then do;
	        zone_token = arg;
	        arg_no = arg_no + 1;
	     end;
	  end;
         end;
         else do;
	  if (index (arg, "-") ^= 1)
	  then code = error_table_$bad_arg;
	  else code = error_table_$badopt;
	  call com_err_ (code, me, "^a", arg);
	  sw.err = "1"b;
         end;
      end;
      if sw.token
      then if (substr (string (sw), 3) ^= ""b)
      then do;
         call com_err_ (0, me, "No other control args allowed with -token.");
         return;
      end;
      if sw.err
      then return; %page;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* Get pointers to all the things we need.			       */
      if (time_info = "")
      then do;			/* supply table default	       */
         time_info = "time_info_$";
      end;

      v_e = cv_entry_ (time_info || "version", null(), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "^aversion", time_info);
         return;
      end;
      v_p = codeptr (v_e);
      if (v_p -> ch8 ^= Vtime_info_2)
      then do;
         code = error_table_$unimplemented_version;
         code_ext = time_info || "version";
         goto bad_call;
      end;
      v_e = cv_entry_ (time_info || "default_language_index", null (), code);
      if (code ^= 0)
      then do;
         code_ext = time_info || "default_language_index";
         goto bad_call;
      end;
      dl_p = codeptr (v_e);
      default_lang = dl_p -> fb;
      v_e = cv_entry_ (time_info || "date_time_keywords", null (), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "^adate_time_keywords", time_info);
         sw.err = "1"b;
      end;
      dtk_p = codeptr (v_e);
      v_e = cv_entry_ (time_info || "language_names", null (), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "^alanguage_names", time_info);
         sw.err = "1"b;
      end;
      l_p = codeptr (v_e);
      v_e = cv_entry_ (time_info || "zone_names", null (), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "^azone_names", time_info);
         sw.err = "1"b;
      end;
      zn_p = codeptr (v_e);
      lang_ct = zn_p -> ti_zone.number_lang;
      zone_ct = zn_p -> ti_zone.number_zone;
      v_e = cv_entry_ (time_info || "month_names", null (), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "^amonth_names", time_info);
         sw.err = "1"b;
      end;
      m_p = codeptr (v_e);
      v_e = cv_entry_ (time_info || "day_names", null (), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "^aday_names", time_info);
         sw.err = "1"b;
      end;
      d_p = codeptr (v_e);
      v_e = cv_entry_ (time_info || "offset_names", null (), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "^aoffset_names", time_info);
         sw.err = "1"b;
      end;
      o_p = codeptr (v_e);
      v_e = cv_entry_ (time_info || "word_names", null (), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "^aword_names", time_info);
         sw.err = "1"b;
      end;
      w_p = codeptr (v_e);
      v_e = cv_entry_ (time_info || "tokens", null (), code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "^atokens", time_info);
         sw.err = "1"b;
      end;
      ti_token_p = codeptr (v_e);
      if (token_token ^= "")
      then do;
         call search (token_token);	/* look for token		       */
         token_index = cur_token;
      end;
      if (lang_token = "")
      then lang_token = time_defaults_$language;
      call search (lang_token);	/* look for language name	       */
      item_p = addrel (v_p, ti_token.list_r (cur_token));
      if (item.table (1) ^= Language_table)
      then do;
         call com_err_ (0, me, "^a is not a language in time_info_.",
	  lang_token);
         sw.err = "1"b;
      end;
      litem_p = item_p;
      if (zone_token ^= "")
      then do;
         call search (zone_token);	/* look for zone name	       */
         item_p = addrel (v_p, ti_token.list_r (cur_token));
         if (item.table (1) ^= Zone_table)
         then do;
	  call com_err_ (0, me, "^a is not a zone in time_info_.",
	     zone_token);
	  sw.err = "1"b;
         end;
         zitem_p = item_p;
      end;
      if sw.err
      then return; %page;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
main:
      begin;

         if ^sw.token
         then do;			/* not doing the token option.       */
	  if (litem_p ^= null())	/* A language name was given	       */
	  then lb, hb = litem_p -> item.element (1);
	  else do;
	     lb = 1;		/* process 'em all		       */
	     hb = lang_ct;
	  end;
display:
	  do lang = lb to hb;
	     call ioa_ ("^a-----", l_p -> ti_language.name (lang, lang));
	     if sw.format | sw.all
	     then do;
	        call ioa_ (" Named format strings");
	        do element = 1 to dtk_p -> ti_keyword.number_kwd;
		 call ioa_ ("^24a ""^va""^[^/^]",
		    dtk_p -> ti_keyword.e.name (element),
		    length (dtk_p -> ti_keyword.e.str (element)),
		    dtk_p -> ti_keyword.e.str (element), (element=3));
	        end;
	     end;
	     if sw.lang | sw.all
	     then do;
	        call ioa_ (" Language name");
	        do element = 1 to lang_ct;
		 call ioa_ ("^6i: ^a", element,
		    fetch (Language_table, lang, element, 0));
	        end;
	     end;
	     if sw.month | sw.all
	     then do;
	        call ioa_ (" Month name (long, short)");
	        do element = 1 to 12;
		 call ioa_ ("^6i: ^a", element,
		    fetch (Month_table, lang, element, 0));
	        end;
	     end;
	     if sw.day | sw.all
	     then do;
	        call ioa_ (" Day name (long, short)");
	        do element = 1 to 7;
		 call ioa_ ("^6i: ^a", element,
		    fetch (Day_table, lang, element, 0));
	        end;
	     end;
	     if sw.offset | sw.all
	     then do;
	        call ioa_ (" Offset(""this"",singular,plural,short)");
	        do element = 1 to hbound (o_p -> ti_offset.e, 2);
		 call ioa_ ("^6i: ^a", element,
		    fetch (Offset_table, lang, element, 0));
	        end;
	     end;
	     if sw.word | sw.all
	     then do;
	        call ioa_ (" Other words");
	        do element = 1 to hbound (w_p -> ti_word.word, 2);
		 call ioa_ ("^6i: ^a", element,
		    fetch (Word_table, lang, element, 0));
	        end;
	     end;
	     if sw.map
	     then call print_time_zones;
	     if sw.zone | sw.all
	     then do;
	        if (zitem_p ^= null())/* A zone name was given, process it */
	        then lb, hb = zitem_p -> item.element (1);  /* ..only */
	        else do;
		 lb = 1;		/* process all the zones	       */
		 hb = zone_ct;
	        end;
	        call ioa_ (" Zone info(short,offset,long)");
	        do element = lb to hb;
		 call ioa_ ("^6i: ^a", element,
		    fetch (Zone_table, lang, element, 0));
	        end;
	     end;
	  end display;
         end;
         else do;			/* -token option		       */
	  if (litem_p ^= null())	/* A language name was given	       */
	  then lang = litem_p -> item.element (1);
	  else lang = default_lang;   /* use process default	       */
	  
	  if (token_index > 0)
	  then lb, hb = token_index;	/* one was singled out	       */
	  else do;
	     lb = 1;		/* do 'em all		       */
	     hb = ti_token.count;
	  end;
show_token:
	  do cur_token = lb to hb;
	     item_p = addrel (v_p, ti_token.list_r (cur_token));
	     call ioa_ ("Token(^3i): ""^a""^[ (ambiguous)^]", cur_token,
	        ti_token.symbol (cur_token), (item.count > 1));
/**** 	     Go thru all items (usually only one).		       */
	     do it = 1 to item.count;
/****	        Get the number of items			       */
	        itn = item.element (it);
/****	        Get the kind of table the item is for		       */
	        tabl = item.table (it);
	        if (tabl = Day_table)
	        then tname = d_p -> ti_day.long (lang, itn);
	        else if (tabl = Language_table)
	        then tname = l_p -> ti_language.name (lang, itn);
	        else if (tabl = Month_table)
	        then tname = m_p -> ti_month.long (lang, itn);
	        else if (tabl = Offset_table)
	        then tname = o_p -> ti_offset.singular (lang, itn);
	        else if (tabl = Word_table)
	        then tname = w_p -> ti_word.word (lang, itn);
	        else if (tabl = Zone_table)
	        then tname = zn_p -> ti_zone.short (lang, itn);
	        else if (tabl = This_table)
	        then tname = o_p -> ti_offset.this (lang, itn) || " ["
		 || o_p -> ti_offset.singular (lang, itn) || "]";
	        else call com_err_ (0, me,
		 "item.table(^i) =^b", it, tabl);

	        first_sw = "1"b;
	        do li = 1 to lang_ct;
		 if (substr (item.in_lang (it), li, 1))
		 then do;
		    call ioa_ ("^[^s  ^a:^;  ^vx ^s^] ^a",
		       first_sw, length (tname), tname,
		       fetch (tabl, li, itn, lang));
		    first_sw = ""b;
		 end;
	        end;
	     end;
	  end show_token;
         end;
      end main;
      return;

bad_call:
      call err (code, me, "^a", code_ext);
exit:
      return; %page;
/* * * * * * * * * * * * * * * * * * *+* * * * * * * * * * * * * * * * * * * */
/* Given a table, language, element, and display-language, this proc returns */
/* a representation of the words which the combination represents, i.e.      */
/*	(Day_table, german, Tue, french)  gives			       */
/* 	Dienstag, Dns, aliases (allemand)			       */
/*	(Month_table, french, Nov, 0)  gives			       */
/* 	novembre, nov, aliases				       */
/* In either case, aliases (NYA) are present if any exist		       */
/* * * * * * * * * * * * * * * * * * *+* * * * * * * * * * * * * * * * * * * */
fetch: proc (table, lang, element, show_lang) returns (char (1024)var);

dcl (table	fixed bin,	/* which table to reference	       */
    lang		fixed bin,	/* which language to show	       */
    element	fixed bin,	/* which element in table	       */
    show_lang	fixed bin		/* what language we're speaking      */
    )		parm;

dcl result	char(1024)var;

      result = "";
      goto type (table);

type (1):				/* Day_table		       */
      result = result || d_p -> ti_day.long (lang, element);
      result = result || ", ";
      result = result || d_p -> ti_day.short (lang, element);
/**** Aliases handled here					       */
      goto finished;

type (2):				/* Language_table		       */
      result = result || l_p -> ti_language.name (lang, element);
/**** Aliases handled here					       */
      goto finished;

type (3):				/* Month_table		       */
      result = result || m_p -> ti_month.long (lang, element);
      result = result || ", ";
      result = result || m_p -> ti_month.short (lang, element);
/**** Aliases handled here					       */
      goto finished;

type (4):				/* Offset_table		       */
      result = result || o_p -> ti_offset.this (lang, element);
      result = result || " ";
      result = result || o_p -> ti_offset.singular (lang, element);
      result = result || ", ";
      result = result || o_p -> ti_offset.plural (lang, element);
      result = result || ", ";
      result = result || o_p -> ti_offset.short (lang, element);
/**** Aliases handled here					       */
      goto finished;

type (5):				/* Word_table		       */
      result = result || w_p -> ti_word.word (lang, element);
/**** Aliases handled here					       */
      if (w_p -> ti_word.short (lang, element) ^= "")
      & (w_p -> ti_word.short (lang, element) ^= "?")
      then do;
         result = result || ", ";
         result = result || w_p -> ti_word.short (lang, element);
      end;
      goto finished;

type (6):				/* Zone_table		       */
				/* convert Usec to hr	       */

				/* value stored is the opposite of   */
				/* ..that displayed, so negate it    */
      result = result || char (zn_p -> ti_zone.short (lang, element), 5);
      result = result || " ";
      result = result || zone_dif (zn_p -> ti_zone.delta (lang, element));
      result = result || "  ";
      result = result || zn_p -> ti_zone.long (lang, element);
/**** Aliases handled here					       */
      goto finished;

zone_dif: proc (td) returns (char (5));
dcl td		fixed bin (71);

dcl time		fixed bin (71);
dcl 1 result,
      2 s		char (1),
      2 (HH,MM)	pic "99";

	time = td;
	s = "-";			/* values stored in table have       */
	if (time < 0)		/* ..opposite sign from the way it   */
	then do;			/* ..is displayed.		       */
	   s = "+";
	   time = -time;
	end;
	HH, i = divide (time, 3600000000, 17, 0);
	time = time - i*3600000000;
	MM = divide (time, 60000000, 17, 0);
	return (string (result));
       end zone_dif;

type (7):				/* This_table (part of offset table) */
      result = result || o_p -> ti_offset.this (lang, element);
      result = result || " [";
      result = result || o_p -> ti_offset.singular (lang, element);
      result = result || "]";
/**** Aliases handled here					       */
      goto finished;

finished:
      if (show_lang > 0)
      then do;
         result = result || " (";
         result = result || l_p -> ti_language.name (show_lang, lang);
         result = result || ")";
      end;

      return (result);

   end fetch; %page;
search: proc (symbol);

dcl symbol	char (*);

dcl sym		char (32);
dcl (az		init ("abcdefghijklmnopqrstuvwxyz"),
    AZ		init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
		char (26) int static options (constant);

      sym = translate (symbol, az, AZ); /* get to normal form	       */

      lb = 1;			/* binary search for it	       */
      hb = ti_token.count;
      do while (lb <= hb);
         cur_token = divide (lb + hb, 2, 17, 0);
         if (ti_token.symbol (cur_token) = sym)
         then return;		/* SUCCESS		       */
         if (ti_token.symbol (cur_token) < sym)
         then lb = cur_token + 1;
         else hb = cur_token - 1;
      end;
      call com_err_ (0, me, "Token not found in ^a. ^a",
         rtrim (time_info, "$|"), sym);
      goto exit;
   end search;%page;
print_time_zones: proc;		/* zn_p -> ti_zone (lang,*)    */

dcl first_hour	pic "ss9";
dcl first_minute	pic "99";
dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
dcl hour		pic "ss9";
dcl j		fixed bin;
dcl l		fixed bin;
dcl last_hour	pic "ss9";
dcl line		char (132);
dcl Lline		fixed bin;
dcl minute	pic "99";
dcl MLline	fixed bin;
dcl Nzones_per_line fixed bin;
dcl Saligned_left	bit (1) aligned;
dcl template_line	char (133) int static options (constant) init ((19)"|      ");
dcl temp_hour	pic "ss9";
dcl zone_str	char (48) var;

      call ioa_ ("^/known time zones:");

      MLline = get_line_length_$switch (null (), code);
      Nzones_per_line = divide (MLline - 1, 7, 35, 0);
      Lline = 1 + 7 * Nzones_per_line;
      element = 1;
      do while (element <= zone_ct);
         Saligned_left = "1"b;
         call hhmm (zn_p -> ti_zone.delta (lang, element),
	  first_hour, first_minute);
         last_hour = first_hour + Nzones_per_line - 1;
         if last_hour > 13
         then do;
	  Nzones_per_line = 13 - first_hour + 1;
	  Lline = 1 + 7 * Nzones_per_line;
	  last_hour = 13;
         end;
         hour = first_hour;
         minute = first_minute;
         do while (hour <= last_hour);
	  line = substr (template_line, 1, Lline);
	  i = (hour - first_hour) * 7 + 2;
	  j = divide (minute, 10, 1, 0);
	  if hour < 0
	  then if j = 0
	       then ;
	       else i = i - (j + 1);
	  else i = i + j;
	  l = 9 + length (zn_p -> ti_zone.short (lang, element))
	     + length (zn_p -> ti_zone.long (lang, element));
	  if Saligned_left
	  then if (i - 1) + l > MLline
	       then if hour > first_hour
		  then do;
		     Saligned_left = "0"b;
		     temp_hour = first_hour;
		     call ioa_ ("^a", line);
		     do j = 2 to Lline by 7 while (temp_hour <= 13);
		        substr (line, j, 6) = temp_hour || ":00";
		        temp_hour = temp_hour + 1;
		     end;
		     call ioa_ ("^a", line);
		     line = substr (template_line, 1, Lline);
		     if i - l + 4 >= 0
		     then call ioa_ ("^a", line);
		  end;
	  if Saligned_left
	  then do;
	     zone_str = hour;
	     zone_str = zone_str || ":";
	     zone_str = zone_str || minute;
	     zone_str = zone_str || "  ";
	     zone_str = zone_str || zn_p -> ti_zone.short (lang, element);
	     zone_str = zone_str || " ";
	     zone_str = zone_str || zn_p -> ti_zone.long (lang, element);
	     substr (line, i) = zone_str;
	  end;
	  else if i - l + 4 < 0
	  then goto END_LOOP;
	  else do;
	     zone_str = " ";
	     zone_str = zone_str || zn_p -> ti_zone.long (lang, element);
	     zone_str = zone_str || " ";
	     zone_str = zone_str || zn_p -> ti_zone.short (lang, element);
	     zone_str = zone_str || "  ";
	     zone_str = zone_str || hour;
	     zone_str = zone_str || ":";
	     zone_str = zone_str || minute;
	     substr (line, 1, i - l + 4) = "";
	     substr (line, i - l + 5, l + 1) = zone_str;
	  end;
	  call ioa_ ("^a", line);
	  element = element + 1;
	  if element <= zn_p -> ti_zone.number_zone
	  then call hhmm (zn_p -> ti_zone.delta (lang, element), hour, minute);
	  else hour = 99;
         end;
END_LOOP:
         if Saligned_left
         then do;
	  temp_hour = first_hour;
	  line = substr (template_line, 1, Lline);
	  call ioa_ ("^a", line);
	  do j = 2 to Lline by 7 while (temp_hour <= 13);
	     substr (line, j, 6) = temp_hour || ":00";
	     temp_hour = temp_hour + 1;
	  end;
	  call ioa_ ("^a^/", line);
         end;
         else call ioa_ ("");
      end;
      return;

hhmm: proc (delta, hour, minute);

dcl delta		fixed bin (71),
    hour		pic "ss9",
    minute	pic "99";

dcl time		fixed dec (12),
    minutes	fixed dec (11),
    hours		fixed dec (2);

      time = delta * -1;
      hours = divide (time, 3600000000, 2, 0);
      minutes = time - hours * 3600000000;
      minute = divide (minutes, 60000000, 2, 0);
      hour = hours;

   end hhmm;
   end print_time_zones; %skip (5);
dcl (v_p, dl_p, dtk_p, l_p, zn_p, m_p, d_p, o_p, w_p)
		ptr;
dcl active_fnc_err_ entry options (variable);
dcl arg		char (arg_l) based (arg_p);
dcl arg_ct	fixed bin;
dcl arg_l		fixed bin (21);
dcl arg_no	fixed bin;
dcl arg_p		ptr;
dcl ch8		char (8) based;
dcl code		fixed bin (35);
dcl code_ext	char (100) var;
dcl com_err_	entry () options (variable);
dcl command	bit (1);
dcl cur_token	fixed bin;
dcl cu_$af_arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cv_entry_	entry (char(*), ptr, fixed bin(35)) returns(entry);
dcl default_lang	fixed bin;
dcl element	fixed bin;
dcl err		entry () options (variable) automatic;
dcl error_table_$bad_arg fixed bin (35) ext static;
dcl error_table_$badopt fixed bin (35) ext static;
dcl error_table_$noarg fixed bin (35) ext static;
dcl error_table_$not_act_fnc fixed bin (35) ext static;
dcl error_table_$unimplemented_version fixed bin (35) ext static;
dcl fb		fixed bin based;
dcl first_sw	bit (1);
dcl get_arg	entry (fixed bin, ptr, fixed bin (21), fixed bin (35))
		automatic;
dcl hb		fixed bin;
dcl i		fixed bin;
dcl ioa_		entry () options (variable);
dcl it		fixed bin;
dcl itn		fixed bin;
dcl lang		fixed bin;
dcl lang_ct	fixed bin;
dcl lang_token	char (32);
dcl lb		fixed bin;
dcl li		fixed bin;
dcl litem_p	ptr;		/* -> item assoc with -lang arg      */
dcl me		char (17) int static options (constant)
		init ("display_time_info");
dcl ret_l		fixed bin (21);
dcl ret_p		ptr;
dcl tabl		fixed bin;
dcl time_info	char (170) var;
dcl tname		char (64)var;
dcl token_index	fixed bin;
dcl token_token	char (32);
dcl v_e		entry automatic;
dcl zitem_p	ptr;		/* -> item assoc with -zone arg      */
dcl zone_ct	fixed bin;
dcl zone_token	char (32);

dcl (addr, addrel, char, codeptr, divide, hbound, index, length, null, rtrim,
     string, substr, translate
    )		builtin;


dcl 1 sw,
      2 err	bit (1),		/*     *** ERROR has occurred ***    */
      2 token	bit (1),		/* break out all token data (2 ways) */
      2 all	bit (1),		/* show everything		       */
      2 format	bit (1),		/*  named format strings	       */
      2 day	bit (1),		/*  day data		       */
      2 month	bit (1),		/*  month data		       */
      2 offset	bit (1),		/*  offset data		       */
      2 word	bit (1),		/*  word data		       */
      2 zone	bit (1),		/*  zone list (2 ways)	       */
      2 map	bit (1),		/*  world zone map		       */
      2 lang	bit (1);		/*  language data (2 ways)	       */

%include time_info_search;
%include time_names;
%include time_defaults_;

   end display_time_info;




		    set_time_default.pl1            08/19/86  2036.9rew 08/19/86  2036.1      234567



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */

/**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16	       */
/**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
/**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
/**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */

std: set_time_default: set_time_defaults: proc;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*							       */
/* Names: set_time_default, std                                              */
/*                                                                           */
/* SYNTAX AS A COMMAND:                                                      */
/*     std key value {-control_arg}				       */
/*                                                                           */
/* SYNTAX AS AN ACTIVE FUNCTION:                                             */
/*    [std key value {-control_arg}]                                         */
/*                                                                           */
/* FUNCTION:                                                                 */
/* This  command  sets a  default date/time  value for  the process.         */
/* When used as an active function,  it returns "true" if the key is         */
/* valid and the value is proper for the key.  Otherwise, it returns         */
/* "false".                                                                  */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* key                                                                       */
/*    is a keyword representing the default to set.                          */
/* value                                                                     */
/*    is  a  value  to become  the  new  default.  If  the  value is         */
/*    "-system"  (or "-sys"),  the system  default is  used.  If the         */
/*    value is -pop, it uses a remembered value, saved by an earlier         */
/*    setting with the  -push option.  It is an  error if no earlier         */
/*    -push has been done.                                                   */
/*                                                                           */
/* CONTROL ARGUMENTS:                                                        */
/* -push                                                                     */
/*    saves the current  value of the default before  setting to the         */
/*    new value.                                                             */
/*                                                                           */

/* LIST OF keys:                                                             */
/* debug							       */
/*    Set the date/time software debugging switch.  The value must be "off"  */
/*    or "false", or "on" or "true".  The initial default is "off".	       */
/* date                                                                      */
/*    Set the process default date.  The value must be acceptable to         */
/*    date_time_$format (see note).				       */
/* date_time                                                                 */
/*    Set the process default date_time.   The value must be accept-         */
/*    able to date_time_$format (see note).			       */
/* language, lang                                                            */
/*    Set the process default language.  The language name may be in         */
/*    any of the languages known to the date/time system.                    */
/* time                                                                      */
/*    Set the process default date.  The value must be acceptable to         */
/*    date_time_$format (see note).				       */
/* zone                                                                      */
/*    Set the process default zone.  The zone abbreviation may be in         */
/*    any of the languages known to the date/time system.                    */
/*							       */
/* Notes							       */
/* The named format strings acceptable to date_time_$format may be seen      */
/* by typing "display_time_info -format".  The names "date", "time", and     */
/* "date_time" are not allowed in this context.			       */
/*							       */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* Status:						       */
/*   1) 03/30/83 - jaf	Created				       */
/*							       */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *-* */


/****^  HISTORY COMMENTS:
  1) change(86-07-18,GDixon), approve(86-07-25,MCR7495),
     audit(86-07-25,Martinson), install(86-08-19,MR12.0-1120):
     Add the debug keyword, with values of "off" or "on".
                                                   END HISTORY COMMENTS */


      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;

      call arg_start_up;
      if err_sw then return;
      if ^command
      then do;
         ret = "true";		/* assume a correct AF call	       */
         err = return_false;		/* redirect the error output call    */
      end;
      sys_sw, pop_sw, push_sw = "0"b;
      keyname, value = "";

/* NOW process the arguments given.				       */

      do arg_no = 1 to arg_ct;
         call get_arg (arg_no, arg_p, arg_l, code);
         if (arg = "-push")
         then push_sw = "1"b;
         else if (keyname = "")
         then do;
	  do keyno = 1 to keyword_last;
	     if (keyword (keyno) = arg)
	     then goto got_key;
	  end;
	  call err (error_table_$bad_arg, me_s, "^a", arg);
	  return;
got_key:
	  keyname = arg;
         end;
         else if (value = "")
         then do;
	  if (arg = "-system") | (arg = "-sys")
	  then sys_sw = "1"b;
	  else if (arg = "-pop")
	  then pop_sw = "1"b;
	  value = arg;
         end;
         else do;
	  if (index (arg, "-") = 1)
	  then code = error_table_$badopt;
	  else code = error_table_$bad_arg;
	  goto usage_msg;
         end;
      end;
      if (value = "")
      then do;
         code = error_table_$wrong_no_of_args;
         arg_p = addr (arg_p);
         arg_l = 0;
usage_msg:
         call err (code, me_s, "^a
USAGE:^-std key value {-push}
value may be -pop or -sys", arg);
         return;
      end;

      if (keyno < 4) & ^pop_sw & ^sys_sw
      then do;			/* validate format string	       */
         if (length (value) > 64)
         then do;
	  call err (error_table_$bigarg, me_s, "^a ""^a""", keyname,
	     value);
	  return;
         end;
         if (value = "date") | (value = "time") | (value = "date_time")
         then do;
	  call err (0, me_s, "The keyword is not usable here. ^a",
	     value);
	  return;
         end;
         call date_time_$valid_format ((value), errloc, code);
         if (code ^= 0)
         then do;
	  call err (code, me_s, "^[
Format is: ""^va""
 error at: ^vx^^^]",
	  (errloc > 0), length (value), value, errloc);
	  return;
         end;
      end;
      if push_sw | pop_sw
      then if (p.heap = null())
      then p.heap = get_system_free_area_();

/* ------------------------------------------------------------------------- */
/*  Note that the setting, pushing, & popping does not effect lower rings.   */
/* ------------------------------------------------------------------------- */
      goto rtn (keyno);		/* format: tree		       */


rtn (1): /** date						       */
      if push_sw
      then call push (p.date, (time_defaults_$date));
      if pop_sw
      then time_defaults_$date = pop (p.date);
      else if sys_sw
         then time_defaults_$date = "system_date";
         else time_defaults_$date = value;
      return;

rtn (2): /** date_time					       */
      if push_sw
      then call push (p.date_time, (time_defaults_$date_time));
      if pop_sw
      then time_defaults_$date_time = pop (p.date_time);
      else if sys_sw
         then time_defaults_$date_time = "system_date_time";
         else time_defaults_$date_time = value;
      return;

rtn (4): /** language					       */
rtn (5): /** lang						       */
      if push_sw
      then call push (p.lang, time_defaults_$language);
      if pop_sw
      then value = pop (p.lang);
      else if sys_sw
         then value = "system_lang";
      call date_time_$set_lang ((value), code);
      if (code ^= 0)
      then do;
         call err (code, me_s, "Setting language ""^a"".", value);
         if push_sw
         then value = pop (p.lang);
      end;
      return;

rtn (3): /** time						       */
      if push_sw
      then call push (p.time, (time_defaults_$time));
      if pop_sw
      then time_defaults_$time = pop (p.time);
      else if sys_sw
         then time_defaults_$time = "system_time";
         else time_defaults_$time = value;
      return;

rtn (6): /** zone						       */
      if push_sw
      then call push (p.zone, (time_defaults_$zone_short));
      if pop_sw
      then value = pop (p.zone);
      else if sys_sw
         then value = "system_zone";
      call date_time_$set_zone ((value), code);
      if (code ^= 0)
      then do;
         call err (code, me_s, "Setting zone ""^a"".", value);
         if push_sw
         then value = pop (p.zone);
      end;
      return;

rtn (7): /** debug						       */
rtn (8): /** db						       */
      if push_sw
      then if time_defaults_$debug
	 then call push (p.debug, "on");
	 else call push (p.debug, "off");
      if pop_sw
      then value = pop (p.debug);
      else if sys_sw
         then value = "off";
      if value = "on" | value = "true" then
         on_sw = "1"b;
      else if value = "off" | value = "false" then
         on_sw = "0"b;
      else do;
         call err (error_table_$bad_arg, me_s, "Setting debug switch to ""^a"".", value);
         if push_sw
         then value = pop (p.debug);
      end;
      time_defaults_$debug = on_sw;
      return;

pop_err:
      call err (0, me_s, "No value available to pop. ^a", keyname);
      return;

return_false: proc;

      ret = "false";

   end return_false;
/* * * * * * * * * * * * *  END set_time_defaults  * * * * * * * * * * * * * */

ptd: print_time_default: print_time_defaults: entry;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*							       */
/* Names: print_time_defaults, ptd                                           */
/*                                                                           */
/* SYNTAX AS A COMMAND:                                                      */
/*     ptd {keys} {-control_arg}				       */
/*                                                                           */
/* SYNTAX AS AN ACTIVE FUNCTION:                                             */
/*    [ptd key {-control_arg}]                                               */
/*                                                                           */
/* FUNCTION:                                                                 */
/* This  command displays  system or  process time-related defaults.         */
/* If set_time_default has pushed any  values, these are also shown.         */
/* The keys  specify which defaults  to print.  When  called with no         */
/* keys,  all  time-related defaults  are  shown.  When  used  as an         */
/* active  function,  it returns  the  current value  of one  of the         */
/* defaults.                                                                 */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* key                                                                       */
/*    selects which default value is to be displayed.                        */
/*                                                                           */
/* CONTROL ARGUMENTS:                                                        */
/* -system, -sys                                                             */
/*    This requests that the system defaults be displayed instead of         */
/*    the process defaults.                                                  */
/*                                                                           */
/* LIST OF keys:                                                             */
/* date                                                                      */
/*    Display  the  default date  format.  A  date format  shows the         */
/*    year, month, and day in month.                                         */
/* date_time                                                                 */
/*    Display the default date/time format.  This combines both date         */
/*    and time.                                                              */
/* debug							       */
/*    Display the date/time debugging switch.			       */
/* language, lang                                                            */
/*    Display  the  default  language.   Any  time  words  in output         */
/*    date/time strings will be in this language.                            */
/* time                                                                      */
/*    Display  the  default time  format.  A  time format  shows the         */
/*    hour, minutes, and perhaps seconds.                                    */
/* zone                                                                      */
/*    Display the default time  zone name.  Unless explicitly speci-         */
/*    fied, all  input time strings will  be interpreted relative to         */
/*    this  zone, and  all output time  values will  be expressed in         */
/*    this zone.                                                             */
/*                                                                           */
/* NOTES:                                                                    */
/* The values displayed are in this order:                                   */
/*    date, date_time, time, language, zone, debug (if on).                  */
/*                                                                           */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* Status:						       */
/*   1) 03/30/83 - jaf	Created				       */
/*							       */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *-* */

      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;

/**** Assume we were called as an active function.  Get ptr to/length of our */
/****  return argument, and count of our input arguments.		       */
      err_sw = ""b;
      string (k) = ""b;
      call arg_start_up;
      if err_sw then return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* NOW process all the arguments given.				       */
      do arg_no = 1 to arg_ct;
         call get_arg (arg_no, arg_p, arg_l, code);
         done = ""b;
         do i = 1 to dimension (keyword, 1) while (^done);
	  if (keyword (i) = arg)
	  then do;
	     done = "1"b;
	     if ^command & (string (k.w) ^= ""b) & (i <= keyword_last)
	     then do;
	        call err (0, me_p,
		 "Active function only accepts one keyword. ^a", arg);
	        return;
	     end;
	     key_sw (i) = "1"b;
	  end;
         end;
         if ^done
         then do;
	  call err (error_table_$badopt, me_p, "^a", arg);
	  err_sw = "1"b;
         end;
      end;
      if ^command & (string (k.w) = ""b)
      then do;
         call err (0, me_p, "Active function must have a keyword.");
         return;
      end;

      if err_sw
      then return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* There are no errors. Do what is required for each option.	       */

      if (string (k.w) = ""b)
      then do;
         string (k.w) = "11110100"b;
         if time_defaults_$debug
         then k.debug_sw = "1"b;
      end;
      sys_sw = (k.system_sw ^= "00"b);

      if k.date_sw
      then do;
         if sys_sw
         then ret = ti_keyword.str (site_date);
         else ret = time_defaults_$date;
         if command
         then if sys_sw
         then call ioa_ ("System default date format: ""^a""", ret);
         else call list$format (p.date, "date format:", ret);
      end;

      if k.date_time_sw
      then do;
         if sys_sw
         then ret = ti_keyword.str (site_date_time);
         else ret = time_defaults_$date_time;
         if command
         then if sys_sw
         then call ioa_ ("System default date/time format: ""^a""", ret);
         else call list$format (p.date_time, "date/time format:", ret);
      end;

      if k.time_sw
      then do;
         if sys_sw
         then ret = ti_keyword.str (site_time);
         else ret = time_defaults_$time;
         if command
         then if sys_sw
         then call ioa_ ("System default time format: ""^a""", ret);
         else call list$format (p.time, "time format:", ret);
      end;

      if k.lang_sw
      then do;
         if sys_sw
         then ret = ti_language.name (time_info_$default_language_index, time_info_$default_language_index);
         else ret = rtrim (time_defaults_$language);
         if command
         then if sys_sw
	  then call ioa_ ("System default language: ^a", ret);
	  else do;
	     if (time_info_$default_language_index = time_defaults_$language_index)
	     then ret = ret || " (system_lang)";
	     call list (p.lang, "language:", ret);
	  end;
      end;

      if k.zone_sw
      then do;
         if sys_sw
         then do;
	  ret = sys_info$time_zone;
	  if command
	  then do;
	     lang_index = time_info_$default_language_index;
	     zone_index = date_time_$get_time_info_index ((ret), Zone_table);
	     call ioa_ ("System default zone: ^a  ^a (^a)",
	        zone_dif (ti_zone.delta (lang_index, zone_index)),
	        ret, ti_zone.long (lang_index, zone_index));
	  end;
         end;
         else do;
	  ret = time_defaults_$zone_short;
	  if command
	  then do;
	     if (translate (ret, AZ, az) = translate (sys_info$time_zone, AZ, az))
	     then ret = ret || " (system_zone, ";
	     else ret = ret || " (";
	     ret = ret || time_defaults_$zone_long;
	     ret = ret || ")";
	     call list (p.zone, "zone: "|| zone_dif (time_defaults_$zone_delta),
	        ret);
	  end;
         end;
      end;

      if k.debug_sw
      then do;
         if sys_sw
         then ret = "off";
         else if time_defaults_$debug
	    then ret = "on";
	    else ret = "off";
         if command
         then if sys_sw
	    then call ioa_ ("System default date/time debugging: ""^a""", ret);
	    else call list (p.debug, "date/time debugging:", ret);
         else if ret = "on"
	    then ret = "true";
	    else ret = "false";
      end;

      return;

/* * * * * * * * * * * * * END print_time_defaults * * * * * * * * * * * * * */

zone_dif: proc (td) returns (char (5));
dcl td		fixed bin (71);

dcl time		fixed bin (71);
dcl 1 result,
      2 s		char (1),
      2 (HH,MM)	pic "99";

	time = td;
	s = "-";			/* values stored in table have       */
	if (time < 0)		/* ..opposite sign from the way it   */
	then do;			/* ..is displayed.		       */
	   s = "+";
	   time = -time;
	end;
	HH, i = divide (time, 3600000000, 17, 0);
	time = time - i*3600000000;
	MM = divide (time, 60000000, 17, 0);
	return (string (result));
       end zone_dif;

arg_start_up: proc;

       err_sw = ""b;
       call cu_$af_return_arg (arg_ct, ret_p, ret_l, code);
       if code = 0			/* if called as an active function,  */
       then do;
	command = "0"b;
	err = active_fnc_err_;
	get_arg = cu_$af_arg_ptr;
       end;
       else if code = error_table_$not_act_fnc /* if called as a command,    */
       then do;
	command = "1"b;		/* indicate so		       */
	get_arg = cu_$arg_ptr;
	err = com_err_;
	ret_p = addr (ret_temp);
	ret_l = maxlength (ret_temp);
       end;
       else do;			/* if some unknown error occurs,     */
	command = "0"b;		/* ..report it to user as if we were */
	call active_fnc_err_ (code, me_p); /* ..called as an active fnc    */
	err_sw = "1"b;
       end;
    end arg_start_up;

push: proc (list_p, item);

dcl list_p	ptr,
    item		char (*);

dcl e_p		ptr;
dcl temp		char (64)var;
dcl 1 e		based (e_p),
      2 version	char (8),		/* identification for dump tracing   */
      2 next	ptr,
      2 data	char (64)var;


         allocate e in (heap);
         e.version = "std_stk";
         e.next = list_p;
         e.data = item;
         list_p = e_p;
         return;

pop: entry (list_p) returns (char (64)var);

         if (list_p = null())
         then goto pop_err;
         e_p = list_p;
         temp = e.data;
         list_p = e.next;
         free e in (heap);
         return (temp);

list: entry (list_p, item, current);
dcl current	char (*)var;
dcl fmt_sw	bit (1);

         fmt_sw = ""b;
         goto start;

list$format: entry (list_p, item, current);

         fmt_sw = "1"b;
start:
         call ioa_ (   "Default ^a ^a", item, form (current));
         do e_p = list_p repeat (e.next) while (e_p ^= null());
	  call ioa_ ("        ^vx ^a", length (item), form ((e.data)));
         end;
         return;

form: proc (format) returns (char (100)var);
dcl format	char (*)var;
dcl result	char (100)var;
dcl i		fixed bin;

         result = format;
         if fmt_sw
         then do;
	  if (index (format, "^") = 0)
	  then do;
	     done = ""b;
	     do i = 1 to ti_keyword.number_kwd while (^done);
	        if (ti_keyword.e.name (i) = format)
	        then do;
		 result = result || " (";
		 result = result || ti_keyword.e.str (i);
		 result = result || ")";
		 done = "1"b;
	        end;
	     end;
	     if ^done
	     then result = result || " (** UNKNOWN KEYWORD **)";
	  end;
	  else do;
	     done = ""b;
	     do i = 1 to ti_keyword.number_kwd while (^done);
	        if (ti_keyword.e.str (i) = format)
	        then do;
		 result = result || " (";
		 result = result || rtrim (ti_keyword.e.name (i));
		 result = result || ")";
		 done = "1"b;
	        end;
	     end;
	  end;
         end;
         return (result);

      end form;

end push;

dcl AZ		char (26) int static options (constant) init (
		"ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl az		char (26) int static options (constant) init (
		"abcdefghijklmnopqrstuvwxyz");
dcl active_fnc_err_ entry options (variable);
dcl arg		char (arg_l) based (arg_p);
dcl arg_ct	fixed bin;
dcl arg_l		fixed bin (21);
dcl arg_no	fixed bin;
dcl arg_p		ptr;
dcl code		fixed bin (35);
dcl com_err_	entry () options (variable);
dcl command	bit (1);
dcl cu_$af_arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl date_time_$valid_format
		entry (char(*), fixed bin, fixed bin(35));
dcl date_time_$get_time_info_index
		entry (char(*), fixed bin) returns(fixed bin);
dcl date_time_$set_time_defaults entry;
dcl date_time_$set_lang
		entry (char (*), fixed bin (35));
dcl date_time_$set_zone
		entry (char (*), fixed bin (35));
dcl done		bit (1);
dcl err		entry options (variable) automatic;
dcl err_sw	bit (1);
dcl errloc	fixed bin;
dcl error_table_$bad_arg fixed bin (35) ext static;
dcl error_table_$badopt fixed bin (35) ext static;
dcl error_table_$bigarg fixed bin (35) ext static;
dcl error_table_$not_act_fnc fixed bin (35) ext static;
dcl error_table_$wrong_no_of_args fixed bin(35) ext static;
dcl get_arg	entry (fixed bin, ptr, fixed bin (21), fixed bin (35))
		automatic;
dcl get_system_free_area_ entry() returns(ptr);
dcl heap		area based (p.heap);
dcl i		fixed bin;
dcl ioa_		entry () options (variable);
dcl keyname	char (32)var;
dcl keyno		fixed bin;
dcl lang_index	fixed bin;
dcl me_s		char (16) int static options (constant)
		init ("set_time_default");
dcl me_p		char (20) int static options (constant)
		init ("print_time_defaults");
/* dcl microseconds_per_hour float dec (20) int static options (constant)
		init (36e8);				       */
dcl on_sw		bit(1);
dcl pop_sw	bit (1);
dcl push_sw	bit (1);
dcl ret		char (ret_l) var based (ret_p);
dcl ret_l		fixed bin (21);
dcl ret_p		ptr;
dcl ret_temp	char (128)var;
dcl sys_info$time_zone  char (3) aligned ext static;
dcl sys_sw	bit (1);
dcl value		char (64)var;
dcl zone_index	fixed bin;
dcl 1 p		int static,	/* put together to ease probing      */
      2 date	ptr init (null ()),
      2 date_time	ptr init (null ()),
      2 debug	ptr init (null ()),
      2 heap	ptr init (null ()),
      2 lang	ptr init (null ()),
      2 time	ptr init (null ()),
      2 zone	ptr init (null ());

dcl (addr, dimension, divide, index, length, maxlength, null, rtrim,
     string, translate
    )		builtin;


dcl key_sw	(10) bit (1)unal defined k;
dcl 1 k,
     2 w,
       3 date_sw	bit (1),
       3 date_time_sw bit (1),
       3 time_sw	bit (1),
       3 lang_sw	bit (2),		/* 4 language, 5 lang	       */
       3 zone_sw	bit (1),
       3 debug_sw   bit (2),		/* 7 debug,    8 db		       */
     2 system_sw	bit (2);		/* 9 -sys,    10 -system	       */

dcl keyword_last	fixed bin int static options (constant) init (8);
dcl keyword	(10) char (10) int static options (constant) init (
		"date",		/* 1 */
		"date_time",	/* 2 */
		"time",		/* 3 */
		"language",	/* 4 */
		"lang",		/* 5 */
		"zone",		/* 6 */
		"debug",		/* 7 */
		"db",		/* 8 */
		"-sys",		/* 9 */
		"-system");        /* 10 */

%include time_names;
%include time_info_search;
%include time_defaults_;

   end set_time_default;





		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved