convert_date_to_binary_.rd      12/11/99  1849.5r w 12/11/99  1846.7      559296



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

/*++
BEGIN
main    	/ <no-token>		/						/ RETURN	\
	\" Begin with parsing of long date
	/ <month_name> <day>	/ SL(1) Amonth_and_LEX Aday_and_LEX SLe			/ year 	\
	/ <day> <month_name>	/ SL(2) Aday_and_LEX Amonth_and_LEX SLe			/ year_	\

	\" Short date formats
	/ <month> /_ <day> /_ <year>
			      	/ SL(3) Amonth_and_LEX LEX Aday_and_LEX LEX Ayear_and_LEX SLe/ main	\
	/ <month> /_ <day>
			       	/ SL(4) Amonth_and_LEX LEX Aday_and_LEX Ayear_default SLe	/ main	\
	/ <year> - <month> - <day>	/ SL(5) Ayear_and_LEX LEX Amonth_and_LEX LEX Aday_and_LEX SLe/ main	\
	/ <fweek> <n>		/ SL(6) LEX Afw LEX SLe				/ main	\

	\" One of the Numeric-Offset family
	/ <N> <andfraction> <offset>	/ SL(7) Afraction_offset LEX(3) SLe			/ main	\

	\" request_id format
	/ <n12> <andfraction6>	/ SL(8) Arequest_id LEX(2) SLe			/ main	\

	\" Time formats
	/ <n> <andfraction>		/ SL(9) Atime LEX Aminute_fraction LEX SLe		/ zone_dif\
	\" <n> . is handled because <andfraction> may be just "."
	/ <hour> : <minute>		/ SL(10) Ahour_and_LEX LEX Aminute_and_LEX SLe		/ second	\
	/ <hour> <meridian>		/ SL(11) Ahour_and_LEX Ameridian LEX
				  Aminute_zero Asecond_zero SLe			/ zone_dif\
	/ <twelve> <half_day>	/ SL(12) LEX Ahalf_day LEX SLe			/ zone_dif\
	/ <half_day>		/ SL(13) Ahalf_day LEX SLe				/ zone_dif\

	\" Day of week.  It is offset if no other date given, or validates a given date.
	/ <day_name> ,		/ SL(14) Uday_of_week LEX(2) SLe			/ main	\
	/ <day_name> <before_on_after>/ SL(15) Uday_of_week LEX Ab_o_a LEX SLe		/ adv_day	\
	/ <day_name>		/ SL(16) Uday_of_week LEX SLe				/ main	\

	\" Numeric offsets
num_off	/ <sign> <N> <offset>	/ SL(17) apply_sign_and_offset LEX(3) SLe		/ main	\
	/ <N> <offset>		/ SL(18) apply_offset LEX(2) SLe			/ main	\
	/ <sign> <N> <andfraction> <offset>
				/ SL(19) Afraction_sign_and_offset LEX(4) SLe		/ main	\
	/ <fraction> <offset>	/ SL(20) Afraction_offset LEX(2) SLe			/ main	\
	/ <sign> <fraction> <offset>
				/ SL(21) Afraction_sign_and_offset LEX(3) SLe		/ main	\


	\" Time zone which qualifies the time given.
	/ <zone>			/ SL(22) Azone LEX SLe				/ main	\
	/ <yesterday>		/ SL(23) Ayesterday LEX SLe				/ main	\
	/ <today>			/ SL(23) Atoday LEX SLe				/ main	\
	/ <tomorrow>		/ SL(23) Atomorrow LEX SLe				/ main	\
	/ <now>			/ SL(23) Anow LEX SLe				/ main	\
	/			/ [last_adverb = VWon]				/	\
	/ <before_after> <or>	/ LEX [err_pt=token.Pvalue;
				  details="""or"" can only be used with <day-name>.";
				  lcode=error_table_$dt_time_conversion_error]		/ RETURN	\
	/ <before_after>		/ SL(24) Aadverb LEX SLe				/ main	\

	\" Error diagnostics and return value.
	/ <on>			/  [err_pt=token.Pvalue;details = """on"" can only be used with <day-name>.";
				    lcode=error_table_$dt_time_conversion_error]		/ RETURN	\
	/ <any-token>		/  [err_pt=token.Pvalue;
				    lcode=error_table_$dt_time_conversion_error]		/ RETURN	\
	/ <no-token>		/						/ RETURN	\

adv_day	/ <or> <before_after>	/ SL(25) LEX Ab_a LEX SLe				/	\
	/			/ [rtime_first = "1"b]				/ main	\

	\" Optional seconds and meridian in HH:MM:SS <MERIDIAN><zone-differential>
second	/ : <second> <andfraction>	/ SL(26) LEX Asecond_and_LEX Asecond_fraction LEX SLe	/ meridian\
	/ : <second>		/ SL(27) LEX Asecond_and_LEX SLe			/ meridian\
	/ <andfraction>		/ SL(28) Aminute_fraction LEX SLe			/ meridian\
	/			/ Asecond_zero					/	\
meridian	/ <meridian>		/ SL(29) Ameridian LEX SLe				/	\

zone_dif	/ <sign> <n4> <offset>	/						/ num_off	\
	/ <sign> <n4> <andfraction>	/						/ num_off	\
	/ <sign> <n4>		/ SL(30) [SIGN = token_value] LEX Azone_dif LEX SLe	/ main	\
	/			/						/ main	\

	\" Look for optional year in long date formats.
year	/ , <year>		/ SL(31) LEX Ayear_and_LEX SLe			/ main	\
year_	/ <n> <andfraction>		/ Ayear_default					/ main	\
	/ <n> :			/ Ayear_default					/ main	\
	/ <n> <meridian>		/ Ayear_default					/ main	\
	/ <twelve> <half_day>	/ Ayear_default					/ main	\
	/ <n> <offset>		/ Ayear_default					/ main	\
	/ <day> <month_name>	/ [err_pt=token.Pvalue;
				   details="<day> <month_name> already given.";
				   lcode=error_table_$dt_time_conversion_error]  		/ RETURN	\
	/ <year>			/ SL(32) Ayear_and_LEX SLe				/ main	\
	/			/ Ayear_default					/ main	\
											++*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/
	/* 								         */
	/* Name: convert_date_to_binary_					         */
	/* 								         */
	/*      This subroutine parses a time string, converting it to a standard Multics        */
	/* clock value.  Refer to the MPM Subroutines for a description of a time string.        */
	/* 								         */
	/* Status								         */
	/* 								         */
	/* 0) Created  March 11, 1971      by  Dan Bricklin			         */
	/* 1) Modified July 30, 1971       by  Dan Bricklin - add offset feature	         */
	/* 2) Modified September 10, 1979  by  Gary Dixon - complete rewrite into reduction      */
	/*    language.							         */
	/* 3) Modified June 1, 1983	     by  J Falksen - add fractional offsets, convert	*/
	/*				to new date/time software.			*/
	/* 4) Modified Jan 20, 1984	     by  J Falksen - added optional "," after day_name,	*/
	/*				zone differential form			*/
	/* 5) Modified Aug 1984	     by jaf - added now/today/tomorrow/yesterday		*/
	/*				this_XXX, and adverbial offsets		*/
	/*								         */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/

/* HISTORY COMMENTS:
  1) change(86-07-18,GDixon), approve(86-07-25,MCR7495),
     audit(86-07-25,Martinson), install(86-09-16,MR12.0-1120):
     Prior to this change, a time string containing ? caused debugging messages
     to be printed by convert_date_to_binary_.  This change triggers debugging
     from the setting of a new time_defaults_$debug switch, and removes support
     for ? in time strings.
  2) change(86-08-14,GDixon), approve(86-09-04,MCR7532),
     audit(86-09-05,Martinson), install(86-09-16,MR12.0-1159):
     Correct null_pointer fault which occurred when processing the time string
     "this". (phx19450)
  3) change(86-08-14,GDixon), approve(86-09-04,MCR7532),
     audit(86-09-05,Martinson), install(86-09-16,MR12.0-1159):
     Make "<day_name> <on> <date>" and "<date> <day_name>" forms of time
     strings properly verify that the given date falls on the given day_name.
     (phx20492)
  4) change(88-05-26,GDixon), approve(88-05-26,MCR7900),
     audit(88-07-28,Lippard), install(88-08-02,MR12.2-1075):
     Added the $analyze entrypoint, an internal entry used primarily by
     memo_repeat_.pl1 to determine if a memo repeat interval given by the user
     consists only of fixed-length offsets (eg, 1 day 5 hours).  All offsets
     greater than weeks are variable-length.  Even 5 years is variable because
     of leap year calculations.  memo calls the new $analyze entrypoint to
     apply the offset once to the current memo time.  If that produces a time
     which is still in the past and the offsets are all fixed length, memo
     simple adds the fixed-length number of microseconds the offset represents
     iteratively until a time in the future is obtained. If the offsets are
     variable length, memo must call $relative repeated until a time in the
     future is obtained. (phx21094)
  5) change(88-05-29,GDixon), approve(88-06-15,MCR7918),
     audit(88-07-28,Lippard), install(88-08-02,MR12.2-1075):
      A) Correct error preventing an absolute day-of-week specification from
         being enforced.  Fix allows "date 6/1/88 thu" to be reported as an
         error, since it is really a Wednesday. (date_time 32)
  6) change(99-06-23,Haggett):
     Y2K
                                                   END HISTORY COMMENTS */


/* Name: convert_date_to_binary_                                             */
/*                                                                           */
/* ENTRY:  convert_date_to_binary_                                           */
/*                                                                           */
/* The convert_date_to_binary_ subroutine  converts a character rep-         */
/* resentation of a  date and time into a  72-bit clock reading.  It         */
/* accepts  a wide  variety of  date and  time forms,  including the         */
/* output of the date_time_ subroutine.                                      */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl convert_date_to_binary_ entry (char (*), fixed bin (71),           */
/*       fixed bin (35));                                                    */
/*    call convert_date_to_binary_ (time_string, clock, code);	       */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* time_string (input)					       */
/*    the time string  to be converted.  See  Multics Programmers' Refer-    */
/*    ence Manual for a description of acceptable strings.                   */
/* clock (output)                                                            */
/*    the resulting clock value.  Unchanged if an error occurs.              */
/* code (output)                                                             */
/*    is a standard  status code.  It can have  one of the following         */
/*    values--                                                               */
/*    error_table_$bad_conversion                                            */
/*    error_table_$dt_ambiguous_time                                         */
/*    error_table_$dt_bad_day_of_week				       */
/*    error_table_$dt_bad_fw                                                 */
/*    error_table_$dt_hour_gt_twelve                                         */
/*    error_table_$dt_multiple_date_spec                                     */
/*    error_table_$dt_multiple_diw_spec                                      */
/*    error_table_$dt_multiple_meaning                                       */
/*    error_table_$dt_multiple_time_spec                                     */
/*    error_table_$dt_multiple_zone_spec                                     */
/*    error_table_$dt_time_conversion_error                                  */
/*    error_table_$dt_size_error                                             */
/*    error_table_$too_many_tokens                                           */
/*    error_table_$dt_unknown_word                                           */
/*                                                                           */
/* ENTRY:  convert_date_to_binary_$relative                                  */
/*                                                                           */
/* This entry point is  similar to the convert_date_to_binary_ entry         */
/* point,  except  that  the  clock  reading  returned  is  computed         */
/* relative  to an  input clock time  rather than  the current clock         */
/* time.  Thus the clock reading  returned for the string "March 26"         */
/* is the clock  reading for the first March  26 following the input         */
/* clock time, rather than the clock  reading for the first March 26         */
/* following the current  clock time.  Given a 72-bit  clock time to         */
/* use, this  entry point converts  a character representation  of a         */
/* date and time to the equivalent 72-bit clock reading.                     */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl convert_date_to_binary_$relative entry (char (*), fixed            */
/*       bin (71), fixed bin (71), fixed bin(35));                           */
/*    call convert_date_to_binary_$relative (time_string, clock,	       */
/*       clock_in, code);                                                    */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* time_string (Input)					       */
/*    is the character representation of the clock reading desired.          */
/* clock (Output)                                                            */
/*    is the computed clock value relative to the clock_in argument.         */
/* clock_in (Input)                                                          */
/*    is the clock time used to compute the clock value.                     */
/* code (output)                                                             */
/*    is a standard status code.                                             */

convert_date_to_binary_: 
	procedure (time_string, clock_out, code);

     dcl						/*		parameters		*/
	time_string		char(*),		/* date string to be converted. (In)		*/
	clock_out			fixed bin(71),	/* binary clock value. (Out)			*/
	relative_to_clock		fixed bin(71),	/* binary clock value which output clock value	*/
						/*    is relative to. (In)			*/
	fixed_length_sw		bit(1) aligned,	/* on if time_string consists only of		*/
						/*    offsets, where all are smaller than months  */
						/*    (Out)				*/
	code			fixed bin(35);	/* a status code. (Out)			*/

     dcl						/*		automatic variables		*/
	Idelim_type		fixed bin,	/* parse type of delimeter found in string.	*/
	Isearch			fixed bin,	/* index of next string token delimiter.	*/
	Iverify			fixed bin,
	Lnumber_in_str		fixed bin,	/* length of next number found in string.	*/
	Lword_in_str		fixed bin,	/* length of next word found in the string.	*/
	Lstr			fixed bin,	/* length of remainder of input string.		*/
	Ntokens			fixed bin,	/* number of tokens in input string.		*/
	Pstr			ptr,		/* ptr to remainder of input string.		*/
	SIGN			char (1),		/* used for zone differential			*/
	Sspace_encountered		bit(1) aligned,	/* on if previous char of input was whitespace	*/
	a_clock			fixed bin(71),	/* number of micro-seconds in absolute time of day*/
	ambig_sw			bit (1),		/* 1- ambiguous token present			*/
	analyze_sw		bit (1),		/* 1- entered at $analyze entrypoint		*/

	clock_now			fixed bin(71),	/* number of micro-seconds in current time of day.*/
	date_given		bit (1),
	details			char(64)var,
	done			bit (1),
	dow_given			bit (1),
	errloc			fixed bin (24),
	err_pt			ptr,
	fld59			float decimal (59),
	fw_sw			bit (1),		/* FW has been given			*/
	h_time_sw			bit (1),		/* 1- a held time exists			*/
	i			fixed bin,
	ii			fixed bin,
	lang_index		fixed bin,
	lang_temp			bit (18),
	lang_used			bit (18),
	last_adverb		fixed bin,
	lcode			fixed bin (35),
	number			fixed bin(35),	/* a temp for numeric token values.		*/
	offset_sign		float dec (2),	/* multiplier which applies sign to offset values.*/
	rtime_ct			fixed bin,	/* # of relative phrases present.		*/
	rtime_ct_h		fixed bin,	/* held rtime_ct				*/
	rtime_first		bit (1),
	rtime_p			ptr,
	silent			bit (1),		/* 0-print error message w/details		*/
	size_flag			bit (1),		/* enable/disble size condition handler		*/
	tcode			fixed bin (35),
	u_day_of_week		fixed bin,	/* an undetermined (absolute or relative) number	*/
						/*    of a day of the week.			*/
	year_needed		bit (1);
	

     dcl
	1 atime			like time_value,	/* absolute time data given			*/
	1 atime_h			like time_value,	/* hold absolute data given when ambig match	*/
	1 atime_init		like time_value,	/* hold initial value			*/
	1 ctime			like time_value,	/* current time data			*/
	1 ttime			like time_value,	/* yesterday/tomorrow data, if needed		*/
	1 tokens (250)		like token,	/* array of tokens.				*/
	1 rtime			aligned like time_offset based (rtime_p),
	1 rtime_array		aligned like time_offset_array based (rtime_p),
	1 rspace_init (8)		aligned,
	  2 rel_ct		fixed bin,
	  2 dw_required		fixed bin,
	  2 data like time_offset_array,
	1 rspace (8)		aligned,		/* rel time given				*/
	  2 rel_ct		fixed bin,
	  2 dw_required		fixed bin,
	  2 data like time_offset_array,
	1 rspace_h (8)		aligned,		/* held rspace during ambig processing		*/
	  2 rel_ct		fixed bin,
	  2 dw_required		fixed bin,
	  2 data like time_offset_array;

     dcl						/*		based variables		*/
	first_char_of_str		char(1) based (Pstr),
						/* first character of remainder of input string.	*/
	number_in_str		char(Lnumber_in_str) based(Pstr),
	str			char(Lstr) based (Pstr),
						/* remainder of input string.			*/
	word_in_str		char(Lword_in_str) based(Pstr);
						/* next word in the string.			*/
	
     dcl
         (addcharno, addr, addrel, charno, char, clock, convert, copy, dim,
	divide, fixed, hbound, index, length, ltrim, mod, null, rtrim,
	search, string, substr, sum, translate, unspec, verify)
				builtin;


     dcl						/*	conditions and entry points.		*/
	(conversion, size)		condition,
	semantic_error		condition, 
	date_time_$from_clock	entry (fixed bin(71), char(*), ptr, fixed bin(35)),
	date_time_$to_clock		entry (ptr, fixed bin(71), fixed bin(35)),
	date_time_$offset_to_clock	entry (ptr, fixed bin(71), char(*), fixed bin(71), fixed bin(35)),
	ioa_$nnl			entry() options(variable);


     dcl						/*		static variables		*/
        (FALSE			init("0"b),
          TRUE			init("1"b)) bit(1) int static options(constant),
	microseconds_per_day	fixed bin (71) int static options (constant) init (864e8),
         (Tunknown		init(0),			/* Table unknown				*/
	TTnumber		init(8),			/* Token Type xxx				*/
	TTbignum		init(9),
	TTfraction	init(10),
	TTandfraction	init(11),
	TTother		init(12),

	VWbefore		init(1),			/* Value for Word xxx			*/
	VWor		init(2),
	VWafter		init(3),
	VWon		init(4),
	VWnoon		init(5),
	VWmidnight	init(6),
	VWnow		init(7),
	VWyesterday	init(8),
	VWtoday		init(9),
	VWtomorrow	init(10),
	VWfw		init(11),
	VWam		init(12),
	VWpm		init(13),

	VOyear		init(1),			/* Value for Offset xxx			*/
	VOmonth		init(2),
/*	VOweek		init(3),				       */
	VOday		init(4),
	VOhour		init(5),
	VOminute		init(6),
	VOsecond		init(7),
/*	VOmicrosecond	init(8)				       */

	need_default	init (-1),
	need_year		init (-2),
	need_this		init (-3),
	need_yesterday	init (-10),
	need_today	init (-11),
	need_tomorrow	init (-12)
	)			fixed bin int static options(constant),
						/* various token types.			*/
	Ttoken (19)		fixed bin int static options(constant) init (
				     0, 0, 0, 3, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, 3, 3),
				/*  HT SP  _  +  -  0  1  2  3  4  5  6  7  8  9  .  /  :  ,	*/
				/* Type of lex to be performed for a token beginning with one of the	*/
				/*    above characters.					*/
	Type	fixed bin,
	Value	fixed bin(35);
      dcl (
	error_table_$bad_conversion,
	error_table_$dt_ambiguous_time,
	error_table_$dt_bad_day_of_week,
	error_table_$dt_bad_fw,
	error_table_$dt_hour_gt_twelve,
	error_table_$dt_multiple_meaning,
	error_table_$dt_multiple_date_spec,
	error_table_$dt_multiple_diw_spec,
	error_table_$dt_multiple_time_spec,
	error_table_$dt_multiple_zone_spec,
	error_table_$dt_size_error,
	error_table_$dt_time_conversion_error,
	error_table_$dt_unknown_word,
	error_table_$too_many_tokens
	)					 fixed bin(35) ext static;%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	analyze_sw = FALSE;
	if constant_sw
	then clock_now = constant_clock;
	else clock_now = clock();			/* initialize clock value to current time.	*/
	goto COMMON;

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


relative:	entry	(time_string, clock_out, relative_to_clock, code);

	analyze_sw = FALSE;
	if constant_sw				/* if we're in testing mode, use the forced	*/
	then clock_now = constant_clock;		/* ..value instead of his.			*/
	else clock_now = relative_to_clock;

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

analyze:	entry	(time_string, relative_to_clock, clock_out, fixed_length_sw, code);
	
	analyze_sw = TRUE;
	fixed_length_sw = FALSE;
	if constant_sw				/* if we're in testing mode, use the forced	*/
	then clock_now = constant_clock;		/* ..value instead of his.			*/
	else clock_now = relative_to_clock;
	

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

COMMON:	tcode, lcode, errloc = 0;			/* no errors found during semantic analysis.	*/
	details = "";
	Pfirst_token, err_pt = null();
	h_time_sw = ""b;				/* no held time data			*/
	rtime_ct = 0;				/* no relative date/time values encountered yet.	*/
	rtime_first = "1"b;				/* This is set on initially.			*/
						/* before/on/after will do so also.		*/
	lang_used = copy ("1"b, ti_language.number_lang);	/* show ALL languages used.			*/
	ambig_sw = ""b;				/* and no ambiguous tokens			*/
	code = 0;					/* initialize output value.			*/
	ti_token_p = addr (time_info_$tokens);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/
	/* 								         */
	/* Parse the input string into tokens structured like those created by lex_string_ and   */
	/* used with reductions (see reduction_compiler).  lex_string_ is not used because we    */
	/* don't need all of its power, and because our parse associates semantic information    */
	/* with the tokens during the parsing.					         */
	/* 								         */
	/* A token is a lexeme of a time string. Examples are 12, /, Monday, Janvier, 1979,      */
	/* etc.  The parser below finds the tokens in the string.  Associated with each token is */
	/* a token type and a numeric value.  The numeric value depends upon the type of token.  */
	/* Numeric character string tokens use the numeric value of the character string         */
	/* (converted according to PL/I conversion rules).  Month names have their month number  */
	/* as a numeric value.  The same is true for day names (1=Mon,...,7=Sun).  Offset words  */
	/* (like weeks, days, etc) have a value from 1 to 7 (1=years,2=months,...7=seconds).  As */
	/* each token is found, it is added to a chain of tokens by the token_ procedure. token_ */
	/* also removes the token from the string, leaving only unprocessed string characters to */
	/* be parsed.							         */
	/* 	Due to the multiple languages, there are tokens which are ambiguous.  This	*/
	/* means that it does not mean the same thing in all languages.  When one of these guys	*/
	/* is encountered, it is flagged as "unknown".  These steps are taken to decide what a	*/
	/* token is to be used as.							*/
	/*   1) All nonambiguous tokens have their language bits ANDed.  If this results in	*/
	/*      all zeroes, there is a mixed language error.				*/
	/*   2) A multiple parse will be undertaken, first with the process default language,	*/
	/*      then the system default, then with any left in the order they appear in		*/
	/*      time_info_.  HOWEVER, the nonambiguous tokens will have restricted the set of	*/
	/*      possible languages.							*/
	/*         The unknown tokens do not have their numeric value set.  During each pass,	*/
	/*      when a semantic function decides a token can be the type it is looking for it	*/
	/*      will plug in the appropriate numeric value while leaving the type unknown.	*/
	/*      The action routine will then be able to pick up the value without extra work.	*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **/

	
	Pstr = addr(time_string);		/* address time string.			*/
	Lstr = length(time_string);
	silent = ^time_defaults_$debug;
	Ntokens = 0;				/* No tokens found yet.			*/
	on conversion				/* handle number conversion errors.		*/
	begin;
	   lcode = error_table_$bad_conversion;
	   goto set_err_loc;
	end;
	size_flag = ""b;
	on size
	begin;
	   if size_flag
	   then do;				/* we know it is all digits, but it might	*/
	      Type = TTbignum;			/* ..not fit in a fixed bin (35).  Thats OK.	*/
	      number = -1;
	      goto lex1a;
	   end;
	   lcode = error_table_$dt_size_error;
	   goto set_err_loc;
	end;

	Sspace_encountered = TRUE;			/* Pretend string begins with whitespace.	*/
	do while (Lstr > 0);			/* parse the string.			*/
/****          Search string begins with HT SP _ + ...			       			*/
	     Isearch = search (str, "	 _+-0123456789./:,");
	     if Isearch = 0 then Isearch = Lstr + 1;	/* find first delimiter character in string.	*/

	     if Isearch > 1 then do;			/* Was a word found in the string preceding the.	*/
						/*   delimiter?				*/
		Sspace_encountered = FALSE;
re_try:
		Lword_in_str = Isearch-1;
		if length(word_in_str) > 32 then goto Eunknown_word;
						/* make sure word isn't too long.		*/
		item_p = find_time_name (word_in_str);
		if (item_p ^= null())
		then do;				/* word was found				*/
		   Type = item.table (1);
		   Value = item.element (1);
		   if (item.count > 1) & (Type ^= This_table)
		   then do;			/* we can't tell yet			*/
		      lang_temp = ""b;
		      do ii = 1 to item.count;
		         lang_temp = lang_temp | item.in_lang (ii);
		      end;
		      lang_used = lang_used & lang_temp;
		      call token_ (length(word_in_str), Tunknown, 0);
		      ambig_sw = "1"b;		/* remember its ambiguous			*/
		   end;
		   else do;			/*   create a token for the word.		*/
		      call token_ (length(word_in_str), Type, Value);
		      lang_used = lang_used & item.in_lang (1);	/* only 1 element */
		   end;
		   token.Psemant = item_p;		/* keep ptr to token info			*/
		end;
		else do;				/* the generated zones end in digits, so before	*/
						/* giving up, lets try gathering some digits	*/
						/* also.					*/
		   Isearch = search (str, "	 _+-./:,");
		   if Isearch = 0 then Isearch = Lstr + 1;
		   if (Isearch-1 > Lword_in_str)	/* If that increased the token size, we'll	*/
						/*   try once again.			*/
		   then goto re_try;
		   goto Eunknown_word;		/* Oops!  You shouldn't say that.		*/
		end;
		if Lstr <= 0 then goto end_scan;	/* Stop scan if word at end of time string.	*/
		end;

	     Idelim_type = Ttoken (index ("	 _+-0123456789./:,", first_char_of_str));    /* HT SP _ ... */
	     goto lex(Idelim_type);			/* we know first char of str is now a delimiter	*/
						/*   because token_ would skip any word which	*/
						/*   might have preceeded the delimiter.	*/
						/*   Continue lexing according to delimiter type.	*/

lex(0):	     Sspace_encountered = TRUE;
	     Iverify = verify (str, "	 _");		/* skip leading white space (HT SP or _)	*/
	     if Iverify = 0 then Iverify = Lstr + 1;
	     Pstr = addcharno (Pstr,(Iverify-1));
	     Lstr = Lstr - (Iverify-1);
	     goto end_scan;

lex(1):	     Iverify = verify(str, "0123456789");	/* find out how long numeric field is.		*/
	     if Iverify = 0 then Lnumber_in_str = Lstr;
	     else Lnumber_in_str = Iverify - 1;
	     Type = TTnumber;
	     size_flag = "1"b;
	     number = convert(number, number_in_str);	/* This conversion is done because some range	*/
	     size_flag = ""b;			/* ..checking is done, so we need the value.	*/
lex1a:
	     call token_ (length(number_in_str), Type, number);
	     if (Lstr = 0)
	     then goto end_scan;
	     if (substr (str, 1, 1) ^= ".")
	     then goto end_scan;
	     Type = TTandfraction;
	     goto lex2a;

lex(2):	     Type = TTfraction;
lex2a:
	     if (Lstr > 1)
	     then do;
	        Iverify = verify(substr (str, 2), "0123456789");	/* find out how long fraction field is.		*/
	        if Iverify = 0 then Lnumber_in_str = Lstr;
	        else Lnumber_in_str = Iverify;
	     end;
	     else Lnumber_in_str = 1;
	     if (Lnumber_in_str > 0)
	     then call token_ (Lnumber_in_str, Type, 0);
	     Sspace_encountered = FALSE;
	     goto end_scan;

lex(3):	     					/* found "+", "-", "/", ":", or ","		*/
	     Sspace_encountered = FALSE;
	     call token_ (1, TTother, 0);		/*    create a token for the break character.	*/

end_scan:	     end;					/* continue lexing with the next field.		*/

	revert conversion, size;			/* get rid of this thing when not needed.	*/
	if Ntokens = 0 then do;
	     clock_out = clock_now;
	     goto exit;
          end;
						/* analyze semantic content of any lexed tokens.	*/
	if (lang_used = ""b)			/* --NO COMMON LANGUAGE--			*/
	then do;
	   lcode = error_table_$dt_ambiguous_time;
	   goto error_exit;
	end;

	unspec (atime_h) = ""b;
	unspec (rspace_h) = ""b;
	unspec (atime_init) = ""b;
	atime_init.version = Vtime_value_3;
	atime_init.yc, atime_init.my, atime_init.dm = need_default;
	atime_init.Hd, atime_init.MH, atime_init.SM, atime_init.US = need_default;
	atime_init.za = "";
	ctime = atime_init;

	unspec (rspace_init) = ""b;
	rtime_p = addr (rspace_init (1).data);
	rtime.version = Vtime_offset_2;
	rtime_array.val (*) = 0;				/* must have decimal zeroes there		*/
	do i = 2 to dim (rspace_init, 1);
	   rspace_init (i) = rspace_init (1);
	end;
	on condition (semantic_error)
	begin;
	   goto parse_fail;
	end;
	done = ""b;
	do lang_index = time_defaults_$language_index,
	   time_info_$default_language_index while (^done),
	   1 to ti_language.number_lang while (^done);
	   if substr (lang_used, lang_index, 1)
	   then do;
	      if ^silent & ambig_sw
	      then call ioa_$nnl ("***Trying ^a.^/", ti_language.name (1, lang_index));
	      substr (lang_used, lang_index, 1) = ""b;	/* show its been used			*/
	      rspace = rspace_init;
	      atime = atime_init;
	      fw_sw = ""b;
	      u_day_of_week = 0;			/* absolute/relativeness undetermined.		*/

						/* analyze semantic content of lexed tokens.	*/
	      Pthis_token = addr(tokens(1));
	      tcode, lcode, errloc = 0;
	      err_pt = null();
	      call SEMANTIC_ANALYSIS();
/****	      We don't know what day_of_week stands for yet, just preserve */
/****	      until later.					       */
	      atime.dw = u_day_of_week;
parse_fail:
	      call error_display;
	      done = ^ambig_sw;
	      if (lcode = 0)
	      then do;
	         if ^ambig_sw
	         then goto parse_success;
/****           When ambiguity exists, we must try all selected languages. 				*/
/****           If there is only 1 match, we assume we are safe.  Otherwise we				*/
/****	      must complain that we can't tell.							*/
	         if ^h_time_sw			/* is this first match?			*/
	         then do
		  h_time_sw = "1"b;			/* ..yes, remember the set of data found.	*/
		  atime_h = atime;
		  rspace_h = rspace;
		  rtime_ct_h = rtime_ct;
	         end;
	         else if (unspec (atime_h) ^= unspec (atime))	/* ..no, did we find a different meaning?	*/
		  | (unspec (rspace_h) ^= unspec (rspace))
	         then do;				/* ..yes					*/
		  lcode = error_table_$dt_multiple_meaning;
		  goto error_exit;			/* Sorry ma'm, no can do.			*/
/**** At this point we could trigger a 2nd pass which will gather info to give a more meaningful message.	*/
	         end;
	      end;
	   end;
	end;
	call error_display;
	if ^h_time_sw				/* if there was no match, we are all done	*/
	then do;
error_exit:
	   call error_display;
	   code = lcode;
exit:
	   return;
	end;

error_display: proc;
	   if (lcode = 0) | (lcode = tcode)
	   then return;
	   if ^silent
	   then do;
	      if (Pfirst_token ^= null())
	      then call ioa_$nnl ("^/");
	      if (lcode ^= 0)
	      then do;
	         if (err_pt ^= null())
	         then errloc = charno (err_pt) - charno (addr (time_string)) + 1;
	         call com_err_ (lcode, "convert_date_to_binary_", "^[
^a^;^s^]^[
String is: ""^va""
 error at: ^vx^^^]", (details ^= ""), details,
		  (errloc > 0), length (time_string), time_string, errloc);
	      end;
	   end;
	   tcode = lcode;
	end error_display;%page;
parse_success:
	if h_time_sw
	then do;
	   atime = atime_h;				/* bring back the remembered success		*/
	   rspace = rspace_h;
	   rtime_ct = rtime_ct_h;
	end;
/****     Now retrieve day_of_week, so that we can determine what it is.     */
	u_day_of_week = atime.dw;
	atime.dw = 0;

	Lstr = 80;				/* keeps debugging code working		*/
	year_needed, date_given, dow_given = ""b;
						/* get current date/time values.		*/

	if analyze_sw				/* For $analyze entrypoint,			*/
	then do;					/*  the time_string is a fixed-length increment   */
	   if unspec(atime) = unspec(atime_init) then	/*  iff no absolute date/time info is given, and  */
	   if u_day_of_week = 0 then			/*  only week, day, hour, minute, second and/or   */
	   if rtime_ct > 0 then do;			/*  microsecond offsets are given.                */
	      do i = rtime_ct to 1 by -1;
	         rtime_p = addr(rspace(i).data);
	         if rtime.flag.yr + rtime.flag.mo > UNUSED
	         then go to NOT_FIXED_LENGTH;
	         end;
	      fixed_length_sw = TRUE;
	      end;
NOT_FIXED_LENGTH:
	   end;

	if (atime.za = "#") then atime.za = "gmt";	/* request_id defaults to GMT			*/
	call date_time_$from_clock (clock_now, atime.za, addr (ctime), code);
	if u_day_of_week ^= 0 then			/* apply defaults to unset date/time values.	*/
	     if atime.my ^= need_default then		/*    day_of_week is absolute if user also gave	*/
		atime.dw = u_day_of_week;		/*       a date specification.		*/
	     else do;				/*    otherwise, it is a day_of_week date,	*/
	          date_given = "1"b;
		call init_rtime;
		rtime.flag.da = USED;
		rtime.val.da = rtime.val.da + mod (u_day_of_week - ctime.dw + 6, 7) + 1;
		end;

	if (atime.yc = need_this) then atime.yc = ctime.yc;
	if (atime.my = need_this) then atime.my = ctime.my;
	if (atime.dm = need_this) then atime.dm = ctime.dm;
	if (atime.Hd = need_this) then atime.Hd = ctime.Hd;
	if (atime.MH = need_this) then atime.MH = ctime.MH;
	if (atime.SM = need_this) then atime.SM = ctime.SM;

	if atime.my = need_yesterday
	then do;
	   ttime = atime_init;
	   call date_time_$from_clock (clock_now - microseconds_per_day, atime.za,
	      addr (ttime), code);
	   atime.yc = ttime.yc;
	   atime.my = ttime.my;
	   atime.dm = ttime.dm;
	end;
	else if atime.my = need_today
	then do;
	   atime.yc = ctime.yc;
	   atime.my = ctime.my;
	   atime.dm = ctime.dm;
	end;
	else if atime.my = need_tomorrow
	then do;
	   ttime = atime_init;
	   call date_time_$from_clock (clock_now + microseconds_per_day, atime.za,
	      addr (ttime), code);
	   atime.yc = ttime.yc;
	   atime.my = ttime.my;
	   atime.dm = ttime.dm;
	end;
	if atime.my = need_default	 		/* supply month-day if needed		*/
	then do;
	   atime.my = ctime.my;
	   atime.dm = ctime.dm;
	end;
	else date_given = "1"b;
	if atime.yc < 0 then do;			/* supply year if needed--		*/
						/*   this_year or a missing year.		*/
	   if atime.yc = need_year			/* missing year-- assume current year for now.	*/
	   then year_needed = "1"b;
	   atime.yc = ctime.yc;
	end;
	if atime.Hd = need_default then do;		/* supply time defaults if needed	*/
	     atime.Hd = ctime.Hd;
	     atime.MH = ctime.MH;
	     atime.SM = ctime.SM;
	     atime.US = ctime.US;
	     end;

/****	  else if (atime.Hd=24)...				       */
/****          In the old days, the "24" times were handled right here.      */
/****          But now date_time_$to_clock handles them instead.	       */
	     
/**** At this point, yc/my/dm/Hd/MH/SM/US have been filled in from "now" if they were not given.	*/
          call date_time_$to_clock (addr (atime), clock_out, code);
	if atime.dw > 0 & code = error_table_$dt_bad_day_of_week
	then do;
	   if clock_out >= clock_now |		/* if day-of-week doesn't match and a   */
	     (^year_needed & date_given)		/* specific date was given, report an   */
	   then go to exit;				/* error now.			*/
	   atime.dw = 0;				/* Otherwise, delay dow check until the */
						/* specific date is known.		*/
	   call date_time_$to_clock (addr (atime), clock_out, code);
	   call init_rtime;				/* setup to do dow checks below.	*/
	   rspace(rtime_ct).dw_required = u_day_of_week;
	   rtime_first = "1"b;
	   atime.dw = 0;
	end;
          if code ^= 0
	then go to exit;
	if (clock_out < clock_now)			/* if value as defaulted is less than	*/
	then do;					/* ..NOW, we have to adjust forward.	*/
	   if year_needed
	   then do;
	      call init_rtime;
	      rtime.flag.yr = USED;
	      rtime.val.yr = rtime.val.yr +1;
	   end;
	   else if ^date_given
	   then clock_out = clock_out + microseconds_per_day;
	end;

	do i = rtime_ct to 1 by -1 while (code = 0);
	   if rspace(i).dw_required > UNUSED then do;
	      call date_time_$from_clock (clock_out, atime.za, addr(atime), code);
	      if atime.dw ^= rspace(i).dw_required
	      then do;
	         code = error_table_$dt_bad_day_of_week;
	         goto exit;
	      end;
	   end;
	   if sum(rspace(i).data.flag(*)) > UNUSED | 
	      rspace(i).data.dw.flag ^= UNUSED
	   then call date_time_$offset_to_clock (addr (rspace (i).data),
	      clock_out, atime.za, clock_out, code);
	end;
	goto exit;%skip(2);
Eunknown_word:
	lcode = error_table_$dt_unknown_word;
	goto set_err_loc;

Etoo_many_adverbs:
	details = "Only " || ltrim (char (hbound (rspace,1)))
	   || " offset groups may be used.";
	lcode = error_table_$too_many_tokens;
	err_pt = token.Pvalue;
	goto error_exit;

Etoo_many_tokens:
	lcode = error_table_$too_many_tokens;
set_err_loc:
	err_pt = Pstr;
	goto error_exit;%page;
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*					       */
	/* The following 2 entries are an aid to debugging.      */
	/* The "set" entry allows a person to fix the reference  */
	/* value to any point they wish.  The "unset" entry      */
	/* returns things to the normal state.  After having     */
	/* called "set", all calls to $convert_date_to_binary_   */
	/* function as if the $relative entry had been called    */
	/* with the saved value.			       */
	/*					       */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl constant_sw	bit (1) int static init (""b);
dcl constant_clock	fixed bin (71) int static;

unset: entry;

          constant_sw = ""b;
	return;

set: entry;
/****     Wrap this code up in a begin block to make 100% sure that nobody outside depends	*/
/****     on anything herein.  Then we can be sure that it may be deleted without effect.		*/
          begin;
	   call cu_$arg_ptr (1, arg_p, arg_l, code);
	   if (code ^= 0)
	   then constant_clock = clock();
	   else do;
	      call convert_date_to_binary_ (arg, a_clock, code);
	      if (code ^= 0)
	      then do;
	         call com_err_ (code, "convert_date_to_binary_$set", "^a", arg);
	         return;
	      end;
	      constant_clock = a_clock;
	   end;
	   constant_sw = "1"b;
	   return;
     dcl
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	arg			char (arg_l) based (arg_p),
	arg_l			fixed bin (21),
	arg_p			ptr,
	code			fixed bin (35);
     end;%page;
dcl Pfirst_token	ptr;
SL: proc (red);
dcl red		fixed bin;	/* reduction to display	       */

        if ^silent
        then do;
	 Pfirst_token = Ptoken;
	 call ioa_$nnl (string (SLtext), red);
        end;
        return;

SLe: entry;

        if ^silent
        then do;
	 do Ptoken = Pfirst_token repeat (token.Pnext) while ((Ptoken ^= null()) & (Ptoken ^= Pthis_token));
	    call ioa_$nnl (" ^a", token_value);
	 end;
	 call ioa_$nnl ("^/");
	 Pfirst_token = null();
	 Ptoken = Pthis_token;
        end;

				/* format: off */
dcl 1 SLtext	unaligned int static options (constant),
    2 x0  char ( 3) init ("^3x"),
    2 x1	char (20) init ("^[<month-name> <day>"),
    2 x2	char (20) init ("^;<day> <month-name>"),
    2 x3	char (26) init ("^;<month> / <day> / <year>"),
    2 x4	char (17) init ("^;<month> / <day>"),
    2 x5	char (26) init ("^;<year> - <month> - <day>"),
    2 x6	char (29) init ("^;<fiscal-indicator> <number>"),
    2 x7	char (34) init ("^;<number> <and-fraction> <offset>"),
    2 x8	char (14) init ("^;<request-id>"),
    2 x9	char (23) init ("^;<HHMM> <and-fraction>"),
    2 x10	char (19) init ("^;<hour> : <minute>"),
    2 x11	char (29) init ("^;<hour> <meridiem-indicator>"),
    2 x12	char (15) init ("^;12 <half-day>"),
    2 x13	char (12) init ("^;<half-day>"),
    2 x14	char (14) init ("^;<day-name> ,"),
    2 x15	char (21) init ("^;<day-name> <adverb>"),
    2 x16	char (12) init ("^;<day-name>"),
    2 x17	char (26) init ("^;<sign> <number> <offset>"),
    2 x18	char (19) init ("^;<number> <offset>"),
    2 x19	char (41) init ("^;<sign> <number> <and-fraction> <offset>"),
    2 x20	char (21) init ("^;<fraction> <offset>"),
    2 x21	char (28) init ("^;<sign> <fraction> <offset>"),
    2 x22	char ( 8) init ("^;<zone>"),
    2 x23	char ( 8) init ("^;<word>"),
    2 x24	char (10) init ("^;<adverb>"),
    2 x25	char (13) init ("^;or <adverb>"),
    2 x26	char (27) init ("^;: <second> <and-fraction>"),
    2 x27	char (12) init ("^;: <second>"),
    2 x28	char (19) init ("^;<minute-fraction>"),
    2 x29	char (22) init ("^;<meridiem-indicator>"),
    2 x30	char (21) init ("^;<zone-differential>"),
    2 x31	char (10) init ("^;, <year>"),
    2 x32	char ( 8) init ("^;<year>"),
    2 x99 char ( 8) init ("^]^25.1t");	/* format: on */

     end SL; %page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/****    A very similar routine exists in get_word_index in date_time_.pl1.				*/

find_time_name: proc (val) returns (ptr);

dcl val		char (*);

dcl (lb, hb)	fixed bin;
dcl symb		char (32) var;
dcl cur_token	fixed bin;
dcl (az		init ("abcdefghijklmnopqrstuvwxyz"),
     AZ		init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
		char (26) int static options (constant);

      symb = translate (val, az, AZ);	/* get to normal form		*/
      symb = rtrim (symb);		/* minimize compare time		*/

      lb = 1;
      hb = ti_token.count;
      do while (lb <= hb);
         cur_token = divide (lb + hb, 2, 17, 0);
         if (ti_token.symbol (cur_token) = symb)
         then return (addrel (addr (time_info_$version),
	       ti_token.list_r (cur_token)));
         if (ti_token.symbol (cur_token) < symb)
         then lb = cur_token + 1;
         else hb = cur_token - 1;
      end;
      return (null ());

   end find_time_name; %skip (5);
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*	SEMANTIC FUNCTIONS  and  ACTION ROUTINES				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


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


day_name:	procedure returns (bit(1) aligned);		/* semantic functions which check for token type.	*/

	Twhich1 = Day_table;
	goto word_check;

fraction:	entry returns (bit(1) aligned);

	if token.Itoken_in_stmt = TTfraction then goto true;
	goto false;

andfraction:	entry returns (bit(1) aligned);

	if token.Itoken_in_stmt = TTandfraction then goto true;
	goto false;

andfraction6:	entry returns (bit(1) aligned);

	if token.Itoken_in_stmt = TTandfraction
	then if length (token_value) = 7 then goto true;
	goto false;
fweek: entry returns (bit(1) aligned);

          Twhich1, Twhich2, Twhich3 = VWfw;
	goto word_table_check;


half_day: entry returns (bit(1) aligned);

	Twhich1 = VWnoon;
	Twhich2, Twhich3 = VWmidnight;

word_table_check:
	if (token.Itoken_in_stmt = Word_table)
	then
	   if (token.Nvalue = Twhich1) | (token.Nvalue = Twhich2)
	   | (token.Nvalue = Twhich3)
	   then goto true;
	if (token.Itoken_in_stmt ^= Tunknown) then goto false;

	item_p = token.Psemant;
	do elem = 1 to item.count;
	   if substr (item.in_lang (elem), lang_index, 1)	/* if defined in current language	*/
	   then if (Word_table = item.table (elem))	/* ..and is a type we want		*/
	   then do;				/* ..its a winner			*/
	      if (Twhich1 = item.element (elem))
	      then do;
	         token.Nvalue = Twhich1;
	         goto true;
	      end;
	      if (Twhich2 = item.element (elem))
	      then do;
	         token.Nvalue = Twhich2;
	         goto true;
	      end;
	      if (Twhich3 = item.element (elem))
	      then do;
	         token.Nvalue = Twhich3;
	         goto true;
	      end;
	   end;
	end;
	goto false;

meridian:	entry returns (bit(1) aligned);

	Twhich1 = VWam;
	Twhich2, Twhich3 = VWpm;
	goto word_table_check;

on:	entry returns (bit(1) aligned);

	Twhich1, Twhich2, Twhich3 = VWon;
	goto word_table_check;

before_on_after:	entry returns (bit(1) aligned);

	Twhich1 = VWbefore;
	Twhich2 = VWon;
	Twhich3 = VWafter;
	goto word_table_check;

before_after:	entry returns (bit(1) aligned);

	if (last_adverb = VWon)
	then do;
	   Twhich1 = VWbefore;
	   Twhich2, Twhich3 = VWafter;
	end;
	else Twhich1, Twhich2, Twhich3 = VWon;
	goto word_table_check;

now:	entry returns (bit(1) aligned);
	Twhich1, Twhich2, Twhich3 = VWnow;
	goto word_table_check;

or:	entry returns (bit(1) aligned);
	Twhich1, Twhich2, Twhich3 = VWor;
	goto word_table_check;

today:	entry returns (bit(1) aligned);
	Twhich1, Twhich2, Twhich3 = VWtoday;
	goto word_table_check;

tomorrow:	entry returns (bit(1) aligned);
	Twhich1, Twhich2, Twhich3 = VWtomorrow;
	goto word_table_check;

yesterday:	entry returns (bit(1) aligned);
	Twhich1, Twhich2, Twhich3 = VWyesterday;
	goto word_table_check;

day: entry returns (bit(1) aligned);
	if this_()
	then do;
	   Twhich1 = VOday;
	   goto offset_table_check_next;
	end;
	goto n_;


month: entry returns (bit(1) aligned);
	if this_()
	then do;
	   Twhich1 = VOmonth;
	   goto offset_table_check_next;
	end;
	goto n_;


year: entry returns (bit(1) aligned);
	if this_()
	then do;
	   Twhich1 = VOyear;
	   goto offset_table_check_next;
	end;
	goto n_;


hour: entry returns (bit(1) aligned);
	if this_()
	then do;
	   Twhich1 = VOhour;
	   goto offset_table_check_next;
	end;
	goto n_;


minute: entry returns (bit(1) aligned);
	if this_()
	then do;
	   Twhich1 = VOminute;
	   goto offset_table_check_next;
	end;
	goto n_;


second: entry returns (bit(1) aligned);
	if this_()
	then do;
	   Twhich1 = VOsecond;
	   goto offset_table_check_next;
	end;
	goto n_;


month_name: entry returns (bit(1) aligned);

	if this_()
	then do;
	   Twhich1 = VOmonth;
	   goto offset_table_check_next;
	end;
	Twhich1  = Month_table;
	goto word_check;


offset_table_check_next:
	if token.Pnext = null then goto false;
	Ptoken = token.Pnext;
	if (token.Itoken_in_stmt = Offset_table)
	then
	   if (token.Nvalue = Twhich1)
	   then goto true;
	if (token.Itoken_in_stmt ^= Tunknown) then goto false;

	item_p = token.Psemant;
	do elem = 1 to item.count;
	   if substr (item.in_lang (elem), lang_index, 1)	/* if defined in current language	*/
	   then if (Offset_table = item.table (elem))	/* ..and is a type we want		*/
	   then do;				/* ..its a winner			*/
	      if (Twhich1 = item.element (elem))
	      then do;
	         token.Nvalue = Twhich1;
	         goto true;
	      end;
	   end;
	end;
	goto false;

N:	entry returns (bit(1) aligned);

	if token.Itoken_in_stmt = TTbignum then goto true;

n:
	entry returns (bit(1) aligned);

n_:
	if token.Itoken_in_stmt = TTnumber then goto true;
	goto false;
n4:
	entry returns (bit(1) aligned);

	if token.Itoken_in_stmt = TTnumber then
	     if length(token_value) = 4 then goto true;
	goto false;


n12: entry returns (bit(1) aligned);

	if (token.Itoken_in_stmt = TTnumber) | (token.Itoken_in_stmt = TTbignum)
	     then if length(token_value) = 12 then goto true;
	goto false;


offset:	entry returns (bit(1) aligned);

	Twhich1 = Offset_table;
	goto word_check;


this_:	entry returns (bit(1) aligned);

	Twhich1 = This_table;
	goto word_check;


twelve:	entry returns (bit(1) aligned);

	if token.Itoken_in_stmt = TTnumber then
	     if token.Nvalue = 12 then
		goto true;
	goto false;


sign:	entry returns (bit(1) aligned);

	if token_value = "+" | token_value = "-" then goto true;
	goto false;
	

zone:	entry returns (bit(1) aligned);

	Twhich1 = Zone_table;

/**** GCD: This check won't work if token means 2 different values in 2 different languages,	*/
/****     but both values are in the same table.						*/
/**** JAF: I'm not sure it can ever get here if that is the case.  More thought is needed		*/
/****	on having time_info_.cds preventing this kind of a table being constructed.  Or get	*/
/****	figured out when that could happen and still be parsable and then learn to handle it.	*/

word_check:
	item_p = token.Psemant;
	if (token.Itoken_in_stmt = Twhich1) then goto true;	/* token.Nvalue is already set	*/
	if (token.Itoken_in_stmt ^= Tunknown) then goto false;
	do elem = 1 to item.count;
	   if substr (item.in_lang (elem), lang_index, 1)		/* if defined in current language	*/
	   then if (Twhich1 = item.table (elem))
	   then do;					/* ..and is the type we want		*/
	      token.Nvalue = item.element (elem);		/* its a winner			*/
	      goto true;
	   end;
	end;

false:	return (FALSE);

true:	return (TRUE);

     dcl (Twhich1, Twhich2, Twhich3, elem)			fixed bin;

	end day_name;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

Aday_and_LEX:	procedure;			/* action routines which apply input token value	*/
						/*    to absolute/relative date/time, as named in	*/
						/*    entry point.				*/

	if atime.dm ^= need_default then goto Emultiple_date_spec;
	if this_()
	then do;
	   call LEX (1);
	   atime.dm = need_this;
	end;
	else atime.dm = token.Nvalue;
	call LEX (1);
	return;

Ab_o_a:	entry;

	call init_rtime;
	if (rspace.rel_ct (rtime_ct)  ^= 1)
	then do;
	   details = "Cannot mix <day_name> with <offsets>.";
	   lcode = error_table_$dt_time_conversion_error;
	   err_pt = token.Pvalue;
	   signal condition (semantic_error);
	end;
	if (token.Nvalue = VWbefore)			/* <day_name> <before_after>			*/
	then rtime.dw.flag = BEFORE;
	if (token.Nvalue = VWafter)
	then rtime.dw.flag = AFTER;
	rtime.dw.val = u_day_of_week;
	if (token.Nvalue = VWon)			/* <day_name> <on>				*/
	then rspace.dw_required(rtime_ct) = u_day_of_week;
	u_day_of_week = 0;
	last_adverb = token.Nvalue;
	return;

Ab_a:	entry;

	call init_rtime;
	if (rspace.rel_ct (rtime_ct) < 2)   		/* there must be something to apply to		*/
	then do;
	   details = "Nothing for adverb to apply to.";
	   lcode = error_table_$dt_time_conversion_error;
	   err_pt = token.Pvalue;
	   signal condition (semantic_error);
	end;
	begin;					/* <day_name> <before_after> <or> <on>		*/
dcl sign		builtin;
	   if (token.Nvalue = VWon)
	   then rtime.dw.flag = rtime.dw.flag - sign (rtime.dw.flag);
	end;
	if (token.Nvalue = VWbefore)			/* <day_name> <on> <or> <before_after>		*/
	then rtime.dw.flag = ON_OR_BEFORE;
	if (token.Nvalue = VWafter)
	then rtime.dw.flag = ON_OR_AFTER;
	if rtime.dw.flag ^= UNUSED
	then rspace.dw_required(rtime_ct) = UNUSED;
	return;
	
	

Afw:	entry;

	if fw_sw | (atime.yc ^= need_default) |(atime.my ^= need_default)
	then goto Emultiple_date_spec;
	atime.yc, atime.my, atime.dm = 0;
	if (length (token_value) = 6) | (length (token_value) = 5)
	then do;
	   atime.fw = token.Nvalue;
	   fw_sw = "1"b;
	   return;
	end;
	lcode = error_table_$dt_bad_fw;
	err_pt = token.Pvalue;
	signal condition (semantic_error);
	

Ahalf_day:	entry;

	if atime.Hd ^= need_default then goto Emultiple_time_spec;
	if (token.Nvalue = VWnoon)
	then atime.Hd = 12;
	else atime.Hd = 0;
	atime.MH = 0;
	atime.SM = 0;
	atime.US = 0;
	return;


Ahour_and_LEX:	entry;

	if atime.Hd ^= need_default then goto Emultiple_time_spec;
	if this_()
	then do;
	   call LEX (1);
	   atime.Hd = need_this;
	end;
	else atime.Hd = token.Nvalue;
	call LEX (1);
	return;


Ameridian:	entry;

          if atime.Hd > 12 then goto Ehr_gt_12;
	if atime.Hd = 12
	then atime.Hd = 0;
	if (token.Nvalue = VWpm)
	then atime.Hd = atime.Hd + 12;
	return;


Arequest_id: entry;

	if (atime.yc ^= need_default) | (atime.my ^= need_default)
	then goto Emultiple_date_spec;
	if (atime.Hd ^= need_default)
	then goto Emultiple_time_spec;
	atime.yc = CONVERT_TO_4_DIGIT_YEAR (fixed (rqid.yc));
	atime.my = fixed (rqid.my);
	atime.dm = fixed (rqid.dm);
	atime.Hd = fixed (rqid.Hd);
	atime.MH = fixed (rqid.MH);
	atime.SM = fixed (rqid.SM);
	atime.US = fixed (rqid.US);
	fw_sw = "1"b;
	if (atime.za = "") then atime.za = "#";
	return;

dcl 1 rqid	based (token.Pvalue),
      2 (yc, my, dm, Hd, MH, SM) char (2),
      2 fill	char (1),
      2 US	char (6);


Asecond_fraction:	entry;

	atime.US = get_fraction() * 1e6;		/* token value is the <fraction> of the reduction */
						/* which parses  HH:MM:SS.fraction		*/
	return;

Aminute_fraction:	entry;

	if (token_value = ".")
	then atime.SM, atime.US = 0;			/* 	hhmm.				*/
	else do;
	   atime.US = get_fraction() * 6e7;		/* token value is the <fraction> of reduction:	*/
	   atime.SM = divide (atime.US, 1000000, 17, 0);	/* 	hhmm.fraction			*/
	   atime.US = atime.US - (atime.SM * 1000000);
	end;
	return;


Aminute_and_LEX:	entry;

	if this_()
	then do;
	   call LEX (1);
	   atime.MH = need_this;
	end;
	else atime.MH = token.Nvalue;
	call LEX (1);
	return;


Aminute_zero:	entry;

	atime.MH = 0;
	return;


Amonth_and_LEX:	entry;

	if atime.my ^= need_default then goto Emultiple_date_spec;
	if this_()
	then do;
	   call LEX (1);
	   atime.my = need_this;
	end;
	else atime.my = token.Nvalue;
	call LEX (1);
	fw_sw = "1"b;
	return;


Asecond_and_LEX:	entry;

	if this_()
	then do;
	   call LEX (1);
	   atime.SM = need_this;
	end;
	else atime.SM = token.Nvalue;
	call LEX (1);
	atime.US = 0;
	return;


Asecond_zero:	entry;

	atime.SM = 0;
	atime.US = 0;
	return;

Atime:	entry;

	if atime.Hd ^= need_default then goto Emultiple_time_spec;
	atime.Hd = divide(token.Nvalue, 100, 17, 0);
	atime.MH = mod(token.Nvalue, 100);
	return;

Aadverb:	entry;
	if rtime_first
	then do;			/* nothing preceeds the adverb       */
	   details = "Nothing for adverb to apply to.";
	   lcode = error_table_$dt_time_conversion_error;
	   goto set_err_loc;
	end;
	if (rtime.dw.flag ^= UNUSED)	/* day_name cannot be mixed with     */
	then do;			/* ...offsets		       */
	   details = "Cannot mix <day_name> with <offsets>.";
	   lcode = error_table_$dt_time_conversion_error;
	   goto set_err_loc;
	end;
	if (unspec (atime) ^=  unspec (atime_init))	/* all adverbs must preceed any	*/
	then do;					/* ...absolute specs		*/
	   details = "All adverbial offsets must precede absolute data.";
	   lcode = error_table_$dt_time_conversion_error;
	   goto set_err_loc;
	end;
	if (token.Nvalue = VWbefore)
	then do;
	   do i = 1 to 8;
	      rtime_array.val(i) = - rtime_array.val(i);
	   end;
	end;	
	rtime_first = "1"b;
	return;


Anow:	entry;
	if atime.Hd ^= need_default then goto Emultiple_time_spec;
	atime.Hd = ctime.Hd;
	atime.MH = ctime.MH;
	atime.SM = ctime.SM;
	atime.US = ctime.US;
	return;

Atoday:	entry;
	if (atime.dm ^= need_default)
	| (atime.my ^= need_default)
	| (atime.yc ^= need_default) then goto Emultiple_date_spec;
	atime.dm, atime.my, atime.yc = need_today;
	return;

Atomorrow:	entry;
	if (atime.dm ^= need_default)
	| (atime.my ^= need_default)
	| (atime.yc ^= need_default) then goto Emultiple_date_spec;
	atime.dm, atime.my, atime.yc = need_tomorrow;
	return;

Ayesterday:	entry;
	if (atime.dm ^= need_default)
	| (atime.my ^= need_default)
	| (atime.yc ^= need_default) then goto Emultiple_date_spec;
	atime.dm, atime.my, atime.yc = need_yesterday;
	return;


Ayear_and_LEX:	entry;

	if atime.yc ^= need_default then goto Emultiple_date_spec;
	if this_()
	then do;
	   call LEX (1);
	   atime.yc = need_this;
	end;
	else do;
	   atime.yc = token.Nvalue;
	   if (length (token_value) < 3)
	   then do;				/* handle century default */
	        atime.yc = CONVERT_TO_4_DIGIT_YEAR (atime.yc);
	   end;
	end;
	call LEX (1);
	return;


Ayear_default:	entry;

	if atime.yc ^= need_default then goto Emultiple_date_spec;
	atime.yc = need_year;
	return;


Azone:	entry;

	if (atime.za ^= "") & (atime.za ^= "#")
	then goto Emultiple_zone_spec;
	atime.za = token_value;
	atime.zone_index = token.Nvalue;
	return;


Azone_dif:	entry;

	if (atime.za ^= "") & (atime.za ^= "#")
	then goto Emultiple_zone_spec;
	atime.za = SIGN || token_value;
	atime.zone_index = 0;
	return;


Uday_of_week:	entry;

	if u_day_of_week ^= 0 then goto Emultiple_diw_spec;
	u_day_of_week = token.Nvalue;
	return;

apply_sign_and_offset:
	entry;

	if token_value = "+" then offset_sign = 1;	/* apply sign to offset value			*/
	else offset_sign = -1;
	Ptoken = token.Pnext;			/* skip over sign token.			*/
	goto join_offset;


apply_offset:
	entry;

	offset_sign = +1;				/* assume positive sign for offset.		*/
join_offset:
	number = token.Nvalue;			/* get magnitude of offset.			*/
	if (number = 0)
	then return;
	if (number < 0)
	then do;
	   fld59 = get_number();
	   number = 0;
	end;
	else fld59 = 0;
	goto offset_common;

Afraction_sign_and_offset:
	entry;

	if token_value = "+" then offset_sign = 1;	/* apply sign to offset value			*/
	else offset_sign = -1;
	Ptoken = token.Pnext;			/* skip over sign token.			*/
	goto join_fraction;


Afraction_offset:
	entry;

	offset_sign = +1;				/* assume positive sign for offset.		*/
join_fraction:
	if (token.Itoken_in_stmt ^= TTfraction)		/* the <N> part of the form is optional		*/
	then do;
	   number = token.Nvalue;			/* get magnitude of offset.			*/
	   if (number < 0)
	   then do;
	      number = 0;
	      fld59 = get_number();
	   end;
	   else fld59 = 0;
	   Ptoken = token.Pnext;			/* move to fraction.			*/
	end;
	else number, fld59 = 0;
          fld59 = fld59 + get_fraction();
          if (fld59 = 0)
	then do;
	   if (number = 0)
	   then return;				/* forget he even mentioned it		*/
	end;
offset_common:
	Ptoken = token.Pnext;			/* move to offset				*/

	call init_rtime;
	rtime_array.flag (token.Nvalue) = USED;
	rtime_array.val (token.Nvalue)
	   = rtime_array.val (token.Nvalue)
	   + (convert (fld59, number) + fld59) * offset_sign;
	return;

Emultiple_time_spec:
	lcode = error_table_$dt_multiple_time_spec;
	goto set_err_loc;
Emultiple_date_spec:
	lcode = error_table_$dt_multiple_date_spec;
	goto set_err_loc;
Emultiple_zone_spec:
	lcode = error_table_$dt_multiple_zone_spec;
	goto set_err_loc;
Emultiple_diw_spec:
	lcode = error_table_$dt_multiple_diw_spec;
	goto set_err_loc;
Ehr_gt_12:
	lcode = error_table_$dt_hour_gt_twelve;
	goto set_err_loc;
set_err_loc:
	err_pt = token.Pvalue;
	signal condition (semantic_error);

	end Aday_and_LEX;%skip(3);
init_rtime: proc;

      if rtime_first
      then do;
         rtime_first = ""b;
         if (rtime_ct = hbound (rspace, 1))
         then goto Etoo_many_adverbs;
         rtime_ct = rtime_ct + 1;
         rtime_p = addr (rspace (rtime_ct).data);
         rtime_array.version = Vtime_offset_2;
      end;
      rspace.rel_ct (rtime_ct) = rspace.rel_ct (rtime_ct) + 1;

   end init_rtime;%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
get_fraction:
get_number: proc returns (float dec (59));

dcl number	char (token.Lvalue) based (token.Pvalue);

      return (convert (fld59, number));

   end get_number;%skip(3);
token_:	procedure (l, type, value);			/* procedure to fill in the next token of the	*/
						/*    token chain.				*/

dcl l		fixed bin,	/* length of the new token.	       */
    type		fixed bin,	/* type of the new token.	       */
				/*    0 = unknown		       */
				/*    1 = day name		       */
				/*      2=language name (unused)     */
				/*    2 = meridian (# borrowed)      */
				/*    3 = month name	       */
				/*    4 = offset		       */
				/*    5 = word		       */
				/*        1 = before	       */
				/*        2 = or		       */
				/*        3 = after		       */
				/*        4 = on		       */
				/*        5 = noon		       */
				/*        6 = midnight	       */
				/*        7 = now		       */
				/*        8 = yesterday	       */
				/*        9 = today		       */
				/*       10 = tomorrow	       */
				/*    6 = zone		       */
				/*    7 = "this"		       */
				/*    8 = number 		       */
				/*    9 = big number	       */
				/*   10 = fraction		       */
				/*   11 = and_fraction	       */
				/*   12 = other		       */
    value		fixed bin(35);	/* numeric value of the token.       */

	if Ntokens = dim(tokens,1) then goto Etoo_many_tokens;
					   	/* if there aren't enough tokens, then there are	*/
						/*    more tokens in input string than can be	*/
	Ntokens = Ntokens + 1;			/*    legal.				*/
	if Ntokens = 1 then do;			/* special case assignment of the first token.	*/
	     Ptoken = addr(tokens(Ntokens));
	     token.Plast = null;
	     end;
	else do;
	     token.Pnext = addr(tokens(Ntokens));
	     token.Pnext -> token.Plast = Ptoken;
	     Ptoken = token.Pnext;
	     end;
	token.Pnext = null;
	token.Pvalue = Pstr;
	token.Lvalue = l;
/****	The comment on token.Itoken_in_stmt is			       */
/****		"position of token within its statement."	       */
/****	But we have no statements, so we are using it for token type       */
	token.Itoken_in_stmt = type;
	token.Nvalue = value;
	token.Pstmt, token.Psemant = null;
	string (token.S) = ""b;
	Pstr = addcharno (Pstr, l);			/* skip to next token of input string.		*/
	Lstr = Lstr - l;
       end token_;%page;
%include time_value;
%include time_offset;
%include time_info_search;
%include time_names;
%include time_defaults_;
dcl com_err_	entry() options(variable);

%skip;
/**** Implement the cutoff for 2 digit year strings.

      00..29  =  2000..2029
      30..99  =  1930..1999
*/
CONVERT_TO_4_DIGIT_YEAR:
	procedure (p_yy)
	returns (fixed binary);

dcl p_yy  fixed binary parameter;

dcl yyyy  fixed binary;

	if p_yy < 30 then
	     yyyy = 2000;
	else yyyy = 1900;
	yyyy = yyyy + p_yy;

	return (yyyy);

end CONVERT_TO_4_DIGIT_YEAR;




		    cv_fstime_.alm                  11/11/89  1137.0r   11/11/89  0837.7        5634



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
	segdef	cv_fstime_
" convert a file-system form of 36-bit date into fixed bin (71)
" Aug 1984 JAF	new

cv_fstime_:
	ldq	0,dl
	lda  	ap|2,*		"fstime
	lrl  	20
	staq 	ap|4,*
	short_return

	end




		    date_name_.pl1                  11/11/89  1137.0r   11/11/89  0839.3       27792



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


date_name_:	proc (dir, prename, postname, a_name, a_code);

/* A subroutine to create a unique name in a directory "dir" of the form
/*
/*	prename.mm/dd/yy.tttt.postname
/*
/* Created by M A Meer in November 1972				       */
/* Updated by J A Falksen in Mar 1984 to call date_time_$format	       */

dcl  dir char(*),
     prename char(*),
     postname char(*),
     a_name char(32),
     a_code fixed bin (35),
     time fixed bin (71),
     time_line char(24)var,
     (p1, p2) char(20)var,
     name char(32)var,
     (i, j) fixed bin,
     pname char(168),
     ename char(32),
     code fixed bin(35),
     type fixed bin (2),
     btcnt fixed bin (24),
     error_table_$bigarg fixed bin(35) ext,
     error_table_$noentry fixed bin(35) ext;

dcl  date_time_$format entry (char(*), fixed bin(71), char(*), char(*),
	char(*) var, fixed bin, fixed bin(35)),
     expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)),
     hcs_$status_minf entry (char(*), char(*), fixed bin, fixed bin(2), fixed bin(24), fixed bin (35));

dcl (clock, length, rtrim) builtin;
	i, j, code =  0;				/* Initialize variables to 0 */
	p1 = rtrim (prename);
	if (p1 ^= "") then p1 = p1 || ".";
	p2 = ".";
	p2 = p2 || rtrim (postname);
	if (p2 = ".") then p2 = "";
	if length (p1) + length (p2) > 19 then do;	/* Name > 32 characters */
	     code = error_table_$bigarg;		/* Let world know what is wrong */
	     go to err_ret;				/* Now quit */
	end;

	time = clock ();				/* Get the current time */
convert_time:					/* Convert to ascii string */
	call date_time_$format("^my/^dm/^yc.^Hd^MH", time, "", "", time_line, 0, code);

	name = p1;
	name = name || time_line;
	name = name || p2;

	if dir = "" then do;
	     call expand_pathname_ ((name), pname, ename, code);
	     if code ^= 0 then go to err_ret;
	  end;
	  else do;
	     pname = dir;				/* Get a directory name */
	     ename = name;				/* Get the new entry name */
	  end;
	call hcs_$status_minf (pname, ename, 0, type, btcnt, code);  /* See if seg with this name exists */
	if code = error_table_$noentry then do;		/* OK none exists */
	     code = 0;
	     go to ret;
	end;
	if code ^= 0 then go to err_ret;		/*  Trouble  */
						/* Duplicate so try a new name */
	time = time + 60000000;			/* add one minut */
	go to convert_time;				/* and try again */

err_ret:	name = "";

ret:	a_name = name;
	a_code = code;

	return;

	end date_name_;




		    date_time_.pl1                  12/11/99  1838.1r w 12/11/99  1815.0     1391202



/****^  ******************************************************
        *                                                    *
        * Copyright, (C) Honeywell Bull Inc., 1987           *
        *                                                    *
        * Copyright (c) 1986 by Massachusetts Institute of   *
        * Technology and Honeywell Information Systems, Inc. *
        *                                                    *
        * 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   */
%page;
/* ***********************************+************************************* */
/* All error table  declarations, and (begin proc end) lines are marked with */
/* "<##>".   This is to aid in gleaning the information needed for proper    */
/*  return code documentation.				       */
/* ***********************************+************************************* */
/*							       */
/* Name: date_time_                                                          */
/*                                                                           */
/* The  date_time_  system  is  a  utility  which  encodes, decodes,         */
/* adjusts, or formats a Multics standard calendar clock value.  The         */
/* clock  reading  is  assumed  to be  in  microseconds  relative to         */
/* 1901-01-01  0:00 gmt.   The ASCII  times involved  may be  one of         */
/* several languages and in a choice of time zones around the world.         */
/*							       */
/* ***********************************+************************************* */


/* ***********************************+************************************* */
/*							       */
/* Status							       */
/*							       */
/* 0) Created: Jun, 1978 by J Falksen				       */
/*        a) based on old date_time_ and decode_clock_value_	       */
/* 1) Extended: Dec, 1978 by Gary Dixon				       */
/*        Added ability to handle wide range of dates		       */
/* 2) Extended: Apr, 1983 by jaf				       */
/*	updating to ioa_-like $format controls			       */
/* 3) Changed:  Apr, 1984 by jaf				       */
/*	enclosed code for each entrypoint in a BEGIN block. delete all     */
/*	first-level declarations of error codes. This forces each block    */
/*	to declare the codes it needs.  This may make it possible to find  */
/*	out the list of error codes each entry might return.	       */
/* 4) Changed: Nov, 1984 by jaf				       */
/*	change time_offset.dw into time_offset.dw.(flag val)	       */
/*	added $format_max_length				       */
/*							       */
/* ***********************************+************************************* */


/****^  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):
     Fix stringsize error.  Change date_time_$format, $format_max_length and
     $valid_format to report location in error within the original time_format
     string (with keywords unexpanded), rather than within the expanded
     time_format string. (phx19124)
  2) change(86-08-16,GDixon), approve(86-09-04,MCR7532),
     audit(86-09-05,Martinson), install(86-09-16,MR12.0-1159):
     Correct problem which causes time_format "^za, ^dn" to be rejected.
     Problem stems from z a and comma all being interpreted as picture chars.
     Therefore, the "za" sequences needs to be special-cased. (date_time 30)
  3) change(88-05-29,GDixon), approve(88-06-15,MCR7918),
     audit(88-07-28,Lippard), install(88-08-02,MR12.2-1075):
      A) Correct bug in applying year offset from a leap_day
         (02/29/<leap_year>).  (date_time 31, phx21107)
  4) change(99-06-23,Haggett):
     Y2K
                                                   END HISTORY COMMENTS */

%page;
/* ***********************************+************************************* */
/* @@@@@@ ext proc .. date_time_				       */
/*							       */
/* ENTRY:  date_time_                                                        */
/*                                                                           */
/* The date_time_ subroutine converts a  system clock value to ASCII         */
/* representation.   It  will be  in  terms of  the  process default         */
/* language and zone.                                                        */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_ entry (fixed bin (71), char (*));                       */
/*    call date_time_ (clock, str);                                          */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* clock (input)                                                             */
/*    is the clock value to be formatted                                     */
/* str (output)                                                              */
/*    is the resultant character string.                                     */
/*                                                                           */
/* NOTES:                                                                    */
/* The format string which produces the resultant string is:                 */
/*   "^my/^dm/^yc  ^Hd^99v.9MH ^za ^da"                                      */
/* which produces strings like this:                                         */
/*    07/14/83  1435.4 mst Thu                                               */
/* See  Multics Programmers'  Reference Manual for  a description of         */
/* acceptable strings.                                                       */
/*                                                                           */
/* The  ASCII representation  of time, which  date_time_ attempts to         */
/* return in string,  is 24 characters long.  If  string is declared         */
/* by the caller with a length of N and N is less than 24, then only         */
/* the first  N characters are  returned.  If N is  greater than 24,         */
/* then the result is returned padded on the right with spaces.              */
/*                                                                           */
/* If  clock  is  not  a valid  date,  "01/01/01  0000.0 gmt Tue" is         */
/* returned.                                                                 */
/*							       */
/* ***********************************+************************************* */

date_time_: proc (clock_value, str);

/* format: off						       */
dcl (
  clock_value	fixed bin (71),	/* standard clock value          [In]*/
  str		char (*)		/* return string 	            [Out]*/
    )		parm;		/* format: on		       */

      temp_clock = clock_value;
      go to date_time_rtn;		/* go join up with fstime code       */
				/* @@"END" date_time_	       */ %skip (4);
/*   Background:						       */
/*							       */
/* The Julian calendar is used for dates from 1/1/0001 to 10/04/1582.  This  */
/*  calendar has the same year/month/day structure as the Gregorian calendar */
/*  (the calendar we use now), except that every fourth year is a leap year, */
/*  including centential years.				       */
/*							       */
/* In 1582, Pope Gregory XIII reformed the Julian calendar.  The Julian      */
/*  calendar year of 365.25 days was too long.  The correct tropical (solar) */
/*  year is 365.242199 days long. By 1582, the error in the Julian calendar  */
/*  of 11 minutes, 14 seconds per year had caused the calendar date to be    */
/*  ten days earlier than it should have been.  Pope Gregory corrected this  */
/*  discrepancy be decreeing that the day following October 4, 1582 would be */
/*  October 15, 1582.  Thus, the year 1582 had only 355 days.    He then     */
/*  reformed the year calculation to avoid discrepancies in the future by    */
/*  removing 3 intercalary (leap) days every 400 years.  The pope decreed    */
/*  that centential years would not be leap years unless they were 0 mod     */
/*  400.  The reformed calendar is called the Gregorian calendar.	       */

/* The dates from October 5, 1582 to October 14, 1582 do not exist.	       */
/* The year 1582 presents a bit of a mess it terms of day-in-week, date,     */
/* and day-in-year.  This is what it looks like:			       */
/*							       */
/* day-in-week: |Mon... Thu| <no gap> |Fri  ...  Fri| <no gap> |Sat ...      */
/* day-in-year: |001... 277| <no gap> |278  ...  355|10 day gap|001 ...      */
/*        date: |1/1...10/4|10 day gap|10/15...12/31| <no gap> |1/1 ...      */
/*              |<--------------1582--------------->|          |<--1583--    */
/*							       */
/* The Gregorian calendar is used for dates from 10/15/1582 to 12/31/9999.   */
/*  This calendar has a leap year every 4 years, except:  leap year omitted  */
/*  when mod(year,100) = 0 but included when mod(year,400) = 0.	       */
/*							       */
/* The lower limit on dates of Jan 1, 0001 AD was picked:  to avoid	       */
/*  complexities of dates Before Christ;  because there was no stable	       */
/*  calendar system prior to 4 AD anyway. The upper limit on date of	       */
/*  Dec 31, 9999 was chosen to limit year numbers to 4 digits.	       */
/*							       */
/* ***********************************+************************************* */

/* ***********************************+************************************* */
/*							       */
/*    The leap year device is used to adjust the calendar year to match the  */
/*  astronomical year.  Every year divisible by 4 is a leap year except when */
/*  it's divisible by 100 but not 400.  The action of these 3 conditions     */
/*  results in 3 numeric cycles. Here is the derivation of the lengths of    */
/*  each of the cycles:					       */
/*                                                                           */
/*              4 *    365 + 1 =     1461 days in    4-yr cycle              */
/*             25 *   1461 - 1 =    36524 days in  100-yr cycle              */
/*              4 *  36524 + 1 =   146097 days in  400-yr cycle              */
/*							       */
/*    Plus we need to know this:				       */
dcl microseconds_per_day init (86400000000) /* 24*60*60*1e6		       */
		fixed bin (71) int static options (constant);

/*							       */
/* The base values used for the calendar work are the Julian values:	       */
/*	 0001        --> yc = 1	(year in calendar)		       */
/*	 0001-01-01  --> dc = 1	(day in calendar)		       */
/*	 0001-01-01m --> Uc = 0	(microsecond in calendar)	       */
/* The Julian calendar has but a single cycle which works directly on this   */
/*  base.  The number of microseconds of 1582-10-04 23:59:59.999999 +1 must  */
/*  equal  the number of microseconds of 1582-10-15 00:00:00.000000. The 1st */
/*  is the last Julian Usec, the 2nd is the first Gregorian one.  The Julian */
/*  method calculates out 577737 days for 1582-10-04, while the Gregorian    */
/*  method calculates out 577735 days for 1582-10-15. So when Gregorian work */
/*  is done, 2 days are subtracted in order to get to the base point of its  */
/*  3 cycles.						       */
/*							       */
/* Consider these several quantities:				       */

/* [ 1] Days from 0001-01-01 thru  1582-10-04.                               */
/*              #units  days/unit          days           years              */
/*    4-yr cycles: 395 *    1461    ->    577095    ->      1580             */
/*   excess years:   1 *     365    ->       365    ->         1             */
/*   days in year:                           277                             */
/*         TOTALS:  (Julian)              577737            1581             */
/*                        49,916,476,800 seconds.			       */

/* ** 1582-10-04 Julian is the same as 1582-10-14 Gregorian                  */
/* **   i.e. 1 day beyond either is 1582-10-15                               */
/*                                                                           */
/* [ 2] Days from 0001-01-01 thru  1582-10-14.                               */
/*              #units  days/unit          days           years              */
/*  400-yr cycles:   3 *  146097    ->    438291    ->      1200             */
/*  100-yr cycles:   3 *   36524    ->    109572    ->       300             */
/*    4-yr cycles:  20 *    1461    ->     29220    ->        80             */
/*   excess years:   1 *     365    ->       365    ->         1             */
/*   days in year:                           287                             */
/*         TOTALS:  (Gregorian)           577735            1581             */
/*                        49,916,304,000 seconds.			       */

/* [ 3] Days from 0001-01-01 thru  1900-12-31.                               */
/*              #units  days/unit          days           years              */
/*  400-yr cycles:   4 *  146097    ->    584388    ->      1600             */
/*  100-yr cycles:   2 *   36524    ->     73048    ->       200             */
/*    4-yr cycles:  24 *    1461    ->     35064    ->        96             */
/*   excess years:   3 *     365    ->      1095    ->         3             */
/*   days in year:                           365                             */
/*         TOTALS:  (Gregorian)           693960            1899             */
/*                        59,958,144,000 seconds.			       */

/* [ 4] Days from 0001-01-01 thru  9999-12-31.                               */
/*              #units  days/unit          days           years              */
/*  400-yr cycles:  24 *  146097    ->   3506328    ->      9600             */
/*  100-yr cycles:   3 *   36524    ->    109572    ->       300             */
/*    4-yr cycles:  24 *    1461    ->     35064    ->        96             */
/*   excess years:   2 *     365    ->       730    ->         2             */
/*   days in year:                           365                             */
/*         TOTALS:  (Gregorian)          3652059            9998             */
/*                       315,537,897,600 seconds.			       */

/* [ 5] Days from 0001-01-01 thru 1900-12-31.                                */
/*    [ 3]    693960                                                         */
/*  - [ 2]    577735                                                         */
/*  + [ 1]    577737                                                         */
/*            693962      59,958,316,800 seconds.			      **/
/*                                                                           */
/*    Since the Multics clock has zero => 1901-01-01, above is the number of */
/*    microseconds to subtract to give the clock reading of 0001-01-01 as    */
/*    the  Gregorian algorithm goes.				       */

/* [ 6] Days from 0001-01-01 thru 9999-12-31.                                */
/*    [ 4]   3652059                                                         */
/*  - [ 2]    577735                                                         */
/*  + [ 1]    577737                                                         */
/*  =        3652061     315,538,070,400 seconds.			       */
/*                                                                           */
/*    This is the maximum allowable value of the virtual clock in the        */
/*    interval to be covered.                                                */
/* ***********************************+************************************* */
/*	     So we must adjust Multics clock (base 1901-01-01m)	       */
/*                        to the virtual clock (base 0001-01-01m)	       */
/*	         And then partition into calendar ranges.		       */
/* ***********************************+************************************* */
dcl (
    begin_Gregorian init (049916476800e6), /* 1582-10-15 m		       */
    begin_Special   init (059958316800e6), /* 1901-01-01 m		       */
    end_Special     init (066238214400e6), /* 2100-01-01 m		       */
    M_vc_adjust	init (059958316800e6), /* 1901-01-01 m		       */
    max_vc_value	init (315538070400e6) /* 9999-12-31 23:59:59.999999     */
    )		fixed bin (71) int static options(constant); %page;
/* @@@@@@ ext proc .. format					       */
/* ***********************************+************************************* */
/*							       */
/* ENTRY:  date_time_$format                                                 */
/* This entry  does a generalized  formatting of a  Multics standard         */
/* calendar  clock  value.   A   format  string  is  supplied  which         */
/* describes the layout and content of the desired result.  The zone         */
/* and/or  language in  which the result  is to be  displayed may be         */
/* specified.                                                                */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$format entry(char (*), fixed bin (71), char             */
/*       (*), char (*)) returns char (250) var;			       */
/*    result = date_time_$format (format, clock, zone, lang);	       */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* format (input)                                                            */
/*    either a keyword, or an ioa-like control string describing the         */
/*    desired  result in  terms of literal  characters and date/time         */
/*    selectors.                                                             */
/* clock (input)                                                             */
/*    a clock value to be displayed                                          */
/* zone (input)                                                              */
/*    the  short  name of  the zone  in which  output time  value is         */
/*    expressed.  "system_zone"  means use the  system default zone.         */
/*    "" means use the per-process default zone.                             */
/* lang (input)                                                              */
/*    the language  in which month  names, day names  and time zones         */
/*    are  expressed.   "system_lang" means  use the  system default         */
/*    time  language.  ""  means use  per-process default  time lan-         */
/*    guage.                                                                 */
/* result (output)                                                           */
/*    is the string which is the result of the conversion.                   */
/*                                                                           */
/* NOTES:                                                                    */
/* The control string to date_time_$format  is either a keyword or a         */
/* character  string  consisting  of  text  and/or  selectors.   The         */
/* selectors are always identified by a leading circumflex character         */
/* (^).  There are 2 types  of selectors; ^<keyword>, which allows a	       */
/* keyword to be imbedded within a format, and the general form ^XX.	       */
/* XX is a 2 letter code which specifies what information is wanted.	       */
/* An optional PL/I picture specification  may be placed between the	       */
/* ^ and  XX if the  default form is  not adequate.  If  the control	       */
/* string does  not contain any circumflex  characters, it must then	       */
/* be one  of the known  set of keywords.   See Multics Programmers'	       */
/* Reference Manual for a description of acceptable strings.	       */
/*							       */
/* Each selector is introduced by a "^", ended with a 2-letter specifier,    */
/* and may have a picture specification in between.  Because of minute/month */
/* ambiguity, all time selectors are capitals.			       */
/*							       */
/*							       */
/*    The selectors of numeric data are made up of 2 letters taken from      */
/*    this sequence:					       */
/*                            c y m w d H M S U			       */
/*    These are calendar, year, month, week, day, Hour, Minute, Second,      */
/*    and  microsecond.  All  81 combinations are  not, however, valid.      */
/*    The form can generally be read as "unit of unit".  The first unit      */
/*    must always  be smaller than  the second one.  In  trying to keep      */
/*    the  specifiers  reasonably  mneumonic  (in English)  there  is a      */
/*    problem.  Both month and minute begin  with an "m".  To that end,      */
/*    all  date values  are used as  lower case letters  while all time      */
/*    values are in upper case.				       */
/*							       */
/*    It proves difficult to try to handle all the forms needed without      */
/*    any  glitches.  "hd"  is Hour  in Day  and is  thus 24-hour time.      */
/*    This is  not always what  is wanted.  "Hh"  is chosen as  Hour in      */
/*    half-day to get the 12-hour form  of time.  To go along with this      */
/*    there is "mi"  for Meridiem Indicator.  This gives  "A" or "P" to      */
/*    make up AM  or PM.  This does not give  "AM" or "PM" because ANSI      */
/*    standards  specify that  time be given  as "3P",  not "3PM".  The      */
/*    user   who  wants  the M  will  just add it, i.e. "^miM".	       */
/*							       */
/*    This  table shows  the complete  set of  control codes.   The row      */
/*    specifies what  unit is wanted, the  column specifies within what      */
/*    other unit, i.e.  ^Sy is "Seconds of Year".			       */ %skip (3);
/*                                  DATE/TIME SELECTORS		       */
/*           | of   | of   | of   | of   | of   | of   | of   | of   |       */
/*           |calen-|year  |month |week  | day  |hour  |minute|second|       */
/*    _______| dar  |      |      |      |      |      |      |      |       */
/*    micro- +------+------+------+------+------+------+------+------+       */
/*    second | ^Uc  | ^Uy  | ^Um  | ^Uw  | ^Ud  | ^UH  | ^UM  | ^US  |       */
/*           +------+------+------+------+------+------+------+------+       */
/*    second | ^Sc  | ^Sy  | ^Sm  | ^Sw  | ^Sd  | ^SH  | ^SM  |	       */
/*           +------+------+------+------+------+------+------+	       */
/*    minute | ^Mc  | ^My  | ^Mm  | ^Mw  | ^Md  | ^MH  |		       */
/*           +------+------+------+------+------+------+		       */
/*      hour | ^Hc  | ^Hy  | ^Hm  | ^Hw  | ^Hd  |			       */
/*           +------+------+------+------+------+			       */
/*       day | ^dc  | ^dy  | ^dm  | ^dw  |        month    day    zone       */
/*           +------+------+------+------+      +------+------+------+       */
/*     month |      | ^my  |             name   | ^mn  | ^dn  | ^zn  |       */
/*           +------+------+                    +------+------+------+       */
/*      year | ^yc  |                    abbrev | ^ma  | ^da  | ^za  |       */
/*           +------+                           +------+------+------+       */
/*           | ^Hh  | <-hour of half-day      differential    | ^zd  |       */
/*           +------+    (12 hour form)			  +------+       */
/*           | ^mi  | <-meridiem indicator			       */
/*           +------+					       */
/*	   | ^fw  | <-fiscal week (form: yyyyww)		       */
/*           +------+					       */
/*	   | ^fi  | <-fiscal indicator  ^fi^fw => FW318		       */
/*           +------+					       */

/* The optional picture is an enhanced PL/I picture.  In addition to the     */
/*  normal characters, "X", "O" & "Z" are also available.  Due to a conflict */
/*  with selectors (and it isn't very useful in this application) the	       */
/*  letters "dy" will give errors.				       */

/* "X" represents an optional character position in the displayed value.     */
/*     The character position is omitted if there is no corresponding	       */
/*     character in the value being displayed.  They must appear as the      */
/*     rightmost character positions in the picture specification, since     */
/*     this is the position in which nonsignificant spaces can occupy.       */
/*     This causes a selective ltrim operation on the displayed value.       */
/*     A selective trim means not all characters are removed, only up to the */
/*     number specified.					       */

/* "O" represents a truncated digit in the displayed value.  This allows a   */
/*     user to specify OO99 to get the year in century or OOO9 to get the    */
/*     year in decade. "O"s may appear anywhere in a picture specification.  */
/*     They are processed as "9" characters and the corresponding characters */
/*     in the result are dropped.				       */

/* "Z" represents a decimal digit in the displayed value.  Nonsignificant    */
/*     zeros to the left of the decimal point are omitted from the displayed */
/*     value when they occupy a "Z" digit position. Nonsignificant zeros to  */
/*     the right of the decimal point are omitted from the displayed value   */
/*     when they occupy a "Z" digit position. "Z" characters must appear as  */
/*     the leftmost or rightmost digit positions in a picture specification, */
/*     since these are the positions which nonsignificant zeros can occupy.  */
/*     This causes a selective ltrim or rtrim (of zero) operation on the     */
/*     displayed value.					       */ %skip (4);
/* This is a comparison of the characters which make up pictures with the    */
/*  characters which make up selectors:				       */
/*     "alphabet"	list of characters for reference		       */
/*     "enhanced"	enhanced picture characters			       */
/*     "selector1"	selector characters which appear 1st in pair	       */
/*     "selector2"	selector characters which appear 2nd in pair	       */
/*     "excluded"	regular picture characters excluded thru conflict	       */
/*							       */
/* alphabet    ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz	       */
/* selector1   .......H....M.....S.U..... ...d.f......m...........yz	       */
/* selector2   .......H....M.....S....... a.cd...hi...mn........w.y	       */
/* enhanced    ..............O........X.Z abcdef....k.......s..v.xyz9.,-+/   */
/* excluded    ..............................d....................y.......   */
/* **** Special casing allows f and z to be picture characters even though   */
/*  they are selector1 characters.				       */
/* ***********************************+************************************* */ %skip (2);
format: entry (format, clock_value, zone, language) returns (char (250)var);

/* format: off						       */
dcl (
  format		char (*),		/* ctl str specifying output     [In]*/
/*clock_value	fixed bin (71)	/* standard clock value 	   [In]*/
  zone		char (*),		/* specify output in this zone   [In]*/
  language	char (*)		/* specify output in this lang   [In]*/
    )		parm;		/* format: on		       */

        temp_clock = clock_value;
        
format_rtn: begin;			/* <<##>> */
dcl (
    error_table_$dt_unknown_time_language, /* <##> */
    error_table_$unknown_zone		/* <##> */
    )		fixed bin (35) ext static;
dcl sub_err_	entry() options(variable);

      testing_format, format_max = "0"b;
      errloc, errlocad.n, lcode = 0;	/* assume no errors.	       */
      lformat = format;		/* copy in his format string	       */
      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;
      lang_index = get_word_index ((language), Language_table);
      if lang_index < 1
      then do;
         lcode = binary (error_table_$dt_unknown_time_language);
signal_sub_err_:
         call sub_err_ (lcode, "date_time_$format", ACTION_CANT_RESTART,
	  null (), 0, "^[
Format is: ""^a""^[ (^a)
 error at: ^vx^^^vx^^^;^3s
 error at: ^vx^^^]^]",
	  (errloc > 0), format,
	   (format ^= lformat), lformat, errloc, 
	   length(format) - errloc + length(" (") + 
	     errlocad.unadjusted_errloc,
	   errloc);
      end;
      zone_index = get_word_index ((zone), Zone_table);
      if zone_index < 1
      then do;
         if (verify (zone, "-+0123456789") ^= 0)
         then do;
	  lcode = binary (error_table_$unknown_zone);
	  goto signal_sub_err_;
         end;
         zone_index = 0;
      end;
      call Multics_2_vc (temp_clock, (zone), zone_index, lang_index, cal_val);
      if (lcode ^= 0)
      then goto signal_sub_err_;
      call do_format;
      if (lcode ^= 0)
      then goto signal_sub_err_;
%include sub_err_flags;
      end format_rtn;		/* <##> */
      return (lresult);
exit:				/* let anybody use this to get out   */
      return;
lcode_err_exit:
      code = lcode;
      return;			/* @@END format		       */%skip(2);
/* @@@@@@ ext proc .. format_max_length				       */
/*                                                                           */
/* ENTRY:  date_time_$format_max_length                                      */
/*                                                                           */
/* This entry returns the length of the biggest strings which can	       */
/* result from the given format string.				       */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$format_max_length entry (char (*), char (*), char (*))  */
/*       returns (fixed bin);                                                */
/*    maxl = date_time_$format_max_length (format, zone, lang);	       */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* format (input)                                                            */
/*    either a keyword, or an ioa-like control string describing the         */
/*    desired  result in  terms of literal  characters and date/time         */
/*    selectors.                                                             */
/* zone (input)                                                              */
/*    the  short  name of  the zone  in which  output time  value is         */
/*    expressed.  "system_zone"  means use the  system default zone.         */
/*    "" means use the per-process default zone.                             */
/* lang (input)                                                              */
/*    the language  in which month  names, day names  and time zones         */
/*    are  expressed.   "system_lang" means  use the  system default         */
/*    time  language.  ""  means use  per-process default  time lan-         */
/*    guage.                                                                 */
/* maxl (output)						       */
/*    is the length of the longest string which could result	       */
/*                                                                           */
/* NOTES:                                                                    */
/* Errors are reported in the same manner as date_time_$format.	       */

format_max_length: entry (format, zone, language) returns (fixed bin);

dcl format_max	bit (1);

fmt_max: begin;			/* <<##>> */
dcl (
    error_table_$dt_unknown_time_language, /* <##> */
    error_table_$unknown_zone		/* <##> */
    )		fixed bin (35) ext static;

      format_max = "1"b;
      testing_format = ""b;
      errloc, errlocad.n, lcode = 0;	/* assume no errors.	       */
      lformat = format;
      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;
      lang_index = get_word_index ((language), Language_table);
      if lang_index < 1
      then do;
         lcode = binary (error_table_$dt_unknown_time_language);
         goto sub_err_return_0;
      end;
      zone_index = get_word_index ((zone), Zone_table);
      if zone_index < 1
      then do;
         lcode = binary (error_table_$unknown_zone);
         goto sub_err_return_0;
      end;
      Ptime_value = addr (decoded_clock); /* point to a structure	       */
      time_value.yc = 9999;		/* plug in a funny set of values     */
      time_value.my = 12;		/* The exact values are arbitrary,   */
      time_value.dm = 28;		/* ...but they all have no leading   */
      time_value.Hd = 12;		/* ...or trailing "0"s	       */
      time_value.MH = 34;
      time_value.SM = 56;
      time_value.US = 987654;
      time_value.fw = 198432;
      time_value.dy = 365;
      time_value.dc = 3652061;
      time_value.Uc = 315538070399999999;
      time_value.za = zone;
      time_value.zone_index = zone_index;
      time_value.leap_year = 0;

      call do_format$direct;
      if (lcode ^= 0)
      then goto sub_err_return_0;
      end fmt_max;
      return (length (lresult));%skip(5);
sub_err_return_0: begin;
         call sub_err_ (lcode, "date_time_$format_max_length", ACTION_CANT_RESTART,
	  null (), 0, "^[
Format is: ""^a""^[ (^a)
 error at: ^vx^^^vx^^^;^3s
 error at: ^vx^^^]^]",
	  (errloc > 0), format,
	   (format ^= lformat), lformat, errloc, 
	   length(format) - errloc + length(" (") + 
	     errlocad.unadjusted_errloc,
	   errloc);
dcl sub_err_	entry() options(variable);
%include sub_err_flags;
         end sub_err_return_0;
         return (0);%page;
/* @@@@@@ ext proc .. valid_format				       */
/*                                                                           */
/* ENTRY:  date_time_$valid_format                                           */
/*                                                                           */
/* This entry checks the validity of a format string using precisely         */
/* the same tests as date_time_$format.                                      */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$valid_format entry (char (*), fixed bin, fixed          */
/*       bin (35));                                                          */
/*    call date_time_$valid_format (format, errloc, code);                   */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* format (input)                                                            */
/*    either a keyword, or an ioa-like control string describing the         */
/*    desired  result in  terms of literal  characters and date/time         */
/*    selectors.                                                             */
/* errloc (output)                                                           */
/*    is the  character index in  the format string  where the error         */
/*    occured.   This is  meaningful only  if it  and code  are both         */
/*    non-zero.                                                              */
/* code (output)                                                             */
/*    is a standard  status code.  It can have  one of the following         */
/*    values--                                                               */
/*    error_table_$dt_bad_format_selector                                    */
/*    error_table_$bad_conversion				       */
/*    error_table_$dt_no_format_selector                                     */
/*    error_table_$picture_bad                                               */
/*    error_table_$picture_scale                                             */
/*    error_table_$picture_too_big                                           */
/*    error_table_$size_error                                                */
/*    error_table_$unimplemented_version                                     */

valid_format: entry (format, Aerrloc, code);
dcl (
  Aerrloc		fixed bin,	/* char index at error time     [Out]*/
  code		fixed bin (35)	/* return code		  [Out]*/
    )		parm;
dcl testing_format	bit (1);
valid_format_rtn: begin;		/* <<##>> */
      Aerrloc, errloc, errlocad.n = 0;
      testing_format = "1"b;
      format_max = ""b;
      code, lcode = 0;		/* assume no errors.	       */
/**** At this point in date_time_$format you will note that there is a check */
/**** to see if defaults need to be initialized.  Here it must NOT be done.  */
/**** This routine is designed to be able to run without the existence of    */
/**** time_info_.  Default initialization references time_info_.	       */
      lformat = format;		/* copy in his format string	       */
      lang_index = 1;
/**** Use a clock reading which tests all fields for their maximum width.    */
      call Multics_2_vc (
/****^   3124103399999999,		/* 1999-12-31 23:59:59.999999+0930   */
         4503599627370495,		/* 2043-09-17 23:53:47.370495 gmt    */
         "+0930", 0, lang_index, cal_val);
      if (lcode = 0)
      then call do_format;
      code = lcode;
      Aerrloc = errloc;
      return;			/* @@END valid_format	       */
      end valid_format_rtn;		/* <##> */ %page;
/* @@@@@@ ext proc .. from_clock				       */
/* ***********************************+************************************* */
/*							       */
/* ENTRY:  date_time_$from_clock                                             */
/*                                                                           */
/* Given a Multics standard calendar  clock value and an output time         */
/* zone name, return the month, day of the month, the year, the hour         */
/* of the day, the minute of the hour, the second of the minute, the         */
/* number of microseconds, the day in week, the day in year, and the         */
/* day in  clock.  The caller may  specify one of the  time zones in         */
/* the  time_info_  in  which  the  decoded  clock  value  is  to be         */
/* expressed, or may  request that the value be  expressed in one of         */
/* the default time zones.                                                   */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$from_clock entry (fixed bin (71), char (*),             */
/*       ptr, fixed bin (35));                                               */
/*    call date_time_$from_clock (clock, zone, addr(time_value),             */
/*       code);                                                              */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* clock (input)                                                             */
/*    is the clock value to be decoded.                                      */
/* zone (input)                                                              */
/*    the  short  name of  the zone  in which  output time  value is         */
/*    expressed.  "system_zone"  means use the  system default zone.         */
/*    "" means use the per-process default zone.                             */
/* time_value (output)                                                       */
/*    is  the  structure containing  time  parts.  The  structure is         */
/*    defined in time_value.incl.pl1.                                        */
/* code (output)                                                             */
/*    is a standard  status code.  It can have  one of the following         */
/*    values--                                                               */
/*    error_table_$dt_date_too_big                                           */
/*    error_table_$dt_date_too_small                                         */
/*    error_table_$dt_year_too_big                                           */
/*    error_table_$dt_year_too_small                                         */
/*    error_table_$unimplemented_version                                     */
/*    error_table_$unknown_zone                                              */
/*							       */
/* ***********************************+************************************* */ %skip (2);
from_clock: entry (clock_value, zone, APtime_value, code);

/* format: off						       */
dcl (
/*clock_value	fixed bin (71)	/* standard clock value 	   [In]*/
/*zone		char (*)		/* specify output in this zone   [In]*/
  APtime_value	ptr		/* ->output structure	   [In]*/
/*code		fixed bin (35);	/* standard return code	  [Out]*/
    )		parm;		/* format: on		       */

from_clock_rtn: begin;		/* <<##>> */
dcl (
    error_table_$unimplemented_version, /* <##> */
    error_table_$unknown_zone		/* <##> */
    )		fixed bin (35) ext static;

      Ptime_value = APtime_value;	/* Use callers output structure.     */
      if (time_value.version ^= Vtime_value_3) & (time_value.version ^= "3")
      then do;
         code = binary (error_table_$unimplemented_version);
         return;
      end;
      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;
      lang_index = time_defaults_$language_index;
      zone_index = get_word_index ((zone), Zone_table);
      if zone_index < 1		/* zone given is not in table.       */
      then do;
/**** But wait! first check to see if it might be a zone differential	       */
         if (verify (zone, "-+0123456789") ^= 0)
         then do;
	  code = binary (error_table_$unknown_zone);
	  return;
         end;
         zone_index = 0;
      end; %skip (4);
      call Multics_2_vc (clock_value, (zone), zone_index, lang_index, cal_val);
      if (lcode = 0)
      then call fromclock;
      code = lcode;
      return;			/* @@END from_clock		       */
      end from_clock_rtn;		/* <##> */ %page;
/* @@@@@@ ext proc .. from_clock_interval			       */
/* ***********************************+************************************* */
/*							       */
/* ENTRY:  date_time_$from_clock_interval                                    */
/*                                                                           */
/* Given 2 clock values, return  the number of years, months, weeks,         */
/* days,  hours,  minutes, seconds,  and microseconds  between them.         */
/* The set of units to use is  specified, as well as whether any are         */
/* to include the fractional remainder.                                      */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$from_clock_interval entry (fixed bin (71),              */
/*       fixed bin (71), ptr, fixed bin (35));                               */
/*    call date_time_$from_clock_interval (clock1, clock2, addr              */
/*       (time_offsets), code);                                              */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* clock1 (input)                                                            */
/*    is the base  time value.  The output is  expressed relative to         */
/*    this value.                                                            */
/* clock2 (input)                                                            */
/*    is  the offset  time value.   clock1 is  in essence subtracted         */
/*    from this value.  If this value  is later, all results will be         */
/*    positive.   If  this value  is  earlier, all  results  will be         */
/*    negative.                                                              */
/* time_offsets (output)                                                     */
/*    is the structure containing  resulting time values.		       */
/* code (output)                                                             */
/*    is a standard  status code.  It can have  one of the following         */
/*    values--                                                               */
/*    error_table_$dt_bad_day_of_week                                        */
/*    error_table_$dt_bad_dm                                                 */
/*    error_table_$dt_bad_dy                                                 */
/*    error_table_$dt_bad_my                                                 */
/*    error_table_$dt_date_not_exist                                         */
/*    error_table_$dt_date_too_big                                           */
/*    error_table_$dt_date_too_small                                         */
/*    error_table_$dt_no_interval_units                                      */
/*    error_table_$dt_offset_too_big_negative                                */
/*    error_table_$dt_offset_too_big_positive                                */
/*    error_table_$dt_year_too_big                                           */
/*    error_table_$dt_year_too_small                                         */
/*    error_table_$unimplemented_version                                     */
/*							       */
/* ***********************************+************************************* */ %skip (2);
from_clock_interval: entry (Aref_clock, Aoff_clock, APtime_offset, code);

/* format: off						       */
dcl (
  Aref_clock	fixed bin (71),	/* reference time		   [In]*/
  Aoff_clock	fixed bin (71),	/* offset time		   [In]*/
  APtime_offset	ptr		/* ->output structure	   [In]*/
/*code		fixed bin (35)	/* return code		  [Out]*/
    )		parm;		/* format: on		       */

from_clock_interval_rtn: begin;	/* <<##>> */

dcl (
    error_table_$dt_no_interval_units	/* <##> */
    )		fixed bin (35) ext static;

      code, lcode = 0;
      lang_index = 1;		/* force to a valid value	       */
      Ptime_offset = APtime_offset;
      if (unspec (time_offset.flag) = ""b)
      then do;
         code = binary (error_table_$dt_no_interval_units);
         return;			/* gotta select SOME units	       */
      end;
      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;

      time_offset.val.yr, time_offset.val.mo,
         time_offset.val.wk, time_offset.val.da,
         time_offset.val.hr, time_offset.val.min,
         time_offset.val.sec, time_offset.val.Usec = 0;
      t_interval = Aoff_clock - Aref_clock;
      if (t_interval = 0)
      then return;			/* no change		       */

/* ***********************************+************************************* */
/* The difference between the two values is dissected from the largest to    */
/*  the smallest.  The difference between the values is simple for Usec,     */
/*  sec, min, hr, da, and wk. They are always fixed in size.  But yr and mo  */
/*  are not so easy.  For these two, the reference value must be taken into  */
/*  account in order to know how big they are.			       */
/* ***********************************+************************************* */

      if (time_offset.flag.yr > 0)	/* Neither of these cases is nice    */
         | (time_offset.flag.mo > 0)
      then do;
         Ptime_value = addr (decoded_ref);
         call Multics_2_vc (Aref_clock, "gmt", time_info_$gmt_zone_index, 1, ref_val);
         cal_val = ref_val;
         if (lcode = 0)
         then call fromclock$no_FW;	/* decode the reference value	       */
         if (lcode ^= 0)
         then do;
	  code = lcode;
	  return;
         end;
         Ptime_value = addr (decoded_clock);
         call Multics_2_vc (Aoff_clock, "gmt", time_info_$gmt_zone_index, 1, off_val);
         cal_val = off_val;
         if (lcode = 0)
         then call fromclock$no_FW;	/* decode the offset value	       */
         if (lcode ^= 0)
         then do;
	  code = lcode;
	  return;
         end;
         Tyear = decoded_clock.yc - decoded_ref.yc;
         Tmonth = decoded_clock.my - decoded_ref.my;
         Tday = decoded_clock.dm - decoded_ref.dm;
         Tusec =
	  (off_val.x + off_val.dx - (decoded_clock.dc * 864) * 100000000)
	  - (ref_val.x + ref_val.dx - (decoded_ref.dc * 864) * 100000000);

         if (t_interval > 0)		/* (+) interval		       */
         then do;
	  if (Tusec < 0)		/* a day borrow is needed	       */
	  then Tday = Tday - 1;	/* ..so take one		       */
	  if (Tday < 0)		/* a month borrow is needed	       */
	  then Tmonth = Tmonth - 1;	/* ..so take one (days not worked on */
				/*  here, only checked in order to   */
				/*  adjust the month.)	       */
	  if (Tmonth < 0)		/* a year borrow is needed	       */
	  then do;		/* ..so take one		       */
	     Tyear = Tyear - 1;
	     Tmonth = Tmonth + 12;
	  end;
         end;
         else do;			/* (-) interval		       */
	  if (Tusec > 0)		/* need to borrow a day?	       */
	  then Tday = Tday + 1;
	  if (Tday > 0)		/* need to borrow a month?	       */
	  then Tmonth = Tmonth + 1;
	  if (Tmonth > 0)		/* need to borrow a year?	       */
	  then do;
	     Tyear = Tyear + 1;
	     Tmonth = Tmonth - 12;
	  end;
         end;
         unspec (auto_time_offset) = ""b;
         auto_time_offset.version = Vtime_offset_2;
         if (time_offset.flag.yr > 0)
         then do;
	  time_offset.val.yr = Tyear;
	  if (Tyear ^= 0)		/* don't waste my time if there is   */
	  then do;		/* ..no integer portion	       */
	     auto_time_offset.val.yr = Tyear;
	     auto_time_offset.flag.yr = 1;
	     cal_val = ref_val;
	     call apply_offset;
	     ref_val = cal_val;
	     if (lcode ^= 0)
	     then goto lcode_err_exit;
	     Ptime_value = addr (decoded_ref);
	     call fromclock$no_FW;	/* decompose the new value	       */
	     t_interval = off_val.x + off_val.dx - (ref_val.x + ref_val.dx);
				/*  figure interval left	       */
	  end;
/**** We have now set the year value, and removed that much from reference.  */
	  if (time_offset.flag.yr = 2)
	  then do;		/* they want the fraction, too       */
	     if (decoded_ref.yc = 1582)
	     then unit_size = 355;	/* figure out how big the year is    */
	     else unit_size = 365 + decoded_ref.leap_year;
	     time_offset.val.yr = time_offset.val.yr
	        + make_fraction (t_interval, unit_size * microseconds_per_day);
	  end;
         end;
         else Tmonth = Tmonth + 12 * Tyear;

         if (time_offset.flag.mo > 0)
         then do;
	  time_offset.val.mo = Tmonth;
	  if (Tmonth ^= 0)
	  then do;
	     auto_time_offset.flag.yr = 0;
	     auto_time_offset.flag.mo = 1;
	     auto_time_offset.val.mo = Tmonth;
	     cal_val = ref_val;
	     call apply_offset;
	     ref_val = cal_val;
	     if (lcode ^= 0)
	     then goto lcode_err_exit;
	     Ptime_value = addr (decoded_ref);
	     call fromclock$no_FW;	/* decompose the new value	       */
	     t_interval = off_val.x + off_val.dx - (ref_val.x + ref_val.dx);
				/*  figure interval left	       */
	  end;
/**** We have now set the month value, and removed that much from reference. */
	  if (time_offset.flag.mo = FRACTION)
	  then do;
	     unit_size = days_in_month (decoded_ref.my);
	     if (decoded_ref.my = FEBRUARY)
	     then unit_size = unit_size + decoded_ref.leap_year;
	     time_offset.val.mo = time_offset.val.mo
	        + make_fraction (t_interval, unit_size * microseconds_per_day);
	  end;
         end;
      end;
      do cur_unit = 3 to 8;
         if (time_offset_array.flag (cur_unit) > 0)
         then do;
	  unit_size = unit_sizes (cur_unit);
	  fb24 = divide (t_interval, unit_size, 24, 0);
	  t_interval = t_interval - fb24 * unit_size;
	  time_offset_array.val (cur_unit) = fb24;
	  if (time_offset_array.flag (cur_unit) = FRACTION)
	  then do;
	     time_offset_array.val (cur_unit)
	        = time_offset_array.val (cur_unit)
	        + make_fraction (t_interval, unit_size);
	  end;
         end;
      end;
      return;			/* @@END from_clock_interval	       */
      end from_clock_interval_rtn;	/* <##> */ %page;
/* @@@@@@ ext proc .. fstime					       */
/* ***********************************+************************************* */
/*							       */
/* ENTRY:  date_time_$fstime                                                 */
/*                                                                           */
/* This entry  performs the same  function as date_time_$date_time_,         */
/* given a 36-bit storage system date value.                                 */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$fstime entry (bit (36) aligned, char (*));              */
/*    call date_time_$fstime (ssclock, str);                                 */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* ssclock (input)                                                           */
/*    is an internal storage system clock value.                             */
/* str (output)                                                              */
/*    is the resultant character string                                      */
/*							       */
/* ***********************************+************************************* */ %skip (2);
fstime: entry (stime, str);

/* format: off						       */
dcl (
  stime		bit (36) aligned	/* "short" time value 	   [In]*/
/*str		char (*);		/* return string 	            [Out]*/
    )		parm;		/* format: on		       */

      temp_clock = 0;
      addr (temp_clock) -> fs_time_value.time = stime;

date_time_rtn: begin;		/* <<##>> */
      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;
      lang_index = time_defaults_$language_index;
      string (standard) = "00/00/00  0000.0 gmt Tue";
      Ptime_value = addr (decoded_clock);
      time_value.version = Vtime_value_3;
      call Multics_2_vc (temp_clock, (time_defaults_$zone_short), time_defaults_$zone_index,
         lang_index, cal_val);
      if (lcode = 0)
      then call fromclock$no_FW;
      if (lcode = 0)
      then do;
         standard.yy = mod (time_value.yc, 100);
         standard.mm = time_value.my;
         standard.dd = time_value.dm;
         standard.HH = time_value.Hd;
/**** MM is pic "99.9". This statement calculates 10ths of minutes to go     */
/****  into this picture, while being efficient.			       */
         standard.MM = divide (time_value.MH * 60 + time_value.SM, 6, 17);
         standard.zz = substr(time_value.za,1,length(standard.zz));
         standard.da = ti_day.short (lang_index, time_value.dw);
      end;
      str = string (standard);
      return;

dcl 1 standard,
      2 mm	pic "99",
      2 xx1	char (1),		/* "/"			       */
      2 dd	pic "99",
      2 xx2	char (1),		/* "/"			       */
      2 yy	pic "99",
      2 HH	pic "bb99",
      2 MM	pic "99.9b",
      2 zz	char (4),
      2 da	char (3);		/* @@END fstime		       */
      end date_time_rtn;		/* <##> */ %skip (3);
/* @@@@@@ ext func .. get_time_info_index			       */
/* ***********************************+************************************* */
/*							       */
/* Entry: date_time_$get_time_info_index			       */
/*							       */
/* Given a word and a table specifier, return the index that word has        */
/*  in that table.  language and zone defaulting is handled here.	       */
/*							       */
/* Usage							       */
/*	dcl date_time_$get_time_info_index (char (*), bit (6))	       */
/*		returns (fixed bin);			       */
/*							       */
/*	an_index = date_time_$get_time_info_index (word, table);	       */
/*							       */
/* 1) word	is the word to look for.  It will be converted to a      */
/*		token by converting to lower-case. (In)		       */
/* 2) table	is the identifier of the table wanted. (In)	       */
/* 3) an_index	is the index in the specified table of the word.	       */
/*	-1	the word was not found at all.		       */
/*	0	the word was found, but was not in the wanted table.     */
/*							       */
/* *This is used by dti to look up offset and language.		       */
/* *This is used by tdft to look up a zone.			       */
/*							       */
/* convert_date_to_binary_ has its own version of this, both for speed and   */
/*  because its requirements are slightly different.  When it looks up a     */
/*  token, it has no idea what use is intended for it.  That happens later   */
/*  when the parsing is done.					       */
/*							       */
/* ***********************************+************************************* */ %skip (2);
get_time_info_index: entry (Atoken, Atable) returns (fixed bin);

dcl Atoken	char (*),		/* word to look for		       */
    Atable	fixed bin;	/* kind off thing it must be	       */

      return (get_word_index ((Atoken), Atable)); /* @@END get_time_info_index */ %page;
/* @@@@@@ ext proc .. hundredths				       */
/* ***********************************+************************************* */
/*							       */
/* Entry: date_time_$hundredths				       */
/*							       */
/* Given a Multics standard calendar  clock  value,  this  entry  point      */
/*  returns  a formatted  date  in  the form			       */
/*	"^my/^dm/^yc  ^Hd^99v.99MH ^za ^da"			       */
/* For the meaning of this string, see date_time_$format information below.  */
/*							       */
/* Usage							       */
/*							       */
/*        dcl date_time_$hundredths entry(fixed bin(71),char(*));	       */
/*							       */
/*        call date_time_$hundredths (clock,str);			       */
/*							       */
/* 1) clock         is the clock value to be formatted (In)		       */
/* 2) str           is the resultant character string (Out)		       */
/*							       */
/* ***********************************+************************************* */ %skip (2);
hundredths: entry (clock_value, str);

/* format: off						       */
/*clock_value	fixed bin (71)	/* standard clock value 	   [In]*/
/*str		char (*)		/* return string		  [Out]*/
				/* format: on		       */
hundredths_rtn: begin;		/* <<##>> */
      testing_format, format_max = "0"b;
      temp_clock = clock_value;
      lformat = "^my/^dm/^yc  ^Hd^99v.99MH ^xxxxza^xxxda";

      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;
      lang_index = time_defaults_$language_index;
      call Multics_2_vc (temp_clock, (time_defaults_$zone_short), time_defaults_$zone_index,
         lang_index, cal_val);
      if (lcode = 0)
      then call do_format;
      str = lresult;
      return;			/* @@END hundredths		       */
      end hundredths_rtn;		/* <##> */
 %skip (3);
/* @@@@@@ ext proc .. offset_to_clock				       */
/* ***********************************+************************************* */
/*							       */
/* ENTRY:  date_time_$offset_to_clock                                        */
/*                                                                           */
/* This entry point  creates a new Multics clock  value by adjusting         */
/* an input clock  value to a specified day-of-week  and then adding         */
/* relative  date/time  offsets.    The  relative  date/time  values         */
/* include  a year  offset, month  offset, week  offset, day offset,         */
/* hour  offset,  minute  offset,  second  offset,  and  microsecond         */
/* offset.  Any  of these values  may be zero (no  offset from input         */
/* clock  value)  or  negative  (backwards offset  from  input clock         */
/* value).  In addition, an input time zone is specified.                    */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$offset_to_clock entry (ptr, fixed bin (71),             */
/*       char (*), fixed bin (71), fixed bin (35));                          */
/*    call date_time_$offset_to_clock (addr(time_offsets), clock_in,         */
/*       zone, clock, code);                                                 */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* time_offset (input)                                                       */
/*    is  the  structure  containing  time  offsets  to  be  aplied.         */
/*    Structure is defined in time_offsets.incl.pl1                          */
/* clock_in (input)                                                          */
/*    is the clock value to which offsets are applied                        */
/* zone (input)                                                              */
/*    is the zone in which clock_in is to be interpreted                     */
/* clock (output)                                                            */
/*    is the resulting clock value                                           */
/* code (output)                                                             */
/*    is a standard  status code.  It can have  one of the following         */
/*    values--                                                               */
/*    error_table_$dt_bad_day_of_week                                        */
/*    error_table_$dt_bad_dm                                                 */
/*    error_table_$dt_bad_dy                                                 */
/*    error_table_$dt_bad_my                                                 */
/*    error_table_$dt_date_not_exist                                         */
/*    error_table_$dt_date_too_big                                           */
/*    error_table_$dt_date_too_small                                         */
/*    error_table_$dt_offset_too_big_negative                                */
/*    error_table_$dt_offset_too_big_positive                                */
/*    error_table_$dt_year_too_big                                           */
/*    error_table_$dt_year_too_small                                         */
/*    error_table_$unimplemented_version                                     */
/*                                                                           */
/* NOTES:                                                                    */
/*                                                                           */
/* The order of applying  these  offsets  can affect  the  resultant	       */
/* clock  value.   In all cases,  the  order required  by  convert_-	       */
/* date_to_binary_  has been used.  The order is as follows:	       */
/*                                                                           */
/*   1) decode the input clock  value into absolute date/time values         */
/*      specified in  terms of the  input time zone.   This zone may         */
/*      affect the day-of-week represented by the input clock value,         */
/*      and hence, may affect any day-of-week offset adjustment.             */
/*   2) apply  any  day-of-week  offset  by  adding/subtracting days         */
/*      to/from the absolute date  until the day-of-week represented         */
/*      by the decoded clock value equals the specified day-of-week.         */
/*   3) apply  any  year  offset  to the  decoded  clock  value.  If         */
/*      applying  the year  offset results  in a  non-existant date,         */
/*      then use the previous  existing day, e.g.  "1583-10-10 -1yr"         */
/*      would yield 1582-10-04.                                              */
/*   4) apply  any  month offset  to  the decoded  clock  value.  If         */
/*      applying  the month  offset results in  a non-existent date,         */
/*      then use the  last day of the month  (taking leap years into         */
/*      account),  e.g.   "Jan 31  3 months"  would yield  April 31.         */
/*      instead.                                                             */
/*   5) apply  the day  offset, hour  offset, minute  offset, second         */
/*      offset, and microsecond offset.                                      */
/*   6) encode the  resultant absolute date/time  specification into         */
/*      the output clock value.                                              */
/*							       */
/* ***********************************+************************************* */ %skip (2);
offset_to_clock: entry (APtime_offset, clock_in_value, zone, clock_value, code);

/* format: off						       */
dcl (
/*APtime_offset	ptr		/* ->input structure	   [In]*/
  clock_in_value	fixed bin (71)	/* clock value 		   [In]*/
/*zone		char (*)		/* for clock_in_value	   [In]*/
/*clock_value	fixed bin (71)	/* adjusted clock value 	  [Out]*/
/*code		fixed bin (35)	/* standard return code	  [Out]*/
    )		parm;		/* format: on		       */

/* ***********************************+************************************* */
/*  Adjust a given clock value by applying a given set of offsets	       */
/*							       */
/* 	Begin by decoding input clock value into month, day, year, etc.    */
/*  Then add offset input arguments to these decoded values.  Finally,       */
/*  encode the sums.					       */
/*							       */
/* ***********************************+************************************* */

offset_to_clock_rtn: begin;		/* <<##>> */
dcl (
    error_table_$unimplemented_version	/* <##> */
    )		fixed bin (35) ext static;

      code, lcode = 0;
      Ptime_offset = APtime_offset;
      if time_offset.version ^= Vtime_offset_2
      then do;
         code = binary (error_table_$unimplemented_version);
         return;
      end;
      auto_time_offset = time_offset;	/* we want to modify structure       */
      call Multics_2_vc (clock_in_value, (zone),
         get_word_index ((zone), Zone_table), 1, cal_val);
      if (lcode = 0)
      then call apply_offset;
      if (lcode = 0)
      then call vc_2_Multics (cal_val, clock_value);
      code = lcode;
      return;			/* @@END offset_to_clock	       */
      end offset_to_clock_rtn;	/* <##> */ %page;
/* @@@@@@ ext func .. decimal_date_time_			       */
/* ***********************************+************************************* */
/* ***********************************+************************************* */
decimal_date_time_: entry (clock_value, str);
      ddt_sw = "1"b;
      goto request_id_rtn;

dcl ddt_sw	bit (1); %skip (5);
/* @@@@@@ ext func .. request_id_				       */
/* ***********************************+************************************* */
/*                                                                           */
/* ENTRY:  date_time_$request_id_                                            */
/*                                                                           */
/* Given a Multics standard clock  value, this entry point returns a         */
/* char(19)   formatted  date   (expressed  in  GMT)   in  the  form         */
/* "^yc^my^dm^Hd^MH^99.999999UM" (e.g.   830718105806.808512).  This         */
/* is a request id as used by ear and eor.                                   */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$request_id_ entry(fixed bin (71)) returns (char         */
/*       (19));                                                              */
/*    result = date_time_$request_id_ (clock);                               */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* clock (input)                                                             */
/*    is the clock value to be formatted                                     */
/* result (output)                                                           */
/*    is the resultant character string                                      */
/*                                                                           */
/* ***********************************+************************************* */

request_id_: entry (clock_value) returns (char (19));

/* format: off						       */
/*clock_value	fixed bin (71);	/* standard clock value 	   [In]*/
				/* format: on		       */

      ddt_sw = "0"b;
request_id_rtn: begin;		/* <<##>> */
      lcode = 0;
      Ptime_value = addr (decoded_clock);
      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;
      lang_index = time_defaults_$language_index;
      call Multics_2_vc (clock_value, "gmt", time_info_$gmt_zone_index,
         lang_index, cal_val);
      if (lcode = 0)
      then call fromclock$no_FW;
      if (lcode ^= 0)
      then string (rqid) = "0000000000000000000";
      else do;
         pic4 = time_value.yc;
         rqid.yc = substr (pic4, 3, 2);
         rqid.my = time_value.my;
         rqid.dm = time_value.dm;
         rqid.Hd = time_value.Hd;
         rqid.MH = time_value.MH;
         rqid.SM = time_value.SM;
         rqid.US = time_value.US;
      end;
      end request_id_rtn;	
      if ^ddt_sw
      then return (string (rqid));
      str = string (rqid);
      return;

dcl 1 rqid,
      2 yc	char (2),
      2 (my, dm, Hd, MH, SM) pic "99",
      2 US	pic ".999999";	/* @@END request_id_	       */
				/* <##> */ %page;
/* @@@@@@ ext proc .. set_lang				       */
/* ***********************************+************************************* */
/*							       */
/* ENTRY:  date_time_$set_lang                                               */
/*                                                                           */
/* This entry sets or resets the user's default time language.               */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$set_lang entry(char (*), fixed bin (35));               */
/*    call date_time_$set_lang (lang, code);                                 */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* lang (input)                                                              */
/*    the language which is to be made current.  "system_lang" means         */
/*    use the system default time language.                                  */
/* code (output)                                                             */
/*    is a standard  status code.  It can have  one of the following         */
/*    values--                                                               */
/*    error_table_$dt_unknown_time_language                                  */
/*							       */
/* ***********************************+************************************* */ %skip (2);
/* ------------------------------------------------------------------------- */
/*	   Note that this setting does not affect lower rings.	       */
/* ------------------------------------------------------------------------- */
set_lang: entry (new_str, code);

/* format: off						       */
dcl new_str	char (*);		/* candidate language name	   [In]*/
/*code		fixed bin (35);    	/* error code		  [Out]*/
				/* format: on		       */
set_lang_rtn: begin;		/* <<##>> */
dcl (
    error_table_$dt_unknown_time_language  /* <##> */
    )		fixed bin (35) ext static;

      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;
      code = 0;
      if new_str = ""		/* Reset to system default time      */
         | new_str = "system_lang"	/*  language.		       */
      then do;
         time_defaults_$language_index, lang_index
	  = time_info_$default_language_index;
         time_defaults_$language = ti_language.name (lang_index, lang_index);
      end;
      else do;
/**** Convert user-supplied lang name to index.			       */
         lang_index = get_word_index ((new_str), Language_table);
         if lang_index < 1		/* Name not found in	       */
				/*  time_info_$language_names?       */
         then code = binary (error_table_$dt_unknown_time_language);
         else do;
	  time_defaults_$language
	     = ti_language.name (lang_index, lang_index);
	  time_defaults_$language_index = lang_index;
         end;
      end;
      return;			/* @@END set_lang		       */
      end set_lang_rtn;		/* <##> */ %page;
/* @@@@@@ ext proc .. set_time_defaults				       */
/* ***********************************+************************************* */
/* ***********************************+************************************* */
/* ------------------------------------------------------------------------- */
/*	   Note that this setting does not effect lower rings.	       */
/* ------------------------------------------------------------------------- */
set_time_defaults: entry;

set_time_defaults_rtn: begin;		/* <<##>> */
dcl (
    error_table_$unimplemented_version	/* <##> */
    )		fixed bin (35) ext static;

      if time_info_$version ^= Vtime_info_2 /* Make sure we know format of   */
      then do;			/*  time_info_.		       */
         call com_err_ (error_table_$unimplemented_version,
	  "date_time_$set_time_defaults",
	  "^/Version ^a of the time_info_ is not supported.",
	  time_info_$version);
         return;
      end;
/**** Set process default formats				       */
      time_defaults_$date_time = ti_keyword.str (site_date_time);
      time_defaults_$date = ti_keyword.str (site_date);
      time_defaults_$time = ti_keyword.str (site_time);


/**** Set default time language.				       */
      time_defaults_$language_index, lang_index
         = time_info_$default_language_index;
      time_defaults_$language = ti_language.name (lang_index, lang_index);

/**** Set default time zone. These are the situations where this routine     */
/****  will be called.					       */
/**** 1) scs_and_init_clocks initializes sys_info_$time_zone (and then comes */
/****    back later under some condition).  If $zone_index <1 it CRASHes.    */
/**** 2) init_clocks sets sys_info$time_zone from the BOS CLOK config	       */
/****    parameter and then calls set_time_defaults.  Then if $zone_index    */
/****    is <1, it will ABORT so that the operator can set a known zone.     */
/**** 3) Anyplace else.  Since the system could not come up with an unknown  */
/****    zone in sys_info_, it isn't necessary to check for its being found. */

      zone_index = get_word_index ((sys_info$time_zone), Zone_table);

      time_defaults_$zone_index = zone_index;
      if (zone_index < 1)
      then zone_index = time_info_$gmt_zone_index;
      time_defaults_$zone_delta = ti_zone.delta (lang_index, zone_index);
      time_defaults_$zone_short = ti_zone.short (lang_index, zone_index);
      time_defaults_$zone_long = ti_zone.long (lang_index, zone_index);
      return;			/* @@END set_time_defaults	       */
      end set_time_defaults_rtn;	/* <##> */ %page;
/* @@@@@@ ext proc .. set_zone				       */
/* ***********************************+************************************* */
/*							       */
/* ENTRY:  date_time_$set_zone                                               */
/*                                                                           */
/* This entry sets or resets the user's default zone.                        */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$set_zone entry(char (*), fixed bin (35));               */
/*    call date_time_$set_zone (zone, code);                                 */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* zone (input)                                                              */
/*    the  short  name of  the  zone which  is  to be  made current.         */
/*    "system_zone" means use the system default zone.                       */
/* code (output)                                                             */
/*    is a standard  status code.  It can have  one of the following         */
/*    values--                                                               */
/*    error_table_$unknown_zone                                              */
/*							       */
/* ***********************************+************************************* */ %skip (2);
/* ------------------------------------------------------------------------- */
/*	   Note that this setting does not effect lower rings.	       */
/* ------------------------------------------------------------------------- */
set_zone: entry (new_str, code);

/* format: off						       */
/*new_str		char (*);		/* candidate zone name	   [In]*/
/*code		fixed bin (35);    	/* error code		  [Out]*/
				/* format: on		       */
set_zone_rtn: begin;		/* <<##>> */
dcl (
    error_table_$unknown_zone		/* <##> */
    )		fixed bin (35) ext static;

      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;
      if new_str = ""		/* Restore system default time zone. */
         | new_str = "system_zone"
      then zone_index = get_word_index ((sys_info$time_zone), Zone_table);
      else do;
         zone_index = get_word_index ((new_str), Zone_table);
         if zone_index < 1		/* Conversion failed?	       */
         then do;
	  code = binary (error_table_$unknown_zone);
	  return;
         end;
      end;
      lang_index = time_defaults_$language_index;
      time_defaults_$zone_short = ti_zone.short (lang_index, zone_index);
      time_defaults_$zone_delta = ti_zone.delta (lang_index, zone_index);
      time_defaults_$zone_long = ti_zone.long (lang_index, zone_index);
      time_defaults_$zone_index = zone_index;
      code = 0;
      return;			/* @@END set_zone		       */
      end set_zone_rtn;		/* <##> */ %page;
/* @@@@@@ ext proc .. to_clock				       */
/* ***********************************+************************************* */
/*							       */
/* ENTRY:  date_time_$to_clock                                               */
/*                                                                           */
/* Given any  or all of  the following- years,  months, days, hours,         */
/* minutes, seconds, microseconds, day in  week, day in year, or day         */
/* in  clock, returns  a standard  clock value  which represents the         */
/* encoding  of these  values.  All the  values must  be valid, i.e.         */
/* hours ^> 23, etc.                                                         */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl date_time_$to_clock entry (ptr, fixed bin (71), fixed bin          */
/*       (35));                                                              */
/*    call date_time_$to_clock (addr (time_value), clock, code);             */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* time_value (input)                                                        */
/*    is  the  structure containing  time  parts.  The  structure is         */
/*    defined in time_value.incl.pl1.                                        */
/* clock (output)                                                            */
/*    is the encoded clock value                                             */
/* code (output)                                                             */
/*    is a standard  status code.  It can have  one of the following         */
/*    values--                                                               */
/*    error_table_$bad_time                                                  */
/*    error_table_$dt_bad_day_of_week                                        */
/*    error_table_$dt_bad_dm                                                 */
/*    error_table_$dt_bad_dy                                                 */
/*    error_table_$dt_bad_my                                                 */
/*    error_table_$dt_conflict                                               */
/*    error_table_$dt_date_not_exist                                         */
/*    error_table_$dt_date_too_big                                           */
/*    error_table_$dt_date_too_small                                         */
/*    error_table_$unimplemented_version                                     */
/*    error_table_$unknown_zone                                              */
/*                                                                           */
/* NOTES:                                                                    */
/* "day"  (as  opposed  to "time")  data  is only  valid  in certain         */
/* combinations.  This table shows with  the *'s which fields may be         */
/* present together.  All others must be zero.                               */
/*                                                                           */
/*                 +-1-+-2-+-3-+-4-+                                         */
/*   time_value.yc | * | * |   |   |  In cases 1, 2, & 4, if dw is           */
/*   time_value.my | * |   |   |   |  present,  it is used to verify         */
/*   time_value.dm | * |   |   |   |  the value converted.                   */
/*   time_value.fw |   |   | * |   |                                         */
/*   time_value.dw |   |   |(*)|   |  In case 3 it actually defines          */
/*   time_value.dy |   | * |   |   |  a day.  If not present, Monday         */
/*   time_value.dc |   |   |   | * |  is assumed.                            */
/*                 +-v-+-v-+-v-+-v-+                                         */
/*                   |   |   |   +-clock_days = dc                           */
/*                   |   |   +-----clock_days = converted (fw,dw)            */
/*                   |   +---------clock_days = converted (yc,dy)            */
/*                   +-------------clock_days = converted (yc,my,dm)         */
/*							       */
/* ***********************************+************************************* */
to_clock: entry (APtime_value, clock_value, code);

/* format: off						       */
/*APtime_value	ptr		/* ->input structure.	   [In]*/
/*clock_value	fixed bin (71)	/* standard clock value	  [Out]*/
/*code		fixed bin (35)	/* standard return code	  [Out]*/
				/* format: on		       */

to_clock_rtn: begin;		/* <<##>> */
dcl (
    error_table_$bad_time,		/* <##> */
    error_table_$dt_bad_day_of_week,	/* <##> */
    error_table_$dt_bad_fw,		/* <##> */
    error_table_$dt_conflict,		/* <##> */
    error_table_$dt_date_too_big,	/* <##> */
    error_table_$dt_date_too_small,	/* <##> */
    error_table_$unknown_zone,	/* <##> */
    error_table_$unimplemented_version	/* <##> */
    )		fixed bin (35) ext static;
dcl combination	bit(6);
dcl fiscal_day_value fixed bin;


      Ptime_value = APtime_value;	/* point to caller's data	       */
      day_adjust = 0;
      if (time_value.Hd = 24) | (time_value.fw ^= 0)
      then do;			/* will need to modify the data,     */
         auto_time_value = time_value;	/* ..so make a copy.	       */
         Ptime_value = addr (auto_time_value);
         if (time_value.Hd = 24)
         then do;
	  time_value.Hd = 0;
	  day_adjust = 1;
         end;
      end;
      code, lcode = 0;
      if (time_value.version ^= Vtime_value_3) & (time_value.version ^= "3")
      then do;
         code = binary (error_table_$unimplemented_version);
         return;
      end;
      if (time_defaults_$zone_delta = -1)
      then call date_time_$set_time_defaults;
      lang_index = time_defaults_$language_index;

      if time_value.dw < 0		/*  0 ==> no check		       */
         | time_value.dw > 7		/* 1=Mon <= day_in_week <= 7=Sun;    */
      then do;
         code = binary (error_table_$dt_bad_day_of_week);
         return;
      end;
      if time_value.Hd < 0
         | time_value.Hd > 23		/* 24 hours per day		       */
         | time_value.MH < 0
         | time_value.MH > 59		/* 60 minutes per hour	       */
         | time_value.SM < 0
         | time_value.SM > 59		/* 60 seconds per minute	       */
         | time_value.US < 0
         | time_value.US >= 1000000
      then do;
         code = binary (error_table_$bad_time);
         return;
      end;
      if time_value.yc > 9999
      then goto toobig;

      substr (combination, 1, 1) = (time_value.yc ^= 0);
      substr (combination, 2, 1) = (time_value.my ^= 0);
      substr (combination, 3, 1) = (time_value.dm ^= 0);
      substr (combination, 4, 1) = (time_value.fw ^= 0);
      substr (combination, 5, 1) = (time_value.dy ^= 0);
      substr (combination, 6, 1) = (time_value.dc ^= 0);
      if (     combination = "111000"b)	/* year,month,day		       */
         | (   combination = "100010"b)	/* year,day-in-year		       */
      then do;
         call ymd_to_days;
         if (lcode ^= 0)
         then goto to_clock_exit;
      end;
      else if (combination = "000100"b) /* fiscal week		       */
      then do;
         fiscal_year_value = divide (time_value.fw, 100, 17, 0);
         fiscal_week_value = time_value.fw - fiscal_year_value * 100;
         if (fiscal_week_value < 1)
         then do;
err_dt_bad_fw:
	  code = binary (error_table_$dt_bad_fw);
	  return;
         end;
         time_value.yc = fiscal_year_value;
retry_fw:
         time_value.my = 1;
         time_value.dm = 1;
         call ymd_to_days;
         fiscal_day_value =		/*  yields   1=Mon ... 7=Sun	       */
	  (lclock_days + 4) - divide ((lclock_days + 4), 7, 11) * 7 + 1;
         time_value.my, time_value.dm = 0;
         time_value.dy = fiscal_week_value * 7 - fiscal_day_value - 5;
         if (fiscal_day_value > 4)
         then time_value.dy = time_value.dy + 7;
         if (time_value.dy < 1)
         then do;			/* FW[first] is in last year,	       */
	  fiscal_week_value = 53;	/* ..back up		       */
	  time_value.yc = time_value.yc - 1;
	  goto retry_fw;		/* ..and recalculate	       */
         end;
         if (time_value.dy > 366)
         then do;			/* years don't get that big	       */
	  if (time_value.yc = fiscal_year_value)
	  then goto err_dt_bad_fw;	/* user can't say that	       */
	  else time_value.dy = time_value.dy - 7; /* (but I can)	       */
         end;
         call ymd_to_days;
         if (lcode ^= 0)
         then goto to_clock_exit;
         if (time_value.dw ^= 0)	/* adjust to day-of-week given       */
         then lclock_days = lclock_days + time_value.dw -1;
         time_value.dw = 0;
      end;
      else if (combination = "000001"b) /* day-in-clock		       */
      then do;
         if (time_value.dc < 1)
         then do;
	  code = binary (error_table_$dt_date_too_small);
	  return;
         end;
         if (time_value.dc > 0)
         then if time_value.dc > 3652061 - day_adjust
         then do;
toobig:
	  code = binary (error_table_$dt_date_too_big);
	  return;
         end;
         lclock_days = time_value.dc;	/* ready to go		       */
         cal_val.J_G = None;
      end;
      else do;
         code = binary (error_table_$dt_conflict);
         return;
      end;

      lclock_days = lclock_days + day_adjust;

      zone_index = get_word_index ((time_value.za), Zone_table);
      if (zone_index < 1)
      then do;
         if (verify (time_value.za, "-+0123456789") ^= 0)
         then do;
	  code = binary (error_table_$unknown_zone);
	  return;
         end;
         zone_index = 0;
         cal_val.z = time_value.za;
         cal_val.dx
	  = convert (cal_val.dx, substr (cal_val.z, 2, 2)) * 3600000000
	  + convert (cal_val.dx, substr (cal_val.z, 4, 2)) * 60000000;
         if (substr (cal_val.z, 1, 1) = "+")
         then cal_val.dx = -cal_val.dx;
/****    This negates on "+" instead of "-" because our internal use of      */
/****    zone offsets is opposite that of a zone differential.	       */
      end;
      else do;
         cal_val.z = ti_zone.short (lang_index, zone_index);
         cal_val.dx = ti_zone.delta (lang_index, zone_index);
      end;
      time_value.zone_index = zone_index;

      cal_val.zi = zone_index;	/* format: off		       */
      cal_val.x = (         time_value.US
         +       1000000 * (time_value.SM
         +            60 * (time_value.MH
         +            60 * (time_value.Hd
         + precision (24 * (lclock_days - 1), 27))))); /* format: on	       */
/**** lclock_days contains a 1-based value, but we needed a 0-based number   */
/****  of days for use in computing the microsecond clock value.	       */

      if (time_value.dw ^= 0)
      then do;
         diw = (lclock_days + 4) - divide ((lclock_days + 4), 7, 11) * 7 + 1;
         if (time_value.dw ^= diw)
         then do;
	  code = error_table_$dt_bad_day_of_week;
	  return;
         end;
      end;
      else diw = 0;

      call vc_2_Multics (cal_val, clock_value);
to_clock_exit:
      code = lcode;
      return;			/* @@END to_clock		       */
      end to_clock_rtn;		/* <##> */%page;
/* ***********************************+************************************* */
/*                                                            _	       */
/*            o            _|_                                 |	       */
/*           __      _      |      _      _      _     ___     |	       */
/*            |    |/ \     |     / \   |/ \   |/ \    ___\    |	       */
/*            |    |   |    |    (__/   |      |   |  /   |    |	       */
/*	   _|_   |   |    \_    \_/   |      |   |  \__/|   _|_	       */
/*							       */
/* ***********************************+************************************* */

/* @@@@@@ int proc .. apply_offset				       */
/* ***********************************+************************************* */
/* apply a set of offsets to a calendar value			       */
/* ***********************************+************************************* */
apply_offset: proc;			/* <<##>> */

dcl 1 toa		like time_offset_array based (toa_p);
dcl toa_p		ptr;
dcl toa_i		fixed bin;
dcl overflow	condition;
dcl (
    error_table_$dt_bad_day_of_week,	/* <##> */
    error_table_$dt_offset_too_big_negative,  /* <##> */
    error_table_$dt_offset_too_big_positive   /* <##> */
    )		fixed bin (35) ext static;


      toa_p = addr (auto_time_offset);
      lang_index = 1;		/* force a valid amount	       */
      do i = 1 to 8;		/* make sure all unused fields       */
         if (toa.flag (i) = UNUSED)	/* ..are empty		       */
         then toa.val (i) = 0;
      end;
      if (auto_time_offset.dw.flag ^= UNUSED)
      then if auto_time_offset.dw.val < 1  /* validate user-specified	       */
         | auto_time_offset.dw.val > 7	/* ...day-of-week offset.	       */
      then do;
         lcode = binary (error_table_$dt_bad_day_of_week);
exit:    return;
      end;
      on overflow
         begin;
	  if (toa.val (toa_i) < 0)
	  then lcode = binary (error_table_$dt_offset_too_big_negative);
	  else lcode = binary (error_table_$dt_offset_too_big_positive);
	  goto exit;
         end;

/* First, apply any day-of-week offset to input clock value.  This offset is */
/*  negative if the previous day is to be used and positive if the next one. */
/*  If absolute value of the offset is the same as clock value day-of-week,  */
/*  add/subtract a week to get the needed occurence of that day-of-week;     */
/*  otherwise, add/subtract enough days (<7) to reach wanted day-of-week.    */

      if (auto_time_offset.dw.flag ^= UNUSED)
      then do;
         Ptime_value = addr (decoded_clock);
         call fromclock$no_FW;	/* decode base value	       */
         if lcode ^= 0
         then return;
         if (auto_time_offset.dw.flag > UNUSED)
         then do;
	  auto_time_offset.dw.val = auto_time_offset.dw.val
	     - decoded_clock.dw;
	  if (auto_time_offset.dw.val < 0)
	  | (auto_time_offset.dw.val = 0) & (auto_time_offset.dw.flag = AFTER)
	  then auto_time_offset.dw.val = auto_time_offset.dw.val + 7;
         end;
         else if (auto_time_offset.dw.flag < UNUSED)
         then do;
	  auto_time_offset.dw.val = auto_time_offset.dw.val
	     - decoded_clock.dw;
	  if (auto_time_offset.dw.val > 0)
	  | (auto_time_offset.dw.val = 0) & (auto_time_offset.dw.flag = BEFORE)
	  then auto_time_offset.dw.val = auto_time_offset.dw.val - 7;
         end;
/****    breaking 864e8 into 2 parts makes for better (inline) code.	       */
         cal_val.x = cal_val.x + 100000000 * (auto_time_offset.dw.val * 864);
      end;			/* ***** DAY-IN-WEEK  finished ***** */

      if (auto_time_offset.flag.yr > 0)
      then do;
         Ptime_value = addr (decoded_clock);
         call fromclock$no_FW;	/* decode values in terms of our     */
         if lcode ^= 0
         then return;
         toa_i = 1;			/* to help the condition handler     */
/****    Separate year offset into integer and fraction parts.	       */
         Tyear = auto_time_offset.val.yr;
         fld24 = auto_time_offset.val.yr - trunc (auto_time_offset.val.yr);
/****    Ensure that auto_time_value.yc gets set.			       */
         auto_time_value.yc = decoded_clock.yc + Tyear;
         if (Tyear ^= 0)
         then do;
	  auto_time_value.dm = decoded_clock.dm;
	  auto_time_value.my = decoded_clock.my;
	  auto_time_value.dy = 0;
/****       If decoded day # falls in the 10-day gap between Julian &	       */
/****       Gregorian calendars, push it back to the last valid day.	       */
	  if (auto_time_value.yc = 1582) & (auto_time_value.my = OCTOBER)
	     & (auto_time_value.dm > 4) & (auto_time_value.dm < 15)
	  then auto_time_value.dm = 4;
	  if auto_time_value.my = FEBRUARY & auto_time_value.dm = 29
	  then if calc_leap_day (auto_time_value.yc) = 0
	  then if Tyear < 0		/* adjust date when year offset from */
				/* 02/29/<leap_year> lands in a      */
				/* non-leap_year.		       */
	     then auto_time_value.dm = 28;
	     else do;
	        auto_time_value.my = MARCH;
	        auto_time_value.dm = 1;
	     end;
	  Ptime_value = addr (auto_time_value);
	  call ymd_to_days;		/* break down the adjusted year      */
	  if (lcode ^= 0)
	  then return;
	  cal_val.x = (decoded_clock.US + 1000000 * (decoded_clock.SM
	     + 60 * (decoded_clock.MH + 60 * (decoded_clock.Hd
	     + precision (24 * (lclock_days - 1), 27)))));
         end;
         else cal_val.J_G = None;
         if (fld24 ^= 0)
         then do;			/* apply fractional part, if any     */
/****       How many days in the year?				       */
	  if (auto_time_value.yc = 1582)
	  then unit_size = 355;
	  else unit_size = 365 + calc_leap_day (auto_time_value.yc);
/****       How many microseconds is that? (-1 bias helps roundoff problem)  */
	  unit_size = (unit_size * 864) * 100000000 - 1;
/****       Add in the number of Usec that the fraction represents.	       */
	  fld24 = convert (fld24, unit_size) * fld24;
	  cal_val.x = cal_val.x + convert (cal_val.x, fld24);
         end;
      end;

      if (auto_time_offset.flag.mo > 0)
      then do;
         Ptime_value = addr (decoded_clock);
         call fromclock$no_FW;	/* decode value		       */
         if lcode ^= 0
         then return;
         toa_i = 2;			/* to help the condition handler     */
/****    Separate month offset into integer and fraction parts.	       */
         Tmonth = auto_time_offset.val.mo;
         fld24 = auto_time_offset.val.mo - trunc (auto_time_offset.val.mo);
         Tmonth = Tmonth + decoded_clock.my;
/****    Tmonth, originally an offset, is now a month-in-year	       */
				/* rule:   1 <= month <= 12;	       */
         if (Tmonth < 1)		/*  enforce this rule by normalizing */
         then do;			/*  the month and year values.       */
	  Tyear = divide (Tmonth, 12, 17) - 1; /* -1 accounts for	       */
	  Tmonth = Tmonth - Tyear * 12; /* ..the 0 month #	       */
         end;
         else if (Tmonth > 12)	/* N year, 0 mon = N-1 year, 12 mon  */
         then do;
	  Tyear = divide (Tmonth - 1, 12, 17);
	  Tmonth = Tmonth - Tyear * 12;
         end;
         else Tyear = 0;
         Tyear = Tyear + decoded_clock.yc;
/****    If day # from decoded clock value is greater than # of days in the  */
/****    adjusted month, then set it to # of days in month; thus:	       */
/****	      May 31, 1973 -3 months				       */
/****    produces an intermediate result of:			       */
/****	      February 28, 1973				       */
         if Tmonth = FEBRUARY		/* if this is February	       */
         then Tday = 28 + calc_leap_day ((Tyear));
         else Tday = days_in_month (Tmonth);
         Tday = min (decoded_clock.dm, Tday);
/****    If decoded day # falls in the 10-day gap between Julian & Gregorian */
/****    calendars, push it back to the last valid day.  This mimics the     */
/****    action mentioned above.				       */
         if (Tyear = 1582) & (Tmonth = OCTOBER)
	  & (Tday > 4) & (Tday < 15)
         then Tday = 4;
         auto_time_value.dm = Tday;
         auto_time_value.my = Tmonth;
         auto_time_value.yc = Tyear;
         auto_time_value.dy = 0;
         Ptime_value = addr (auto_time_value);
         call ymd_to_days;		/* break down the adjusted yr/mo     */
         if (lcode ^= 0)
         then return;
         cal_val.x = (decoded_clock.US + 1000000 * (decoded_clock.SM
	  + 60 * (decoded_clock.MH + 60 * (decoded_clock.Hd
	  + precision (24 * (lclock_days - 1), 27)))));
         if (fld24 ^= 0)
         then do;			/* apply fractional part, if any     */
/****       How many days in the month?				       */
	  if Tmonth = FEBRUARY	/* if this is February	       */
	  then unit_size = 28 + calc_leap_day ((Tyear));
	  else unit_size = days_in_month (Tmonth);
/****       How many microseconds is that? (-1 bias helps roundoff problem)  */
	  unit_size = (unit_size * 864) * 100000000 - 1;
/****       Add in the number of Usec that the fraction represents.	       */
	  fld24 = convert (fld24, unit_size) * fld24;
	  cal_val.x = cal_val.x + convert (cal_val.x, fld24);
         end;
      end;
/**** Now take care of the easy ones:  wk, da, hr, min, sec, Usec.	       */
/****				3   4   5    6    7     8	       */
      do toa_i = 3 to 8;
         if (toa.flag (toa_i) > 0)
         then cal_val.x = cal_val.x
	       + convert (cal_val.x, toa.val (toa_i) * unit_sizes (toa_i));
      end;
      revert overflow;

   end apply_offset;		/* <##> */ %page;
/* @@@@@@ int func .. calc_leap_day				       */
/* ***********************************+************************************* */
/* ***********************************+************************************* */
calc_leap_day: proc (yr) returns (fixed bin); /* <<##>> */

dcl yr		fixed bin;

      if (yr > 1582)
      then return (1
	    - divide (yr - divide (yr, 4, 17) * 4 + 3, 4, 17)
	    + divide (yr - divide (yr, 100, 17) * 100 + 99, 100, 17)
	    - divide (yr - divide (yr, 400, 17) * 400 + 399, 400, 17));
      if (mod (yr, 4) = 0)
      then return (1);
      return (0);

   end calc_leap_day;		/* <##> */ %skip (4);
/* @@@@@@ int proc .. cv_fmt_kwd				       */
/* ***********************************+************************************* */
/* ***********************************+************************************* */

cv_fmt_kwd: proc (fmt_str) returns (char (256)var); /* <<##>> */

dcl fmt_str	char(512)var;

dcl (
    error_table_$dt_no_format_selector	/* <##> */
    )		fixed bin (35) ext static;
dcl ii		fixed bin;
dcl result	char (256)var;
dcl ct		fixed bin;

         lcode = 0;
         ct = 0;
         result = fmt_str;
check:
         if (result = "date_time")
         then result = time_defaults_$date_time;
         else if (result = "date")
         then result = time_defaults_$date;
         else if (result = "time")
         then result = time_defaults_$time;
         else do;
	  do ii = 1 to ti_keyword.number_kwd;
	     if (ti_keyword.name (ii) = result)
	     then do;
	        result = ti_keyword.str (ii);
	        goto found_kwd;
	     end;
	  end;
no_good:
	  lcode = binary (error_table_$dt_no_format_selector);
	  return(fmt_str);
found_kwd:
         end;
         if (index (result, "^") = 0)	/* if the keyword gave a keyword     */
         then do;
	  if (ct = 0)		/* ..and this is the first time      */
	  then do;		/* ..thru, give it another shot.     */
	     ct = 2;
	     goto check;
	  end;
	  goto no_good;		/* ..otherwise complain	       */
         end;
         return (result);

      end cv_fmt_kwd;

/* @@@@@@ int proc .. do_format				       */
/* ***********************************+************************************* */
/* ***********************************+************************************* */
do_format: proc;			/* <<##>> */

dcl i		fixed bin;

      Ptime_value = addr (decoded_clock); /* point to a structure	       */
      time_value.version = Vtime_value_3;
      call fromclock;		/* ..and get it filled in, in the    */
				/* ..zone specified or implied       */
error:
      if lcode ^= 0			/* report error to user.	       */
      then do;
         lresult = "01/01/01  0000.00 gmt Tue";
         return;
      end;
do_format$direct: entry;
      errloc = 1;			/* in case there's an error	       */
      if (index (lformat, "^") = 0)	/* if no ^'s, it must be a keyword   */
      then do;			/* ..get it translated	       */
         lformat = cv_fmt_kwd (lformat);
         errlocad.n = 1;
         errlocad.start(1) = 1;
         errlocad.enclosed_key(1) = 0;
         errlocad.old_len(1) = length(format);
         errlocad.new_len(1) = length(lformat);
         end;
      if (lcode ^= 0)
      then goto error;
      
      lresult = "";			/* set up to scan his format string  */
      format_i = 1;
      do while ((format_i <= length (lformat)) & (lcode = 0));
         i = index (substr (lformat, format_i), "^");
         if (i = 0)
         then i = length (lformat) - format_i + 1;
         else i = i - 1;
         if (i > 0)
         then lresult = lresult || substr (lformat, format_i, i);
         format_i = format_i + i;
         if (format_i <= length (lformat))
         then do;
	  call proc_selector;
         end;
      end;

   end do_format;			/* <##> */ %page;
/* @@@@@@ int proc .. fromclock				       */
/* ***********************************+************************************* */
/* Arguments to this proc are:				       */
/*   Ptime_value=  ptr to time_value output struc.		   [In]*/
/*   cal_val    =  calendar value in zone specified to be converted      [In]*/
/*   lcode      =  error code if nonzero			  [Out]*/
/* ***********************************+************************************* */
fromclock: proc;			/* <<##>> */
     do_FW = "1"b;
     goto start;

fromclock$no_FW: entry;
     do_FW = ""b;
start:     ;

dcl (
    error_table_$badcall	/* <##> */
    )		fixed bin (35) ext static;

dcl (A, B, C)	fixed bin;	/* factors for leap year calculation */
dcl lclock_seconds	fixed bin (36);
dcl lclock_minutes	fixed bin (31);
dcl lclock_hours	fixed bin (25);
dcl lclock_days	fixed bin (20);
dcl leap_day	fixed bin;	/* number of Feb 29's in this year.  */
dcl do_FW		bit (1);
dcl day_for_fiscal	fixed bin;
dcl fiscal_constant fixed bin;
dcl fiscal_week_value fixed bin;
dcl fiscal_year_value fixed bin;

      lcode = 0;
      time_value.zone_index = cal_val.zi;

/* ***********************************+************************************* */
/*							       */
/* 1) compute number of micro-seconds in excess of 1 second in clock value.  */
/* 2) compute number of seconds in excess of 1 minute in clock value.	       */
/* 3) compute number of minutes in excess of 1 hour in clock value.	       */
/* 4) compute number of hours in excess of 1 day in clock value.	       */
/*							       */
/* ***********************************+************************************* */
/* format: off		       */

      time_value.Uc = cal_val.x;
      time_value.za = cal_val.z;
      time_value.zone_index = cal_val.zi;

      lclock_seconds = divide (cal_val.x,                1000000, 39);
      time_value.US  = cal_val.x      - lclock_seconds * 1000000;

      lclock_minutes = divide (lclock_seconds,           60, 10);
      time_value.SM  = lclock_seconds - lclock_minutes * 60;

      lclock_hours   = divide (lclock_minutes,           60, 8);
      time_value.MH  = lclock_minutes - lclock_hours   * 60;

      lclock_days    = divide (lclock_hours,             24, 7);
      time_value.Hd  = lclock_hours  - lclock_days     * 24;
				/* format: on		       */
/**** Add 1 because Us 0 at beginning of day 1			       */
      time_value.dc = lclock_days + 1; %page;
      if (cal_val.J_G = Special)	/* this range does Julian type of    */
      then do;			/* ..breakdown (cheaper)	       */
         lclock_days = lclock_days + 13;
         goto Julian_style;
      end;
      if (cal_val.J_G = Gregorian)
      then do;

/* ***********************************+************************************* */
/*							       */
/*    G R E G O R I A N    D A T E S :  1582-10-15 thru 9999-12-31	       */
/* During this interval, the Gregorian leap calculation is used.	       */
/*							       */
/* Compute the year by dividing the whole number of days in the clock value  */
/*  into a whole number of 400 year groups plus a whole number of 100 year   */
/*  groups plus a whole number of 4 year groups plus a number of years in    */
/*  excess of the last 4 year group.				       */
/*							       */
/* ***********************************+************************************* */

         A, B, C = 1;		/* format: off */
         lclock_days = lclock_days - 2;	/* The base value of the Gregorian   */
				/* ..algorithm is 2 days before that */
				/* ..of the Julian.		       */

         num_of__400s = divide (lclock_days,     146097, 2);
         rest_of__400 =         lclock_days   -  146097 * num_of__400s;
              if (rest_of__400 >= 146097-366)
	    then C = 0;

         num_of__100s = divide ( rest_of__400,    36524, 1);
              if  (num_of__100s = 4)	/* Account for leap day every 4th    */
	    then num_of__100s = 3;	/*  century.		       */
         rest_of__100 =          rest_of__400 -   36524 * num_of__100s;
              if (rest_of__100 >= 36524-365)
	    then B = 0;

         num_of____4s = divide ( rest_of__100,     1461, 2);
         rest_of____4 =          rest_of__100 -    1461 * num_of____4s;
              if (rest_of____4 >= 1461-366)
	    then A = 0;

         num_of____1s = divide ( rest_of____4,      365, 1);
              if  (num_of____1s = 4)	/* Account for leap day every 4th    */
              then num_of____1s = 3;	/*  year			       */
         rest_of____1 =          rest_of____4 -     365 * num_of____1s + 1;
				/* Number of the day of the year.    */
         time_value.yc
            = num_of__400s * 400
            + num_of__100s * 100
            + num_of____4s * 4
            + num_of____1s + 1;
				/* format: on */
         time_value.dy = rest_of____1;
         if (time_value.yc = 1582)	/* Only 355 days in year 1582.       */
	  & (rest_of____1 >= 288)
         then time_value.dy = rest_of____1 - 10;

         leap_day = 1 - A + B - C;
      end; %page;
/* ***********************************+************************************* */
/*							       */
/*    J U L I A N   D A T E S :  0001-01-01 thru 1582-10-04		       */
/*							       */
/* Compute the year by dividing the whole number of days in the clock value  */
/*  into a whole number of 4 year groups plus a number of years in excess    */
/*  of the last 4 year group.					       */
/*							       */
/* ***********************************+************************************* */

      else if (cal_val.J_G = Julian)
      then do;
Julian_style:
         num_of____4s = divide (lclock_days, 1461, 17);
         rest_of____4 = lclock_days - (1461 * num_of____4s);
         num_of____1s = divide (rest_of____4, 365, 1);
         if (num_of____1s >= 3)	/* =4 on last day of leap year.      */
         then do;
	  num_of____1s = 3;
	  leap_day = 1;
         end;
         else leap_day = 0;

         rest_of____1 = rest_of____4 - (365 * num_of____1s) + 1;
         time_value.yc
	  = num_of____4s * 4
	  + num_of____1s + 1;
         time_value.dy = rest_of____1;


      end;
      else do;
         lcode = binary (error_table_$badcall);
         return;
      end; %page;
/* ***********************************+************************************* */
/* 0001-1-1 has dc=1 and is a Saturday(=6).  Calculate the day of the week   */
/* by removing the number of whole weeks and adjusting what is left.	       */
/* when dc=1 the formula will be (1+4)-(1+4)/7*7+1		       */
/* which works out to be           5  -    0    +1 = 6		       */
/* when dc=3 the formula will be (3+4)-(3+4)/7*7+1		       */
/* which works out to be           7  -    7    +1 = 1		       */
/* This show that the wrap around is at the right place.		       */
/* ***********************************+************************************* */

      time_value.dw			/*  yields   1=Mon ... 7=Sun	       */
         = (time_value.dc + 4) - divide ((time_value.dc + 4), 7, 11) * 7 + 1;

/* ***********************************+************************************* */
/*							       */
/*  Calculate the fiscal week.  This method is derived from equations in     */
/*  an article in Interface Age by R. W. Bemer; Feb 1979 p75-79	       */
/*							       */
/* ***********************************+************************************* */
      if do_FW
      then do;
         day_for_fiscal = divide (time_value.dy - 1, 7, 17);
         day_for_fiscal = time_value.dy - 1 - day_for_fiscal * 7;
         fiscal_constant = time_value.dw - day_for_fiscal + 6;
         if (fiscal_constant < 4)
         then fiscal_constant = fiscal_constant + 7;
         if (fiscal_constant > 10)
         then fiscal_constant = fiscal_constant - 7;

         fiscal_week_value
	  = divide (time_value.dy + fiscal_constant - 1, 7, 17);
         fiscal_year_value = time_value.yc;

/**** take care of the special cases				       */

         if (fiscal_week_value = 53)
         then do;
	  if fiscal_constant + leap_day < 10
	  then do;
	     fiscal_year_value = fiscal_year_value + 1;
	     fiscal_week_value = 1;
	  end;
         end;
         else if fiscal_week_value = 0
         then do;
	  fiscal_year_value = fiscal_year_value - 1;
	  fiscal_week_value = 53
	     - divide (fiscal_constant + 1 - calc_leap_day (fiscal_year_value), 6, 17);
         end;

				/* 9999-12-31=FW999952, so we don't  */
				/* ..have to check for year 10000    */
         time_value.fw = fiscal_year_value * 100 + fiscal_week_value;
      end;
/* ***********************************+************************************* */
/*							       */
/*      Compute the month of the year, and day of the month, using the       */
/*	algorithm of Richard A. Stone; Communications of the ACM;	       */
/*		 Vol 13, No 10; October, 1970; p 621.		       */
/*							       */
/* ***********************************+************************************* */

      if rest_of____1 > (59 + leap_day) /* make Feb have 30 days.	       */
      then rest_of____1 = rest_of____1 + 2 - leap_day;
      rest_of____1 = rest_of____1 + 91;
				/* get pseudo-month_number	       */
      time_value.my = divide (rest_of____1, 30.55, 2);
      time_value.dm = rest_of____1
         - precision ((30.55 * time_value.my), 3, 0);
				/* pseudo-month_number * 30.55 gives */
				/* ..number of days before the first */
				/* ..day of this month.  ITS MAGIC!  */
      time_value.my = time_value.my - 2;
				/* Algorithm says subtract 2 to get  */
				/*  real month no.		       */
      time_value.leap_year = leap_day;
      return;			/* All done!		       */
   end fromclock;			/* <##> */ %page;
/* @@@@@@ int proc .. get_word_index				       */
/* ***********************************+************************************* */
/* ***********************************+************************************* */

/*   A portion of this routine also exists in convert_date_to_binary_.rd.    */

get_word_index: proc (Atoken, Atable) returns (fixed bin);	 /* <<##>> */

dcl Atoken	char (32),	/* word to look for		       */
    Atable	fixed bin;	/* kind off thing it must be	       */

dcl (lb, hb)	fixed bin;
dcl symb		char (32);
dcl cur_token	fixed bin;
dcl e_count	fixed bin;

      if (Atable = Language_table)
      then do;
         if (Atoken = "")		/* User wants process default.       */
         then return (time_defaults_$language_index);
         if (Atoken = "system_lang")
         then return (time_info_$default_language_index);
      end;
      if (Atable = Zone_table)
      then do;
         if (Atoken = "")		/* User wants process default.       */
         then return (time_defaults_$zone_index);
         if (Atoken = "system_zone")
         then do;
	  symb = sys_info$time_zone;
	  goto search;
         end;
      end;
      item_p = null ();
      symb = translate (Atoken, az, AZ);/* get to normal form	       */
search:
      ti_token_p = addr (time_info_$tokens);
      lb = 1;			/* set lower bound of search	       */
      hb = ti_token.count;		/* set upper bound of search	       */
      do while (lb <= hb);		/* as long as range is non-null      */
         cur_token = divide (lb + hb, 2, 17); /* find center of range	       */
         if (ti_token.symbol (cur_token) = symb)
         then do;
	  item_p = addrel (addr (time_info_$version),
	     ti_token.list_r (cur_token));
	  goto found_token;
         end;
         if (ti_token.symbol (cur_token) < symb)
         then lb = cur_token + 1;
         else hb = cur_token - 1;
      end;
      return (-1);			/* Tell caller name was not there    */

found_token:
      do e_count = 1 to item.count;
         if (Atable = item.table (e_count))
         then return (item.element (e_count));
      end;
      return (0);			/* Tell caller name was there,       */
				/* ..but not the kind she wanted.    */

   end get_word_index;		/* <##> */ %skip (5);
/* @@@@@@ int func .. make_fraction				       */
/* ***********************************+************************************* */
/* ***********************************+************************************* */
make_fraction: proc (interval, units) returns (float dec (20)); /* <<##>> */

dcl (interval, units) fixed bin (71);

dcl (fldA, fldB)	float dec (24);
dcl fldC		float dec (20);

      fldA = convert (fldA, interval);
      fldB = convert (fldB, units);
      fldC = fldA / fldB;
      return (fldC);

   end make_fraction;		/* <##> */ %page;
/* @@@@@@ int proc .. Multics_2_vc				       */
Multics_2_vc: proc (Mval, zname, zval, lval, cval); /* <<##>> */

dcl Mval		fixed bin (71),	/* Multics value		 [IN]  */
    zname		char (5),		/* zone name in which to work  [IN]  */
				/* ""=> zone-name(zval) is used      */
    zval		fixed bin,	/* zone index of value	 [IN]  */
				/* 0 => zname is a zone differential */
				/*  and is converted.	       */
				/* >0=> zname assumed to match zval  */
    lval		fixed bin,	/* language in which working	 [IN]  */
				/* (needed when zname="")	       */
    1 cval	like cal_val;	/* virtual value, zoned	 [OUT] */

/* Convert a Multics clock value (org 1901-01-01 00:00:00.000000 gmt Tue)    */
/* into a virtual clock value (org 0001-01-01__00:00:00.000000_gmt_Sat) and  */
/* then adjust to the indicated time zone.			       */
/* The results are placed in a structure which contains		       */
/*   x	the adjusted value.					       */
/*  dx	the value to add to x to give GMT			       */
/*   z	the name of the zone related to dx			       */
/*  zi	the zone_index into ti_zone for this zone.		       */
/* J_G	which calendar system the value is in			       */

dcl (
    error_table_$dt_date_too_big,	/* <##> */
    error_table_$dt_date_too_small,	/* <##> */
    error_table_$dt_year_too_big,	/* <##> */
    error_table_$dt_year_too_small	/* <##> */
    )		fixed bin (35) ext static;

      lcode = 0;
/**** First adjust to an absolute virtual clock value, check range.	       */
      cval.x = Mval + M_vc_adjust;
      if (cval.x < 0)
      then do;			/* 0001-01-01__00:00:00.000000_gmt   */
         lcode = binary (error_table_$dt_date_too_small);
         return;
      end;
      if (cval.x >= max_vc_value)
      then do;			/* 9999-12-31__23:59:59.999999_gmt   */
         lcode = binary (error_table_$dt_date_too_big);
         return;
      end;
/**** Now zone adjust the value and keep associated info.		       */
/**** If zval=0 then zname is a zone differential.  This is a signed number  */
/****  pair (sHHMM) representing the hour and minute adjustment to GMT to    */
/****  given the needed local value, i.e. -0700 is Mountain Standard Time,   */
/****  +0530 is India Standard Time.				       */
      if (zval = 0)
      then do;
         cval.dx
	  = convert (cval.dx, substr (zname, 2, 2)) * 3600000000
	  + convert (cval.dx, substr (zname, 4, 2)) * 60000000;
         if (substr (zname, 1, 1) = "+")
         then cval.dx = -cval.dx;
      end;
      else cval.dx = ti_zone.delta (1, zval);
      cval.x = cval.x - cval.dx;
      cval.zi = zval;
      cval.z = zname;
      if (cval.z = "")
      then cval.z = ti_zone.short (lval, cval.zi);

/**** Now make sure it still is within bounds and see which calendar its in. */
      if (cval.x < begin_Special)	/* < 1901-01-01 00:00:00.000000      */
      then do;
         if (cval.x < begin_Gregorian)	/* < 1582-10-15 00:00:00.000000      */
         then do;
	  if (cval.x < 0)		/*    (ZAT == Zone Adjusted Time)    */
	  then do;		/* < 0001-01-01 00:00:00.000000 ZAT  */
	     lcode = binary (error_table_$dt_year_too_small);
	     return;
	  end;
	  cval.J_G = Julian;	/*   0001-01-01 thru 1582-10-04      */
         end;
         else cval.J_G = Gregorian;	/*   1582-10-15 thru 1900-12-31      */
      end;
      else if (cval.x < end_Special)
      then cval.J_G = Special;	/*   1901-01-01 thru 2099-12-31      */
      else do;
         if (cval.x >= max_vc_value)
         then do;			/* > 9999-12-31 23:59:59.999999 ZAT  */
	  lcode = binary (error_table_$dt_year_too_big);
	  return;
         end;
         cval.J_G = Gregorian;	/*   2100-01-01 thru 9999-12-31      */
      end;

      return;

   end Multics_2_vc;		/* <##> */ %skip (3);
/* @@@@@@ int proc .. proc_selector				       */
/* ***********************************+************************************* */
/* ***********************************+************************************* */
proc_selector: proc;		/* <<##>> */
dcl (
    error_table_$bad_conversion,	/* <##> */
    error_table_$dt_bad_format_selector,/* <##> */
    error_table_$picture_bad,		/* <##> */
    error_table_$picture_scale,	/* <##> */
    error_table_$picture_too_big,	/* <##> */
    error_table_$size_error		/* <##> */
    )		fixed bin (35) ext static;
				/* format: off */
dcl selector	(43)char(2)int static options (constant) init (
	"Hc",	/* 01 "(8)Z9"	Hour/calendar		       */
	"Hd",	/* 02 "99"	Hour/day			       */
	"Hh",	/* 03 "99"	Hour/half-day		       */
	"Hm",	/* 04 "(3)Z9"	Hour/month		       */
	"Hw",	/* 05 "(3)Z9"	Hour/week			       */
	"Hy",	/* 06 "(4)Z9"	Hour/year			       */
	"MH",	/* 07 "99"	Minute/Hour		       */
	"Mc",	/* 08 "(10)Z9"	Minute/calendar		       */
	"Md",	/* 09 "(4)Z9"	Minute/day		       */
	"Mm",	/* 10 "(5)Z9"	Minute/month		       */
	"Mw",	/* 11 "(5)Z9"	Minute/week		       */
	"My",	/* 12 "(6)Z9"	Minute/year		       */
	"SH",	/* 13 "(4)Z9"	Second/Hour		       */
	"SM",	/* 14 "99"	Second/Minute		       */
	"Sc",	/* 15 "(12)Z9"	Second/calendar		       */
	"Sd",	/* 16 "(5)Z9"	Second/day		       */
	"Sm",	/* 17 "(8)Z9"	Second/month		       */
	"Sw",	/* 18 "(6)Z9"	Second/week		       */
	"Sy",	/* 19 "(12)Z9"	Second/year		       */
	"UH",	/* 20 "(10)Z9"	Usecond/Hour (microsecond)	       */
	"UM",	/* 21 "(8)Z9"	Usecond/Minute		       */
	"US",	/* 22 "(5)Z9"	Usecond/Second		       */
	"Uc",	/* 23 "(18)Z9"	Usecond/calendar		       */
	"Ud",	/* 24 "(11)Z9"	Usecond/day		       */
	"Um",	/* 25 "(13)Z9"	Usecond/month		       */
	"Uw",	/* 26 "(12)Z9"	Usecond/week		       */
	"Uy",	/* 27 "(14)Z9"	Usecond/year		       */
	"da",	/* 28 "(8)X"	day abbrev		       */
	"dc",	/* 29 "(7)Z9"	day/calendar		       */
	"dm",	/* 30 "99"	day/month			       */
	"dn",	/* 31 "(32)X"	day name			       */
	"dw",	/* 32 "9"		day/week			       */
	"dy",	/* 33 "999"	day/year			       */
	"fw",	/* 34 "OOO999"	fiscal week		       */
	"ma",	/* 35 "(8)X"	month abbrev		       */
	"mi",	/* 36 "a"		meridiem indicator		       */
	"mn",	/* 37 "(32)X"	month name		       */
	"my",	/* 38 "99"	month/year		       */
	"yc",	/* 39 "OO99"	year/calendar		       */
	"za",	/* 40 "(8)X"	zone abbrev		       */
	"zn",	/* 41 "(64)X"	zone name			       */
	"fi",	/* 42 "(8)X"	fiscal indicator		       */
	"zd");	/* 43 "s9999"	zone differential		       */
				/* format: on */

dcl Ar_ct		fixed bin;
dcl assign_	entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin,
		fixed bin (35));
dcl bit1		bit (1) unaligned based;
dcl buff		(20) fixed binary;
dcl conversion	condition;
dcl ftype		fixed bin;
dcl fx2		fixed bin;
dcl i1		fixed bin;
dcl i2		fixed bin;
dcl ii		fixed bin;
dcl pack_picture_	options (variable);
/**** pack_picture_ declares itself to be "(char(1), fixed bin, char(1))",   */
/****  but it does not play straight with it's arguments.		       */
dcl Pic		char (64);
dcl PIC		char (64);
dcl picl		fixed bin;
dcl picp		ptr;
dcl pictured	char (256) var;
dcl picture_code	fixed bin (15);	/* I think it's weird also.	       */
dcl picture_info_	entry (char (*) aligned, ptr, fixed bin (15));
dcl picv		char (picl) based (picp);
dcl Pic_l		fixed bin;
dcl pi_p		ptr;
dcl size		condition;
dcl target	char (128);
dcl target_length	fixed bin (35);
dcl temp		char (64);
dcl Ol_sw		bit (1);
dcl Zl_ct		fixed bin;
dcl Zr_ct		fixed bin;

dcl map_type	(24:28) fixed bin int static init (
		42,		/* character		       */
		18,		/* real fixed dec		       */
		22,		/* cplx fixed dec		       */
		20,		/* real float dec		       */
		24);		/* cplx float dec		       */

dcl 1 pi		like picture_image based (pi_p);
%include picture_image;


/**** see if a picture is here				       */
      Pic = "";
      Pic_l = 0;
      pi_p = addr (buff);
      pi.scale = 0;
      format_i = format_i + 1;	/* skip the "^"		       */
      if (substr (lformat, format_i, 1) = "^")
      then do;			/* Just wants a "^"		       */
         format_i = format_i + 1;
         lresult = lresult || "^";
exit_selector:
         return;
      end;
      if (substr (lformat, format_i, 1) = "<")
      then do;			/* imbedded ^<keyword>	       */
/****    Replace the keyword reference with it's associated string.	       */
/****    This is done in such a manner so as to avoid any string temporaries */
/****    other than the compiler assigned one to receive cv_fmt_kwd output.  */
/****    The "----------" comments below are intended to show how the pieces */
/****    of the string "BBB^<kk>AAA" are manipulated.  xxx is converted kk.  */
         errloc = format_i+1;		/* point to beginning of keyword     */
				/* ..in case an error occurs	       */
         temp_512_v			/* ------------"kk"		       */
	  = before (substr (lformat, errloc), ">");
         i = min(errlocad.n+1, hbound(errlocad.keywords,1));
         errlocad.start(i) = format_i-1;
         errlocad.enclosed_key(i) = 1;
         errlocad.old_len(i) = length(temp_512_v) + length("^<>");
				/* remember start/length of keyword. */
         temp_512_v			/* ------------"xxx"	       */
	  = cv_fmt_kwd (temp_512_v);
         if (lcode ^= 0)
         then goto err_exit;
         errlocad.new_len(i) = length(temp_512_v);
         errlocad.n = i;		/* remember length of keyword	       */
				/* replacement value, so errloc can  */
				/* be adjusted if an error occurs.   */
         temp_512_v = temp_512_v	/* ------------"xxxAAA"	       */
	  || after (substr (lformat, errloc), ">");
         format_i = format_i -1;	/* set scan index properly	       */
         lformat			/* ------------"BBB"	       */
	  = substr (lformat, 1, format_i-1);
         lformat			/* ------------"BBBxxxAAA"	       */
	  = lformat || temp_512_v;
         goto exit_selector;		/* and that's all we do, no output   */
      end;
      i = verify (substr (lformat, format_i), "abcefksvxzXZ9().,-+O012345678");
      if (i = 0)
      then i = length (lformat) - format_i + 1;
      else i = i - 1;
/**** There is some overlap between valid picture characters and selector    */
/**** characters.  This is not an ambiguity, but does require this special   */
/**** handling, since determining the picture length is very simplistic.     */
      if (substr (lformat, format_i + i - 1, length ("f")) = "f")
      then i = i - 1;
      else if (substr (lformat, format_i + i - 1, length ("zn")) = "zn")
         | (substr (lformat, format_i + i - 1, length ("zd")) = "zd")
      then i = i - 1;
      else if (i > 1) then do;	 /* ^za can be followed by .,+- et al*/
         ii = index(substr (lformat, format_i, i), "za");
         if ii > 0 
         then i = ii-1;
         end;
      if (i > 0)
      then do;
         Pic_l = i;
         if (Pic_l > length (Pic))
         then do;
	  lcode = binary (error_table_$picture_too_big);
	  errloc = format_i;
	  goto err_exit;
         end;
         Pic = substr (lformat, format_i, Pic_l);
         picloc = format_i;		/* in case there is an error later   */
         format_i = format_i + Pic_l;
      end;
      if (format_i ^< length (lformat))
      then do;			/* no room for selector	       */
         errloc = length (lformat) + 1;
         goto bad_selector;
      end;
      errloc = format_i;		/* set up in case failure next       */
      i = index (string (selector), substr (lformat, format_i, 2));
      if (i = 0)
      then do;
bad_selector:
         lcode = binary (error_table_$dt_bad_format_selector);
err_exit:
         errlocad.unadjusted_errloc = errloc;
         do i = lbound(errlocad.keywords,1) to errlocad.n;
	  if errloc > errlocad.start(i) then do;
	     if errloc > errlocad.start(i) - 1 + errlocad.new_len(i)
	     then errloc = errloc - errlocad.new_len(i)+errlocad.old_len(i);
	     else errloc = errlocad.start(i) + 
		         errlocad.enclosed_key(i)*length("^<");
	  end;
         end;
         return;
      end;
      ftype = divide (i + 1, 2, 17);
      format_i = format_i + 2;
      on condition (conversion)	/* just in case he blows it	       */
         begin;
	  lcode = binary (error_table_$bad_conversion);
	  goto err_exit;
         end;
      on condition (size)		/* just in case he blows it	       */
         begin;
	  lcode = binary (error_table_$size_error);
	  goto err_exit;
         end;
Pic_supplied:
      if (Pic ^= "")
      then do;
Pic_expand:
         picp = addr (Pic);
         picl = Pic_l;
         i = index (picv, "(");
         if (i > 0)
         then do;
	  if (i > 1)
	  then do;
	     if (substr (Pic, i - 1, length ("f")) = "f")
	     then goto Pic_expanded;	/* it's a scale factor	       */
	  end;
	  ii = index (picv, ")");
	  if (ii < i) | (ii = Pic_l)
	  then goto pic_syntax;
	  i1 = ii - i - 1;		/* length of the repeat number       */
	  i2 = convert (i2, substr (Pic, i + 1, i1));
	  Pic = substr (Pic, 1, i - 1)
	     || copy (substr (Pic, ii + 1, 1), i2 - 1)
	     || substr (Pic, ii + 1);
	  Pic_l = Pic_l - i1 - length ("()9") + i2;
	  goto Pic_expand;
         end;
Pic_expanded:
         Ar_ct = verify (reverse (substr (Pic, 1, Pic_l)), "X");
         if (Ar_ct = 0)
         then Ar_ct = Pic_l;
         else Ar_ct = Ar_ct - 1;
         if (Ar_ct > 0)
         then substr (Pic, Pic_l - Ar_ct + 1, Ar_ct) = copy ("x", Ar_ct);

         Zr_ct = verify (reverse (substr (Pic, 1, Pic_l)), "Z");
         if (Zr_ct ^= 0)		/* if its all Z's, use them left     */
         then do;
	  Zr_ct = Zr_ct - 1;
	  if (Zr_ct > 0)
	  then substr (Pic, Pic_l - Zr_ct + 1, Zr_ct) = copy ("9", Zr_ct);
         end;

         Zl_ct = verify (substr (Pic, 1, Pic_l), "Z");
         if (Zl_ct = 0)
         then Zl_ct = Pic_l;
         else Zl_ct = Zl_ct - 1;
         if (Zl_ct > 0)
         then substr (Pic, 1, Zl_ct) = copy ("z", Zl_ct);

/****    Os may appear scattered around in a picture.		       */
         if (index (substr (Pic, 1, Pic_l), "O") = 0)
         then Ol_sw = ""b;
         else do;			/* There is at least 1 O present     */
	  Ol_sw = "1"b;
	  PIC = Pic;		/* keep the original for reference.  */
	  i = index (PIC, "v");	/* ..The presence of a "v" does not  */
	  if (i ^= 0)		/* ..produce a result character, so  */
	  then do;		/* ..remove it.		       */
	     substr (PIC, i) = substr (PIC, i+1);
	     Pic_l = Pic_l - 1;
	  end;
/****       O's in the midst of z's cannot translate to 9's. Check for this  */
	  i = verify (Pic, "ZOz");
	  if (i = 0)
	  then i = Pic_l + 1;
	  if (i > 0)
	  then do;
	     i = i - 1;
	     substr (Pic, 1, i) = translate (substr (Pic, 1, i), "z", "O");
	  end;
	  Pic = translate (Pic, "9", "O");  /* make working copy "proper"  */
         end;

         call picture_info_ ((picv), pi_p, picture_code);
				/* let PL/I routine process it       */
         if (picture_code ^= 0)	/* Oh,			       */
         then do;			/* ...you didnt like that one!       */
	  if (picture_code = 434)
	  then lcode = binary (error_table_$picture_scale);
	  else if (picture_code < 434)
	  then lcode = binary (error_table_$picture_too_big);
	  else do;
pic_syntax:
	     lcode = binary (error_table_$picture_bad);
	  end;
	  errloc = picloc;
	  goto exit_selector;
         end;
         target_length = pi.prec + 262144 * (pi.scale - pi.scalefactor);
      end;
      fld24 = 0;
      if testing_format
      then goto exit_selector;
      goto sel (ftype); %page;
dcl pic25		pic "(25)-9";
dcl ch64		char (64) var; %skip (2);
sel_pic2:
      lresult = lresult || pic2;
      goto exit_selector;
sel_ascii:
      if (Pic_l = 0)
      then do;
         lresult = lresult || ch64;
         goto exit_selector;
      end;
      arg_p = addr (ch64);
      arg_t = 44;
      arg_l = length (ch64);
      goto sel_done;

sel_dec_pic:
      if (Pic_l = 0)
      then do;
         pic25 = fld24;
         lresult = lresult || ltrim (pic25);
         goto exit_selector;
      end;
sel_dec:
      arg_p = addr (fld24);
      arg_t = 20;
      arg_l = 24;
sel_done:
/**** picture_info_ has decided what type pack_picture_ is going to need     */
/**** to be able to get it's job done.  We must convert the value we have    */
/**** into that needed type.					       */
      begin;
/****    If a character value is assigned to a picture which has too few     */
/****    ..characters, assign_ signals stringsize.  The default system       */
/****    ..action is to truncate without comment.  We want that.  We don't   */
/****    ..want someone else's handler to get in the way so we make our own. */
         on stringsize system;
         call assign_ (addr (temp), map_type (pi.type), target_length,
	  arg_p, arg_t, arg_l);
dcl stringsize	condition;
      end;
      call pack_picture_ (addr (target) -> bit1, buff, temp);

      pictured = substr (target, 1, pi.varlength);

/**** The "O" processing must be done first, because the characters to be    */
/****  worked on are position dependant.			       */
      if Ol_sw
      then do;			/* copy all characters which did not */
         pictured = "";		/* ..have a "O" in the picture. Note */
         do i = 1 to Pic_l;		/* ..that "v" was removed above.     */
	  if (substr (PIC, i, 1) ^= "O")
	  then pictured = pictured || substr (target, i, 1);
         end;
      end;

      if (Ar_ct > 0)
      then do;			/* rtrim up to Ar_ct spaces	       */
         i = verify (reverse (pictured), " ");
         if (i = 0)
         then i = length (pictured);
         else i = i - 1;
         i = length (pictured) - min (i, Ar_ct);
         pictured = substr (pictured, 1, i);
      end;
      else if (Zr_ct > 0)		/* rtrim up to Zr_ct zeroes	       */
      then do;
         i = verify (reverse (pictured), "0");
         if (i = 0)
         then i = length (pictured);
         else i = i - 1;
         i = length (pictured) - min (i, Zr_ct);
         pictured = substr (pictured, 1, i);
      end;

      if (Zl_ct > 0)
      then do;			/* ltrim up to Zl_ct spaces	       */
         i = verify (pictured, " ");
         if (i = 0)
         then i = length (pictured);
         else i = i - 1;
         i = min (i, Zl_ct);
         if (i = length (pictured))
         then pictured = "";
         else pictured = substr (pictured, i + 1);
      end;

/**** After all that, add what's left to the string being built.	       */
      lresult = lresult || pictured;
      goto exit_selector; %page;
/**** Usecond is a 0-based quantity.  Thus any of the 1-based quantities     */
/****  will have to have 1 subtracted in order to "fit".		       */
sel (23):				/* "Uc", "(18)Z9"  Usec of calendar  */
      fld24 = cal_val.x;		/* Uc is 0-based		       */
      goto sel_dec_pic;

sel (27):				/* "Uy", "(14)Z9"	Usecond of year  */
      fld24 = time_value.dy - 1;	/*  dy is 1-based		       */
      goto sel (24);

sel (25):				/* "Um", "(13)Z9	Usecond of month */
      fld24 = time_value.dm - 1;	/* dm is 1-based		       */
      goto sel (24);

sel (26):				/* "Uw", "(12)Z9"	Usecond of week  */
      fld24 = time_value.dw - 1;	/* dw is 1-based  */

sel (24):				/* "Ud", "(11)Z9"	Usecond of day   */
      fld24 = fld24 * 24 + time_value.Hd; /* Hd is 0-based  */

sel (20):				/* "UH", "(10)Z9"	Usecond of Hour  */
      fld24 = fld24 * 60 + time_value.MH; /* MH is 0-based		       */

sel (21):				/* "UM", "(8)Z9"	Usecond of Minute*/
      fld24 = fld24 * 60 + time_value.SM; /* SM is 0-based		       */

sel (22):				/* "US", "(5)Z9"	Usecond of Second*/
      fld24 = fld24 * 1e6 + time_value.US; /* US is 0-based		       */
      goto sel_dec_pic;

sel (15):				/* "Sc", "(12)Z9"	Sec of calendar  */
      fld24 = convert (fld24, cal_val.x) / 1e6;
      goto sel_dec_pic;

sel (19):				/* "Sy", "(12)Z9"	Second of year   */
      fld24 = time_value.dy - 1;
      goto sel (16);

sel (17):				/* "Sm", "(8)Z9"	Second of month  */
      fld24 = time_value.dm - 1;
      goto sel (16);

sel (18):				/* "Sw", "(6)Z9"	Second of week   */
      fld24 = time_value.dw - 1;

sel (16):				/* "Sd", "(5)Z9"	Second of day    */
      fld24 = fld24 * 24 + time_value.Hd;

sel (13):				/* "SH", "(4)Z9"	Second of Hour   */
      fld24 = fld24 * 60 + time_value.MH;
      fld24 = fld24 * 60 + time_value.SM;
SM_fraction:
      if (pi.scale > 0)
      then fld24 = fld24 + convert (fld24, time_value.US) / 1e6;
      goto sel_dec_pic;

sel (14):				/* "SM", "99"	Second of Minute */
      if (Pic_l > 0)
      then do;
         fld24 = time_value.SM;
         goto SM_fraction;
      end;
      pic2 = time_value.SM;
      goto sel_pic2;

sel (08):				/* "Mc", "(10)Z9"	Min of calendar  */
      fld24 = convert (fld24, cal_val.x) / 6e7;	/* 60*1e6		       */
      goto sel_dec_pic;

sel (12):				/* "My", "(6)Z9"	Minute of year   */
      fld24 = time_value.dy - 1;
      goto sel (09);

sel (10):				/* "Mm", "(5)Z9"	Minute of month  */
      fld24 = time_value.dm - 1;
      goto sel (09);

sel (11):				/* "Mw", "(5)Z9"	Minute of week   */
      fld24 = time_value.dw - 1;

sel (09):				/* "Md", "(4)Z9"	Minute of day    */
      fld24 = fld24 * 24 + time_value.Hd;
      fld24 = fld24 * 60 + time_value.MH;
MH_fraction:
      if (pi.scale > 0)
      then do;
         fld24 = fld24 + convert (fld24, time_value.SM) / 60;
         fld24 = fld24 + convert (fld24, time_value.US) / 6e7; /* 60*1e6     */
      end;
      goto sel_dec_pic;

sel (07):				/* "MH", "99"	Minute of Hour   */
      if (Pic_l > 0)
      then do;
         fld24 = time_value.MH;
         goto MH_fraction;
      end;
      pic2 = time_value.MH;
      goto sel_pic2;

sel (01):				/* "Hc", "(8)Z9"	Hour of calendar */
      fld24 = convert (fld24, cal_val.x) / 36e8;	/* 60*60*1e6	       */
      goto sel_dec_pic;

sel (06):				/* "Hy", "(4)Z9"	Hour of year     */
      fld24 = time_value.dy - 1;
      goto Hday;

sel (04):				/* "Hm", "(3)Z9"	Hour of month    */
      fld24 = time_value.dm - 1;
      goto Hday;

sel (05):				/* "Hw", "(3)Z9"	Hour of week     */
      fld24 = time_value.dw - 1;
Hday:
      fld24 = fld24 * 24 + time_value.Hd;
Hd_fraction:
      if (pi.scale > 0)
      then do;
         fld24 = fld24 + convert (fld24, time_value.MH) / 60;
         fld24 = fld24 + convert (fld24, time_value.SM) / 36e2; /* 60*60     */
         fld24 = fld24 + convert (fld24, time_value.US) / 36e8; /* 60*60*1e6 */
      end;
      goto sel_dec_pic;

sel (02):				/* "Hd", "99"	Hour of day      */
      if (Pic_l > 0)
      then do;
         fld24 = time_value.Hd;
         goto Hd_fraction;
      end;
      pic2 = time_value.Hd;
      goto sel_pic2;

sel (03):				/* "Hh", "99"	Hour of half-day */
      fx2 = time_value.Hd;
      if (fx2 > 11) then fx2 = fx2 - 12;
      if (fx2 = 00) then fx2 = 12;
      if (Pic_l > 0)
      then do;
         fld24 = fx2;
         goto Hd_fraction;
      end;
      pic2 = fx2;
      goto sel_pic2;

sel (29):				/* "dc", "(7)Z9"	day of calendar  */
      fld24 = time_value.dc;
dc_fraction:
      if (pi.scale > 0)
      then do;
         fld24 = fld24 + convert (fld24, time_value.Hd) / 24;
         fld24 = fld24 + convert (fld24, time_value.MH) / 1440;  /* 24*60    */
         fld24 = fld24 + convert (fld24, time_value.SM) / 864e2; /* ..*60    */
         fld24 = fld24 + convert (fld24, time_value.US) / 864e8; /* ..*1e6   */
      end;
      goto sel_dec_pic;

sel (33):				/* "dy", "999"	day of year      */
      if (Pic_l = 0)
      then do;			/* if no specification,	       */
         Pic = "999";		/* ..we shall supply the default     */
         Pic_l = 3;			/* ..and go fake it.	       */
         goto Pic_expand;		/* ....(It'll be back)	       */
      end;			/* This is not optimized in any way  */
      fld24 = time_value.dy;		/* ..because it is felt to be a low  */
      goto dc_fraction;		/* ..usage datum.		       */

sel (30):				/* "dm", "99"	day of month     */
/****   Given: clock ^99v.9999dm feb15m ut -zone z +12hr		       */
/**** you get: 15.5000					       */
/**** i.e. 12 hours into feb15 is .5 day			       */

      if (Pic_l > 0)
      then do;
         fld24 = time_value.dm;
         goto dc_fraction;
      end;
      pic2 = time_value.dm;
      goto sel_pic2;

sel (32):				/* "dw", "9"	day of week      */
      if (Pic_l > 0)
      then do;
         fld24 = time_value.dw;
         goto dc_fraction;
      end;
      lresult = lresult || substr ("1234567", time_value.dw, 1);
      goto exit_selector;

sel (28):				/* "da", "(8)X"	day abbrev       */
      if format_max
      then do;
         ch64 = "";
         do i = 1 to 7;
	  if length (ch64) < length (ti_day.short (lang_index, i))
	  then ch64 = ti_day.short (lang_index, i);
         end;
      end;
      else ch64 = ti_day.short (lang_index, time_value.dw);
      goto sel_ascii;

sel (31):				/* "dn", "(15)X"	day name	       */
      if format_max
      then do;
         ch64 = "";
         do i = 1 to 7;
	  if length (ch64) < length (ti_day.long (lang_index, i))
	  then ch64 = ti_day.long (lang_index, i);
         end;
      end;
      else ch64 = ti_day.long (lang_index, time_value.dw);
      goto sel_ascii;

sel (42):				/* "fi", "aa"	fiscal indicator */
      ch64 = ti_word.word (lang_index, tiw_FiscalIndicator);
      goto sel_ascii;

sel (34):				/* "fw", "OOO999"	fiscal week      */
      if (Pic_l = 0)
      then do;			/* if no specification,	       */
         Pic = "OOO999";		/* ..we shall supply the default     */
         Pic_l = 6;			/* ..and go fake it.	       */
         goto Pic_expand;		/* ....(It'll be back)	       */
      end;
      fld24 = time_value.fw;
      goto sel_dec_pic;

sel (38):				/* "my", "99"	month of year    */
      if (Pic_l > 0)
      then do;
         fld24 = time_value.my;
         if (pi.scale ^= 0)
         then do;
/****       How many days in the month?				       */
	  if (time_value.my = FEBRUARY)
	  then unit_size = 28 + calc_leap_day ((time_value.yc));
	  else unit_size = days_in_month (time_value.my);
/****       How many microseconds is that? (-1 bias helps roundoff problem)  */
	  unit_size = (unit_size * 864) * 100000000 - 1;
	  t_interval = time_value.dm - 1;
	  t_interval = t_interval * 024 + time_value.Hd;
	  t_interval = t_interval * 060 + time_value.MH;
	  t_interval = t_interval * 060 + time_value.SM;
	  t_interval = t_interval * 1000000 + time_value.US;
	  fld24 = fld24 + make_fraction (t_interval, unit_size);
         end;
         goto sel_dec;
      end;
      pic2 = time_value.my;
      goto sel_pic2;

sel (37):				/* "mn", "(15)X"	month name       */
      if format_max
      then do;
         ch64 = "";
         do i = 1 to 12;
	  if length (ch64) < length (ti_month.long (lang_index, i))
	  then ch64 = ti_month.long (lang_index, i);
         end;
      end;
      else ch64 = ti_month.long (lang_index, time_value.my);
      goto sel_ascii;

sel (35):				/* "ma", "(8)X"	month abbrev     */
      if format_max
      then do;
         ch64 = "";
         do i = 1 to 12;
	  if length (ch64) < length (ti_month.short (lang_index, i))
	  then ch64 = ti_month.short (lang_index, i);
         end;
      end;
      else ch64 = ti_month.short (lang_index, time_value.my);
      goto sel_ascii;

sel (39):				/* "yc", "OO99"	year of calendar */
      if (Pic_l > 0)
      then do;
         fld24 = time_value.yc;
         if (pi.scale ^= 0)
         then do;
/****       How many days in the year?				       */
	  if (time_value.yc = 1582)
	  then unit_size = 355;
	  else unit_size = 365 + calc_leap_day (time_value.yc);
/****       How many microseconds is that? (-1 bias helps roundoff problem)  */
	  unit_size = (unit_size * 864) * 100000000 - 1;
	  t_interval = time_value.dy - 1;
	  t_interval = t_interval * 024 + time_value.Hd;
	  t_interval = t_interval * 060 + time_value.MH;
	  t_interval = t_interval * 060 + time_value.SM;
	  t_interval = t_interval * 1000000 + time_value.US;
	  fld24 = fld24 + make_fraction (t_interval, unit_size);
         end;
         goto sel_dec;
      end;
      pic2 = mod (time_value.yc, 100);
      goto sel_pic2;

sel (36):				/* "mi", "a"	meridiem indic.  */
      if (time_value.Hd < 12)
      then ch64 = "A";
      else ch64 = "P";
      goto sel_ascii;

sel (41):				/* "zn", "(64)X"	zone name	       */
      if format_max
      then do;
         ch64 = "";
         do i = 1 to ti_zone.number_zone;
	  if length (ch64) < length (ti_zone.long (lang_index, i))
	      then ch64 = ti_zone.long (lang_index, i);
         end;
      end;
      else ch64 = ti_zone.long (lang_index, time_value.zone_index);
      goto sel_ascii;

sel (40):				/* "za", "(8)X"	zone abbrev      */
      if format_max
      then do;
         ch64 = "";
         do i = 1 to ti_zone.number_zone;
	  if length (ch64) < length (ti_zone.short (lang_index, i))
	  then ch64 = ti_zone.short (lang_index, i);
         end;
      end;
      else ch64 = ti_zone.short (lang_index, time_value.zone_index);
      goto sel_ascii;

sel (43):				/* "zd", "s9999"	z. differential  */
      ch64 = zone_dif (ti_zone.delta (lang_index, time_value.zone_index));
      goto sel_ascii;

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;

   end proc_selector;		/* <##> */ %page;
/* @@@@@@ int proc .. vc_2_Multics				       */
/* ***********************************+************************************* */
/* ***********************************+************************************* */
vc_2_Multics: proc (cval, Mval);	/* <<##>> */

dcl 1 cval	like cal_val,	/* virtual value		   [In]*/
    Mval		fixed bin (71);	/* Multics value		  [Out]*/

dcl (
    error_table_$dt_date_too_big,	/* <##> */
    error_table_$dt_date_too_small	/* <##> */
    )		fixed bin (35) ext static;

      Mval = 0;
      if (cval.x > max_vc_value)
      then lcode = binary (error_table_$dt_date_too_big);
      else if (cval.x < 0)
      then lcode = binary (error_table_$dt_date_too_small);
      else Mval			/* make GMT Multics value	       */
	    = cval.x - M_vc_adjust + cval.dx;
      return;

   end vc_2_Multics;		/* <##> */ %page;
/* @@@@@@ int proc .. ymd_to_days				       */
/* ************************************************************************* */
/**** This converts either yc,my,dm  or yc,dy  into dc.	fw is ignored    */
/**** cal_val.J_G is set to reflect Julian or Gregorian		       */
/* ************************************************************************* */

ymd_to_days: proc;			/* <<##>> */

dcl adjustment	fixed bin;
dcl (
    error_table_$dt_bad_dm,		/* <##> */
    error_table_$dt_bad_dy,		/* <##> */
    error_table_$dt_bad_my,		/* <##> */
    error_table_$dt_date_not_exist	/* <##> */
    )		fixed bin (35) ext static;

/**** Figure out which calendar we are in.			       */
      cal_val.J_G = Gregorian;
      if (time_value.yc < 1583)
      then do;
         cal_val.J_G = Julian;
         if (time_value.yc = 1582)
         then do;			/* 1582 only had 355 days	       */
	  if (time_value.dy > 355)
	  then do;
	     lcode = binary (error_table_$dt_bad_dy);
	     return;
	  end;
	  if (time_value.dy > 277)	/* > 1582-10-04		       */
	     | (time_value.my > OCTOBER)
	  then cal_val.J_G = Gregorian;
	  else if (time_value.my = OCTOBER)
	  then do;
	     if (time_value.dm > 14)
	     then cal_val.J_G = Gregorian;
	     else if (time_value.dm > 4)
	     then do;
	        lcode = binary (error_table_$dt_date_not_exist);
	        return;
	     end;
	  end;
         end;
      end;
/**** Break down the date into the cycles it contains and find if leap year. */
      A, B, C = 1;
      lyear = time_value.yc - 1;	/* yc is 1-based, we need 0-based    */
      if (cal_val.J_G = Julian)
      then num_of__400s, num_of__100s = 0;
      else do;
         num_of__400s = divide (lyear, 400, 17);
         lyear = lyear - num_of__400s * 400;
         if (lyear = 399) then C = 0;

         num_of__100s = divide (lyear, 100, 17);
         lyear = lyear - num_of__100s * 100;
         if (lyear = 99) then B = 0;
      end;
      num_of____4s = divide (lyear, 4, 2);
      num_of____1s = lyear - num_of____4s * 4;

      if (num_of____1s >= 3)		/* =4 on last day of leap year       */
      then A = 0;
      leap_day = 1 - A + B - C;
/**** figure how many days in calendar prior to this year.		       */
      lclock_days
         = num_of__400s * 146097
         + num_of__100s * 36524
         + num_of____4s * 1461
         + num_of____1s * 365;

      if (time_value.dy > 0)
      then do;			/* day-in-year is given	       */
/****    Make sure day-in-year is a valid #. 1582 only has 355 days.	       */
         if (time_value.dy > 365 + leap_day)
	  | (time_value.yc = 1582 & time_value.dy > 355)
         then do;			/* not valid day-in-year	       */
	  lcode = binary (error_table_$dt_bad_dy);
	  return;
         end;

/****    The Gregorian cycles don't know anything about any missing 10 days. */
/****    The convention used here is that the days are numbered from 1:355   */
/****    in 1582.  Thus the last part of 1582 needs to be pushed up by 10 so */
/****    it falls in the right place in the cycle.		       */
         if (time_value.yc = 1582) & (time_value.dy > 277)
         then adjustment = 10;	/* kept separate for debug display   */
         else adjustment = 0;
/****    NOTE1: The base of the Gregorian cycles is 2 days different from    */
/****    the base of the Julian cycle.  We must adjust the numbers so that   */
/****    the day-in-calendar of 1582-10-04 is 1 less that of 1582-10-15,     */
/****    since this is the way it occurred.			       */
         if (cal_val.J_G = Gregorian)
         then lclock_days = lclock_days + 2;

         lclock_days = lclock_days + adjustment + time_value.dy;
      end;
      else do;
         if (time_value.my < 1)
	  | (time_value.my > 12)
         then do;			/* month must be 1:12	       */
	  lcode = binary (error_table_$dt_bad_my);
	  return;
         end;
         if (time_value.dm < 1)	/* N days per month		       */
	  | (time_value.dm > days_in_month (time_value.my)
	  + fixed (time_value.my = FEBRUARY) * leap_day)
         then do;			/* day must be 1:(SizeOfMonth)       */
	  lcode = binary (error_table_$dt_bad_dm);
	  return;
         end;
         lclock_days = lclock_days + before_month (time_value.my)
	  + leap_day * fixed (time_value.my > FEBRUARY) + time_value.dm;
         if (cal_val.J_G = Gregorian)	/* See NOTE1 above		       */
         then lclock_days = lclock_days + 2;
      end;

   end ymd_to_days;			/* <##> */ %page;
dcl (
    Gregorian	init (1),
    Julian	init (2),
    Special	init (3),
    None		init (4),
    FEBRUARY	init (2),
    MARCH		init (3),
    OCTOBER	init (10)
    )		fixed bin int static options (constant);

dcl (A, B, C)	fixed bin;
dcl lclock_days	fixed bin (27);
dcl leap_day	fixed bin;	/* number of Feb 29's in this year.  */
dcl lyear		fixed bin (35);
dcl rest_of__400	fixed bin;	/* days left from  400 year cycle    */
dcl rest_of__100	fixed bin;	/* days left from  100 year cycle    */
dcl rest_of____4	fixed bin;	/* days left from    4 year cycle    */
dcl rest_of____1	fixed bin;	/* days left from    1 year cycle    */

dcl num_of__400s	fixed bin;	/* number of  400 year cycles	       */
dcl num_of__100s	fixed bin;	/* number of  100 year cycles	       */
dcl num_of____4s	fixed bin;	/* number of    4 year cycles	       */
dcl num_of____1s	fixed bin;	/* number of      years left	       */
dcl cur_unit	fixed bin;
dcl day_adjust	fixed bin;
dcl diw		fixed bin;
dcl fb24		fixed bin (24);
dcl fiscal_week_value fixed bin (24);
dcl fiscal_year_value fixed bin (24);
dcl unit_sizes	(3:8) fixed bin (71) int static options (constant) init (
		6048e8, 864e8, 36e8, 6e7, 1e6, 1);
   /***		wk      da     hr    min  sec  Usec		       */
dcl temp_clock	fixed bin (71);	/* holds a Multics clock value       */
dcl arg_l		fixed bin (35);
dcl arg_p		ptr;
dcl arg_t		fixed bin;
dcl AZ		char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl az		char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");

dcl 1 cal_val,			/* x+dx gives virtual clock in GMT   */
      2 x		fixed bin (71),	/* calendar value		       */
      2 dx	fixed bin (71),	/* delta			       */
      2 z		char (5),		/* zone it's in		       */
      2 zi	fixed bin,	/* zone_index of cal_val.z	       */
				/* =0 => cal_val.z is differential   */
      2 J_G	fixed bin;	/* Julian/Gregorian indicator	       */
dcl 1 (ref_val, off_val) like cal_val;

/* format: off		       */
dcl (
/*		    0  1   2   3   4   5   6   7   8   9  10  11  12  13 */
/*		    . jan feb mar apr may jun jul aug sep oct nov dec .  */
    days_in_month init (0,031,028,031,030,031,030,031,031,030,031,030,031,000),
    before_month  init (0,000,031,059,090,120,151,181,212,243,273,304,334,365)
    )		(0:13) fixed bin int static options (constant);
				/* format: on		       */

dcl errloc	fixed bin;
dcl 1 errlocad	aligned,		/* error location adjustments.       */
      2 n		fixed bin,
      2 unadjusted_errloc
		fixed bin,
      2 keywords (20),
        3 start	fixed bin,	/* column in which keyword started.  */
        3 enclosed_key		/* =1 for ^<key>		       */
		fixed bin,	/* =0 for key		       */
        3 old_len	fixed bin,	/* length (original keyword).	       */
        3 new_len	fixed bin;	/* length (keyword value).	       */
dcl fld24		float dec (24);
dcl format_i	fixed bin;
dcl i		fixed bin;
dcl lang_index	fixed bin;
dcl lcode		fixed bin (35);
dcl lformat	char (512) var;
dcl temp_512_v	char (512) var;
dcl lresult	char (256) var;
dcl pic2		pic "99";
dcl pic4		pic "9999";
dcl picloc	fixed bin;
dcl sys_info$time_zone char (4) ext static;
dcl Tday		fixed bin;
dcl t_interval	fixed bin (71);
dcl Tmonth	fixed bin;
dcl Tusec		fixed bin (71);
dcl Tyear		fixed bin;
dcl unit_size	fixed bin (71);
dcl zone_index	fixed bin;

dcl 1 auto_time_value aligned like time_value;
dcl 1 auto_time_offset aligned like time_offset;
dcl 1 decoded_clock aligned like time_value;
dcl 1 decoded_ref	aligned like time_value;
dcl 1 fs_time_value aligned based,
      2 pad1	bit (20) unal,
      2 time	bit (36) unal,
      2 pad2	bit (16) unal;

dcl com_err_	entry options (variable);
dcl date_time_$set_time_defaults entry;

dcl (addr, addrel, after, before, convert, copy, divide, fixed, hbound, index,
    lbound, length, ltrim, min, mod, null, precision, reverse, string, substr,
    translate, trunc, unspec, verify) builtin; %page;
%include time_names;
%include time_info_search;
%include time_defaults_;
%include time_value;
%include time_offset;

/* ***********************************+************************************* */
/* During debugging, there is an internal procedure named binary which is    */
/*  central point thru which all error codes are set.  It allows me to catch */
/*  when error codes are being set.  Once debugging is complete, the	       */
/*  definition of it is deleted and the calls revert to the builtin, which   */
/*  has no effect on the generated code.			       */
/* ***********************************+************************************* */
dcl binary builtin;
   end date_time_;




		    encode_clock_value_.pl1         11/11/89  1137.0r w 11/11/89  0839.4      123444



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * 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   */

/* UPDATE HISTORY						       */
/* EL#   date	TR	comments				       */
/* ___ 83-12-15 -------- JAFalksen: created			       */
/* --- 84-11-08 -------- jaf: always return the zone for dcv$dcv	       */
/* --- 84-11-13 -------- jaf: adjust to new form of time_offset.dw data      */
/* --- 84-12-03 //////// jaf:					       */
/*   END HISTORY						       */

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* This is a write-thru into the new software.			       */
/*                                                                           */
/* Name: encode_clock_value_                                                 */
/*                                                                           */
/* This subroutine (obsolete) is a temporary replacement for correct         */
/* calling of the new date/time  facilities.  It relays data between         */
/* the user and the date/time system.                                        */
/*                                                                           */
/* ENTRY:  encode_clock_value_                                               */
/*                                                                           */
/* takes a  given month, day  of the month,  year, hour of  the day,         */
/* minute, second,  microsecond, and time zone  and returns a system         */
/* clock  reading.  When  given a  day of  the week,  it performs an         */
/* optional check  on the clock  reading to ensure that  it falls on         */
/* the given day.                                                            */
/*                                                                           */
/* A system clock  reading is encoded as the  number of microseconds         */
/* from  January 1,  1901 0000.0, Greenwich  mean time  (GMT) to the         */
/* given date, time, and time zone.                                          */
/*                                                                           */
/* USAGE:                                                                    */
/*    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));                        */
/*    call encode_clock_value_ (month, dom, year, hour, minute, sec-         */
/*       ond, microsecond, dow, zone, clock, code);                          */
/*                                                                           */
/* ENTRY:  encode_clock_value_$offsets                                       */
/*                                                                           */
/* This entry point takes a system clock reading, a day of the week,         */
/* and  year,  month, day,  hour,  minute, second,  and microsecond,         */
/* offset values.   The offset values may  be positive, negative, or         */
/* zero.  It returns a clock reading  that has been adjusted to fall         */
/* on the  given day of  the week, and  which is then  offset by the         */
/* given number of years, months, days, hours, minutes, seconds, and         */
/* microseconds.                                                             */
/*                                                                           */
/* USAGE:                                                                    */
/*    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));                                                           */
/*    call encode_clock_value_$offsets (clock_in, month_off,                 */
/*       day_off, year_off, hour_off, minute_off, second_off,                */
/*       microsec_off, dow_offset, zone, clock_out, code);                   */

encode_clock_value_: proc (month, dom, year, hour, minute, second, microsecond,
      dow, zone, clock, code);

dcl (
    month		fixed bin,
    dom		fixed bin,
    year		fixed bin,
    hour		fixed bin,
    minute	fixed bin,
    second	fixed bin,
    microsecond	fixed bin (71),
    dow		fixed bin,
    zone		char (3),
    clock		fixed bin (71),
    code		fixed bin (35)
    )		parm;

      tv.version = Vtime_value_3;
      tv.yc = year;
      tv.my = month;
      tv.dm = dom;
      tv.Hd = hour;
      tv.MH = minute;
      tv.SM = second;
      tv.US = microsecond;
      tv.fw = 0;
      tv.dw = dow;
      tv.dy = 0;
      tv.dc = 0;
      tv.za = zone;
      tv.zone_index = 0;
      call date_time_$to_clock (addr (tv), clock, code);
      return; %page;
offsets: entry (clock_in, month_off, day_off, year_off, hour_off, minute_off,
      second_off, microsec_off, dow_offset, zone, clock_out, code);

dcl (
    clock_in	fixed bin (71),
    month_off	fixed bin,
    day_off	fixed bin,
    year_off	fixed bin,
    hour_off	fixed bin,
    minute_off	fixed bin,
    second_off	fixed bin,
    microsec_off	fixed bin (71),
    dow_offset	fixed bin,
/*  zone		char (3),					       */
    clock_out	fixed bin (71)
/*  code		fixed bin (35)				       */
    )		parm;

      tof.version = Vtime_offset_2;
      unspec (tof.flag) = "0"b;
      if (dow_offset > 0)
      then do;
         tof.dw.flag = AFTER;
         tof.dw.val = dow_offset;
      end;
      else tof.dw.flag = UNUSED;
      if (year_off ^= 0)
      then do;
         tof.flag.yr = USED;
         tof.val.yr = year_off;
      end;
      if (month_off ^= 0)
      then do;
         tof.flag.mo = USED;
         tof.val.mo = month_off;
      end;
      if (day_off ^= 0)
      then do;
         tof.flag.da = USED;
         tof.val.da = day_off;
      end;
      if (hour_off ^= 0)
      then do;
         tof.flag.hr = USED;
         tof.val.hr = hour_off;
      end;
      if (minute_off ^= 0)
      then do;
         tof.flag.min = USED;
         tof.val.min = minute_off;
      end;
      if (second_off ^= 0)
      then do;
         tof.flag.sec = USED;
         tof.val.sec = second_off;
      end;
      if (microsec_off ^= 0)
      then do;
         tof.flag.Usec = USED;
         tof.val.Usec = microsec_off;
      end;
      call date_time_$offset_to_clock (addr (tof), clock_in, zone, clock_out, code);
      return;%page;
/*                                                                           */
/* Name: decode_clock_value_                                                 */
/*                                                                           */
/* This subroutine (obsolete) is a temporary replacement for correct         */
/* calling of the new date/time  facilities.  It relays data between         */
/* the user and the date/time system.                                        */
/*                                                                           */
/* ENTRY:  decode_clock_value_                                               */
/*                                                                           */
/* takes a given system clock reading and returns the month, the day         */
/* of the month, the year, the time of day, the day of the week, and         */
/* the local time zone.                                                      */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl decode_clock_value_ entry (fixed bin(71), fixed bin, fixed         */
/*       bin, fixed bin, fixed bin(71), fixed bin, char(3));                 */
/*    call decode_clock_value_ (clock, month, dom, year, tod, dow,           */
/*       zone);                                                              */
/*                                                                           */
/* ARGUMENTS:                                                                */
/* clock (Input)                                                             */
/*    is the system clock value to be decoded.                               */
/* month (Output)                                                            */
/*    is the month (January = 1, ..., December = 12).                        */
/* dom (Output)                                                              */
/*    is the day of the month, i.e., 1 to 31.                                */
/* year (Output)                                                             */
/*    is the year, e.g., 1978.                                               */
/* tod (Output)                                                              */
/*    is the time of day (number of microseconds since midnight).            */
/* dow (Output)                                                              */
/*    is the day of the week (Monday = 1, ..., Sunday = 7).                  */
/* zone (Output)                                                             */
/*    is a  three-character lowercase abbreviation of  the time zone         */
/*    currently used by this process (for example, mst, edt).                */
/*                                                                           */
/* NOTES:                                                                    */
/* If the clock value does not  lie within the range 0001-01-01 thru         */
/* 9999-12-31, then  zero values are returned  for month, dom, year,         */
/* tod, and dow.                                                             */
/*                                                                           */
/* ENTRY:  decode_clock_value_$date_time                                     */
/*                                                                           */
/* This entry point is given a  system clock reading and returns the         */
/* month, the day of the month,  the year, the hour, the minute, the         */
/* second, the  microseconds within a  second, the day  of the week.         */
/* The time zone in which the decoded clock reading is expressed may         */
/* be given as input, or the current time zone can be used.                  */
/*                                                                           */
/* USAGE:                                                                    */
/*    dcl decode_clock_value_$date_time 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(35));                  */
/*    call decode_clock_value_$date_time (clock, month, dom, year,           */
/*       hour, minute, second, microsecond, dow, zone, code);                */

decode_clock_value_: entry (clock, month, dom, year, tod, dow, zone);

dcl     tod		fixed bin(71);

      time_sw = "0"b;
      all_sw = "0"b;
      dcv_sw = "1"b;
      out_zone = "";

dcv_common:
      tv.version = Vtime_value_3;
      call date_time_$from_clock (clock, out_zone, addr (tv), lcode);
      if ^time_sw
      then do;
         month = tv.my;
         dom = tv.dm;
         year = tv.yc;
         dow = tv.dw;
      end;
      if ^dcv_sw
      then do;
         hour = tv.Hd;
         minute = tv.MH;
         second = tv.SM;
         microsecond = tv.US;
         code = lcode;
      end;
      else tod = tv.US
         + 1e6 * (tv.SM
         + 060 * (tv.MH
         + 060 * (tv.Hd)));
      if all_sw
      then do;
         days_in_clock = tv.dc - 693962;
         day_of_year = tv.dy;
      end;
      if (zone = "") | dcv_sw
      then zone = tv.za;
      return;%skip(2);
date_time: entry (clock, month, dom, year, hour, minute, second, microsecond,
	    dow, zone, code);
      time_sw = "0"b;
      all_sw = "0"b;
      dcv_sw = "0"b;
      out_zone = zone;
      goto dcv_common;

time: entry (clock, hour, minute, second, microsecond, zone, code);
      time_sw = "1"b;
      all_sw = "0"b;
      dcv_sw = "0"b;
      out_zone = zone;
      goto dcv_common;

all: entry (clock, month, dom, year, hour, minute, second, microsecond,
	dow, zone, days_in_clock, day_of_year, code);
dcl days_in_clock	fixed bin;
dcl day_of_year	fixed bin;
dcl lcode		fixed bin (35); 
      time_sw = "0"b;
      all_sw = "1"b;
      dcv_sw = "0"b;
      out_zone = zone;
      goto dcv_common;%page;
dcl time_sw	bit (1);
dcl all_sw	bit (1);
dcl dcv_sw	bit (1);
dcl out_zone	char (4);
		  
dcl date_time_$to_clock	entry (ptr, fixed bin(71), fixed bin(35));
dcl date_time_$offset_to_clock entry (ptr, fixed bin (71), char (*), fixed bin (71),
		fixed bin (35));
dcl date_time_$from_clock	entry (fixed bin(71), char(*), ptr, fixed bin(35));

dcl 1 tv		like time_value;
dcl 1 tof		like time_offset;

dcl (addr, unspec) builtin;

%include time_value;
%include time_offset;

   end encode_clock_value_;




		    set_system_time_zone_.pl1       11/11/89  1137.0rew 11/11/89  0839.4       32796



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


/****^  HISTORY COMMENTS:
  1) change(87-03-26,Lippard), approve(87-04-27,MCR7673),
     audit(87-05-15,Fawcett), install(87-05-26,MR12.1-1036):
     Written by Jim Lippard.
                                                   END HISTORY COMMENTS */

/* This program sets the system time zone. */
set_system_time_zone_: proc (P_time_zone, P_code);

	dcl     P_time_zone		 char (4) aligned parm;
	dcl     P_code		 fixed bin (35) parm;

	dcl     code		 fixed bin (35);

	dcl     (lang_index, zone_index) fixed bin;

	dcl     found_zone		 bit (1) aligned;

	dcl     1 local_clok_card	 aligned like clok_card;

	dcl     time_correction	 fixed bin (71);
	dcl     time_zone		 char (4) aligned;

	dcl     user_ring		 fixed bin;

	dcl     zone_delta		 fixed bin;

	dcl     config_$find	 entry (char (4) aligned, ptr);
	dcl     config_$replace	 entry (ptr, ptr);

	dcl     error_table_$unknown_zone fixed bin (35) ext static;

	dcl     level$get		 entry (fixed bin);
	dcl     level$set		 entry (fixed bin);

	dcl     sys_info$time_correction_constant fixed bin (71) aligned ext static;
	dcl     sys_info$time_zone	 char (4) aligned ext static;

	dcl     (addr, divide, null) builtin;

	dcl     cleanup		 condition;

          dcl     MILSEC_IN_HR           fixed bin (71)  int static options (constant) init (3600000000);

	dcl     RING_ZERO		 fixed bin int static options (constant) init (0);

	dcl     TRUE		 bit (1) aligned int static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) aligned int static options (constant) init ("0"b);
%page;
/* Copy input arguments. */
	time_zone = P_time_zone;
	code = 0;

/* Initialize clok config pointer. */
	clok_cardp = null ();

/* Validate input zone, get delta. */
	found_zone = FALSE;
	do lang_index = 1 to ti_zone.number_lang while (^found_zone);
	     do zone_index = 1 to ti_zone.number_zone while (^found_zone);
		if ti_zone.short (lang_index, zone_index) = time_zone then do;
			found_zone = TRUE;
			time_correction = ti_zone.delta (lang_index, zone_index);
		     end;
	     end;					/* zones */
	end;					/* languages */

	if ^found_zone then do;
		code = error_table_$unknown_zone;
		go to MAIN_RETURN;
	     end;

/* Calculate zone delta for CLOK card. */
	zone_delta = divide (time_correction, MILSEC_IN_HR, 17, 0);

/* Find the CLOK card in the config deck. */
	call config_$find (CLOK_CARD_WORD, clok_cardp);

/* Make a copy. */
	local_clok_card = clok_card;

/* Make changes. */
	local_clok_card.delta = zone_delta;
	local_clok_card.zone = time_zone;

/* Set validation level. */
	user_ring = -1;
	on cleanup begin;
	     if user_ring ^= -1 then call level$set (user_ring);
	end;
	call level$get (user_ring);
	call level$set (RING_ZERO);

/* Replace the CLOK card in the config deck. */
	call config_$replace (clok_cardp, addr (local_clok_card));

/* Change the system time zone in sys_info. */
	sys_info$time_zone = time_zone;
	sys_info$time_correction_constant = time_correction;

/* Reset validation level. */
	call level$set (user_ring);

MAIN_RETURN:
	P_code = code;
	return;

%include config_clok_card;
%page;
%include sys_log_constants;
%page;
%include time_names;
     end set_system_time_zone_;




		    time_defaults_.alm              11/11/89  1137.0rew 11/11/89  0837.8       47889



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************

"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  "
"							        "
"  Name:  time_defaults_					        "
"							        "
"  This table defines user-settable, per-process default values for the time  "
"  zone and time language in which dates and times are expressed.  The values "
"  stored in this table must appear in the time_data_.  Refer to	        "
"  time_names_.incl.pl1 for more information about the time_data_  Use this   "
"  include file to reference values in this time_defaults_ table.	        "
"							        "
"  Values in this table can be set using the time_default command, or	        "
"   the date_time_$set_(date_time date time lang zone) subroutines.	        "
"							        "
"  Entry:  time_defaults_$date_time				        "
"							        "
"  dcl time_defaults_$date_time  char(32)var;			        "
"							        "
"  The string to give to date_time_$format to get "standard" date/time        "
"							        "
"  Entry:  time_defaults_$date				        "
"							        "
"  dcl time_defaults_$date  char(32)var;			        "
"							        "
"  The string to give to date_time_$format to get "standard" time	        "
"							        "
"  Entry:  time_defaults_$time				        "
"							        "
"  dcl time_defaults_$time  char(32)var;			        "
"							        "
"  The string to give to date_time_$format to get "standard" time	        "
"							        "
"  Entry:  time_defaults_$language				        "
"							        "
"  dcl time_defaults_$language  char(32);			        "
"							        "
"  The name of the default time language in which day names and month names   "
"  given in dates are expressed.  The value must be one of those given in     "
"  time_data_$language_names.					        "
"							        "
"  Entry:  time_defaults_$language_index			        "
"							        "
"  dcl time_defaults_$language_index fixed bin;			        "
"							        "
"  The value of tt_language_names.index (from time_data_$language_names) for  "
"  the default time language.  This can be used as an index into the other    "
"  tables of time_data_ to find names in the default language.	        "
"							        "

"  Entry:  time_defaults_$zone_long				        "
"							        "
"  dcl time_defaults_$zone_long char(32) varying;			        "
"							        "
"  The full name of the default time zone associated with this process        "
"  (eg, Mountain Standard Time).				        "
"  Time character strings are, by default, expressed in this time zone.       "
"							        "
"  Entry:  time_defaults_$zone_short				        "
"							        "
"  dcl time_defaults_$zone_short char(4) varying;			        "
"							        "
"  The acronym for the default time zone (eg, mst for Mountain Standard Time) "
"							        "
"  Entry:  time_defaults_$zone_delta				        "
"							        "
"  dcl time_defaults_$zone_delta fixed bin(71);			        "
"							        "
"  The offset, in microseconds, of the default time zone from GMT.	        "
"							        "
"  Entry:  time_defaults_$zone_index				        "
"							        "
"  dcl time_defaults_$zone_index fixed bin;			        "
"							        "
"  The index (in time_data_$zone_names) of the default time zone.	        "
"							        "
"  Entry:  time_default_$debug				        "
"							        "
"  dcl time_defaults_$debug bit(1) aligned;			        "
"							        "
"  Status:						        "
"							        "
" 0) Created:  06/14/78- J. Falksen 				        "
" 1) Modified: 07/04/78- G. Dixon	standardize names, add comments.      "
" 2) Modified: 03/30/83- jaf		get ready to install	        "
"							        "
"  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  "


" 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 time_default_$debug switch.
"                                                      END HISTORY COMMENTS




	name	time_defaults_

	segdef	date_time,date,time
	segdef	debug
	segdef	language,language_index
	segdef	zone_long,zone_short,zone_delta,zone_index
	segdef	time_delta,time_zone

	use	static
	join	/static/static

date_time:			"default date_time format string
	dec	0
	aci	" ",64
	
date:				"default date format string
	dec	0
	aci	" ",64
	
time:				"default time format string
	dec	0
	aci	" ",64

language:				"default language name	
	aci " ",32

language_index:			"default language index
	dec 0

zone_long:			"default zone (full name)
	dec	0
	aci	" ",32

zone_short:			"default zone (acronym)
	dec	0
	aci	" ",4
time_zone:
	aci	" ",4		"time_data_$time_zone
		even
time_delta:			"time_data_$time_delta
zone_delta:			"time delta for default zone
	dec	-1,-1
	
zone_index:			"index in time_data_$zone_names of default zone
	dec	0

debug:	dec	0		"debugging off by default

	end




		    time_info_.cds                  11/11/89  1137.0rew 11/11/89  0830.0      499194



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Bull Inc., 1987                *
   *                                                         *
   * 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   */

/*   *   *   *   *	 *   *   *   *   *	 *   *   *   *   *	 *   *   *   *   */
/*							       */
/* Name:	time_info_					       */
/*							       */
/*     Table of values used in converting date/time character strings to or  */
/*  from Multics standard clock values.  Use time_names.incl.pl1 to	       */
/*  reference data values.					       */
/*							       */
/*							       */
/* Entry:  time_info_$version					       */
/*							       */
/* Version number of the structures in the time_info_.		       */
/*							       */
/*							       */
/* Entry:  time_info_$language_names				       */
/*							       */
/* Names of languages in which day names, month names and time zones can be  */
/*  expressed.  Each language is present in each language.		       */
/*							       */
/*							       */
/* Entry:	 time_info_$zone_names				       */
/*							       */
/* Table of time zones in each of the languages.			       */
/*							       */
/*							       */
/* Entry:  time_info_$month_names				       */
/*							       */
/* Table of month names in each of the languages.			       */
/*							       */
/*							       */
/* Entry:  time_info_$day_names				       */
/*							       */
/* Table of day names in each of the languages.			       */
/*							       */
/*							       */
/* Note							       */
/*							       */
/*      A Multics standard clock value is a number of microseconds relative  */
/*  to January 1, 1901 0000.0 GMT.				       */

/* Status							       */
/* 0) Created:	1983-02-09  JFalksen-			       */
/* 1) Updated:	1984-11-18 jaf				       */
/*	Added Australian zones, filled in Spanish.		       */


/* HISTORY COMMENTS:
  1) change(86-08-14,GDixon), approve(86-09-04,MCR7532),
     audit(86-09-05,Martinson), install(86-09-16,MR12.0-1159):
     Rename zone AHST (Alaska-Hawaii Standard Time) to HST (Hawaiian Standard
      Time, GMT-10), according to ANSI Standard X3.51-1975.  Add HDT
      (Hawaiian Daylight Time, GMT-9) and YDT (Yukon Daylight Time, GMT-8)
      according to this standard. (phx18898)
     Add NDT (Newfoundland Daylight Time, GMT-2.5). (phx19658)
     Correct spelling, capitalization and accents (by removing them) in French
      language words. (Compliments of Bruno Mannoni, phx20440)
     Replace zone NZT by NZST (New Zealand Standard Time, GMT+12) and add
      zone NZDT (New Zealand Daylight Time, GMT+13). (phx18881)
  2) change(87-04-09,Lippard), approve(86-11-24,MCR7576),
     audit(87-05-18,Dickson), install(87-07-17,MR12.1-1043):
     Delete inclusion of time_zones_.
                                                   END HISTORY COMMENTS */



/* Modified 07/09/86 by Bruno Mannoni to correct the French names            */
/* ************************************************************************* */
/* ************************************************************************* */
/* **							    ** */
/* ** Debugging trace: While working on a table, it may be helpful to see ** */
/* ** what is going on.  For this purpose there is a debugging switch     ** */
/* ** to be set before running a COMPILED version of this procedure,      ** */
/* **   i.e. execution via cds doesn't hack it.			    ** */
/* ** execute like this:     time_info_$dbn;time_info_;time_info_$dbf	    ** */
/* **							    ** */
/* ************************************************************************* */
/* ************************************************************************* */%page;
time_info_: ti_: proc;

dcl (the_language_count init (4),	/* how many languages in the table   */
    the_zone_count  init (48),	/* how many zones in the table       */
    the_keyword_count init (16),	/* how many keywords in the table    */
				/* includes 3 generated in setup     */

    english	init (1),		/* define a set of named languages,  */
    french	init (2),		/* ..beginning at 1		       */
    german	init (3),
    spanish	init (4),

    Default_Language init (1),	/* site default language	       */

    Fill_From	init (1)		/* which language supplies defaults  */
				/*  for unspecified zones.	       */
    )		int static options (constant);

   call setup;

/**** The 3 keywords "date_time", "date", and "time" cannot be specified     */
/**** here.  They are dynamic quantities, while the ones here are static.    */
/**** These end up in read-only memory.				       */

   call set_format (		/* everything but the kitchen sink   */
      "all",   "^9999yc-^my-^dm  ^Hd:^MH:^99.(6)9UM^zd ^za ^da ^fi"
      || "^(6)9fw ^ma dy^dy dc^dc Uc^Uc");
   call set_format (
      "calendar_clock",     "^9999yc-^my-^dm__^Hd:^MH:^99.(6)9UM_^za_^da");
   call set_format (
      "clock",              "^9999yc-^my-^dm  ^Hd:^MH:^99.(6)9UM ^za ^da");
   call set_format (
      "iso_date",           "^9999yc-^my-^dm");
   call set_format (
      "iso_date_time",      "^9999yc-^my-^dm ^Hd:^MH:^SM ^za");
   call set_format (
      "iso_long_date",      "^9999yc-^my-^dm ^da");
   call set_format (
      "iso_long_date_time", "^9999yc-^my-^dm ^Hd:^MH:^99.(6)9UM ^za");
   call set_format (
      "iso_long_time",      "^Hd:^MH:^99.(6)9UM");
   call set_format (
      "iso_time",           "^Hd:^MH:^SM");
   call set_format (
      "system_date",        "^my/^dm/^yc");
   call set_format (
      "system_date_time",   "^my/^dm/^yc  ^Hd^99v.9MH ^xxxxza^xxxda");
   call set_format (
      "system_time",        "^Hd:^MH");
   call set_format (
      "request_id",         "^yc^my^dm^Hd^MH^99.(6)9UM");

/*  +-+ +-+ +-+ +-+ +-+ +-+ english language values +-+ +-+ +-+ +-+ +-+ +-+  */

   call set_language (english, english, "english");
   call set_language (english, french, "french");
   call set_language (english, german, "german");
   call set_language (english, spanish, "spanish");


   call set_month_name (english, Jan, "Jan", "January");
   call set_month_name (english, Feb, "Feb", "February");
   call set_month_name (english, Mar, "Mar", "March");
   call set_month_name (english, Apr, "Apr", "April");
   call set_month_name (english, May, "May", "May");
   call set_month_name (english, Jun, "Jun", "June");
   call set_month_name (english, Jul, "Jul", "July");
   call set_month_name (english, Aug, "Aug", "August");
   call set_month_name (english, Sep, "Sep", "September");
   call set_month_name (english, Oct, "Oct", "October");
   call set_month_name (english, Nov, "Nov", "November");
   call set_month_name (english, Dec, "Dec", "December");

   call set_day_name (english, Mon, "Mon", "Monday");
   call set_day_name (english, Tue, "Tue", "Tuesday");
   call set_day_name (english, Wed, "Wed", "Wednesday");
   call set_day_name (english, Thu, "Thu", "Thursday");
   call set_day_name (english, Fri, "Fri", "Friday");
   call set_day_name (english, Sat, "Sat", "Saturday");
   call set_day_name (english, Sun, "Sun", "Sunday");

   call set_offset (english, Year, "yr", "years", "year", "this");
   call set_offset (english, Month, "mo", "months", "month", "this");
   call set_offset (english, Week, "wk", "weeks", "week", "this");
   call set_offset (english, Day, "da", "days", "day", "this");
   call set_offset (english, Hour, "hr", "hours", "hour", "this");
   call set_offset (english, Minute, "min", "minutes", "minute", "this");
   call set_offset (english, Second, "sec", "seconds", "second", "this");
   call set_offset (english, Microsecond, "usec", "microseconds",
      "microsecond", "this");

   call set_word (english, Before, "before", "?");
   call set_word (english, On, "on", "?");
   call set_word (english, After, "after", "?");
   call set_word (english, Or, "or", "?");
   call set_word (english, Noon, "noon", "n");
   call set_word (english, Midnight, "midnight", "m");
   call set_word (english, Now, "now", "?");
   call set_word (english, Today, "today", "?");
   call set_word (english, Yesterday, "yesterday", "?");
   call set_word (english, Tomorrow, "tomorrow", "?");
   call set_word (english, FiscalWeek, "FW", "?");

   call set_zone (english, "ut  ", "ut  ", 0, "Universal Time");
   call set_zone (english, "z   ", "z   ", 0, "Universal Time");
   call set_zone (english, "gmt ", "gmt ", 0, "Greenwich Mean Time");
   call set_zone (english, "wat ", "wat ", -1, "West Africa Time");
   call set_zone (english, "at  ", "at  ", -2, "Azores Time");
   call set_zone (english, "gst ", "gst ", -3, "Greenland  Standard Time");
   call set_zone (english, "adt ", "adt ", -3, "Atlantic Daylight Time");
   call set_zone (english, "nst ", "nst ", -3.5,
				        "Newfoundland Standard Time");
   call set_zone (english, "ndt ", "ndt ", -2.5,
				        "Newfoundland Daylight Time");
   call set_zone (english, "ast ", "ast ", -4, "Atlantic Standard Time");
   call set_zone (english, "edt ", "edt ", -4, "Eastern Daylight Time");
   call set_zone (english, "est ", "est ", -5, "Eastern Standard Time");
   call set_zone (english, "cdt ", "cdt ", -5, "Central Daylight Time");
   call set_zone (english, "cst ", "cst ", -6, "Central Standard Time");
   call set_zone (english, "mdt ", "mdt ", -6, "Mountain Daylight Time");
   call set_zone (english, "mst ", "mst ", -7, "Mountain Standard Time");
   call set_zone (english, "pdt ", "pdt ", -7, "Pacific Daylight Time");
   call set_zone (english, "pst ", "pst ", -8, "Pacific Standard Time");
   call set_zone (english, "ydt ", "ydt ", -8, "Yukon Daylight Time");
   call set_zone (english, "yst ", "yst ", -9, "Yukon Standard Time");
   call set_zone (english, "hdt ", "hdt ", -9, "Hawaiian Daylight Time");
   call set_zone (english, "hst ", "hst ",-10, "Hawaiian Standard Time");
/**** l set_zone (english, "bst ", "bst ",-11, "Bering Standard Time");      */
   call set_zone (english, "nt  ", "nt  ",-11, "Nome Time");
   call set_zone (english, "cet ", "cet ", +1, "Central European Time");
   call set_zone (english, "met ", "met ", +1, "Middle Europe Time");
   call set_zone (english, "mewt", "mewt", +1, "Middle Europe Winter Time");
   call set_zone (english, "bst ", "bst ", +1, "British Summer Time");
   call set_zone (english, "swt ", "swt ", +1, "Swedish Winter Time");
   call set_zone (english, "fwt ", "fwt ", +1, "French Winter Time");
   call set_zone (english, "mest", "mest", +2, "Middle Europe Summer Time");
   call set_zone (english, "eet ", "eet ", +2, "Eastern European Time");
   call set_zone (english, "sst ", "sst ", +2, "Swedish Summer Time");
   call set_zone (english, "fst ", "fst ", +2, "French Summer Time");
   call set_zone (english, "bt  ", "bt  ", +3, "Baghdad Time");
   call set_zone (english, "ist ", "ist ", +5.5, "Indian Standard Time");
/**** l set_zone (english, "sst ", "sst ", +7, "South Sumatra Time");	       */
   call set_zone (english, "wast", "wast", +7,
				   "West Australian Standard Time");
   call set_zone (english, "jt  ", "jt  ", +7.5, "Java Time");
   call set_zone (english, "wadt", "wadt", +8,
				   "West Australian Daylight Time");
   call set_zone (english, "cct ", "cct ", +8, "China Coast Time");
   call set_zone (english, "jst ", "jst ", +9, "Japan Standard Time");
   call set_zone (english, "cast", "cast", +9.5,
				   "Central Australian Standard Time");
   call set_zone (english, "sast", "sast", +9.5,
				   "South Australian Standard Time");
   call set_zone (english, "cadt", "cadt", +10.5,
				   "Central Australian Daylight Time");
   call set_zone (english, "sadt", "sadt", +10.5,
				   "South Australian Daylight Time");
   call set_zone (english, "east", "east", +10,
				   "East Australian Standard Time");
   call set_zone (english, "eadt", "eadt", +11,
				   "East Australian Daylight Time");
   call set_zone (english, "nzst", "nzst", +12, "New Zealand Standard Time");
   call set_zone (english, "nzdt", "nzdt", +13, "New Zealand Daylight Time");

/*   +-+ +-+ +-+ +-+ +-+ +-+ french language values +-+ +-+ +-+ +-+ +-+ +-+  */
/*							       */
/*  The national character usage from here on down is taken from	       */
/*	  REFERENCE CHART ISO CODE AND ASSOCIATED RELATIONSHIPS	       */
/*	   The Honeywell Computer Journal, 1971, Vol. 5, No. 3	       */

   call set_language (french, english, "anglais");
   call set_language (french, french, "francais");
   call set_language (french, german, "allemand");
   call set_language (french, spanish, "espagnol");

   call set_month_name (french, Jan, "jan", "Janvier");
   call set_month_name (french, Feb, "fev", "Fevrier");
   call set_month_name (french, Mar, "mars", "Mars");
   call set_month_name (french, Apr, "avr", "Avril");
   call set_month_name (french, May, "mai", "Mai");
   call set_month_name (french, Jun, "juin", "Juin");
   call set_month_name (french, Jul, "jul", "Juillet");
   call set_month_name (french, Aug, "aout", "Aout");
   call set_month_name (french, Sep, "sep", "Septembre");
   call set_month_name (french, Oct, "oct", "Octobre");
   call set_month_name (french, Nov, "nov", "Novembre");
   call set_month_name (french, Dec, "dec", "Decembre");

   call set_day_name (french, Mon, "lun", "Lundi");
   call set_day_name (french, Tue, "mar", "Mardi");
   call set_day_name (french, Wed, "mer", "Mercredi");
   call set_day_name (french, Thu, "jeu", "Jeudi");
   call set_day_name (french, Fri, "ven", "Vendredi");
   call set_day_name (french, Sat, "sam", "Samedi");
   call set_day_name (french, Sun, "dim", "Dimanche");

   call set_offset (french, Year,   "an",  "annees",   "annee",   "cette");
   call set_offset (french, Month,  "m",   "mois",     "mois",    "ce");
   call set_offset (french, Week,   "sem", "semaines", "semaine", "cette");
   call set_offset (french, Day,    "j",   "jours",    "jour",    "ce");
   call set_offset (french, Hour,   "hr",  "heures",   "heure",   "cette");
   call set_offset (french, Minute, "min", "minutes",  "minute",  "cette");
   call set_offset (french, Second, "sec", "secondes", "seconde", "cette");
   call set_offset (french, Microsecond, "usec", "microsecondes",
      "microseconde", "cette");

   call set_word (french, Before, "avant", "?");
   call set_word (french, On, "sur", "?");
   call set_word (french, After, "apres", "?");
   call set_word (french, Or, "ou", "?");
   call set_word (french, Noon, "midi", "?");
   call set_word (french, Midnight, "minuit", "?");
   call set_word (french, Now, "maintenant", "?");
   call set_word (french, Today, "aujourd'hui", "?");
   call set_word (french, Yesterday, "hier", "?");
   call set_word (french, Tomorrow, "demain", "?");
   call set_word (french, FiscalWeek, "SF", "?");

   call set_zone (french, "ut  ", "tu  ", 0, "Temps Universel");
   call set_zone (french, "fwt ", "hfh ", +1, "Heure Francaise d'Hiver");
   call set_zone (french, "fst ", "hfe ", +2, "Heure Francaise d'Ete");


/*   +-+ +-+ +-+ +-+ +-+ +-+ german language values +-+ +-+ +-+ +-+ +-+ +-+  */

   call set_language (german, english, "englisch");
   call set_language (german, french, "franzosisch");
   call set_language (german, german, "deutsch");
   call set_language (german, spanish, "spanisch");


   call set_month_name (german, Jan, "Jan", "Januar");
   call set_month_name (german, Feb, "Feb", "Februar");
   call set_month_name (german, Mar, "Mrz", "M{rz");
   call set_month_name (german, Apr, "Apr", "April");
   call set_month_name (german, May, "Mai", "Mai");
   call set_month_name (german, Jun, "Jun", "Juni");
   call set_month_name (german, Jul, "Jul", "Juli");
   call set_month_name (german, Aug, "Aug", "August");
   call set_month_name (german, Sep, "Sep", "September");
   call set_month_name (german, Oct, "Okt", "Oktober");
   call set_month_name (german, Nov, "Nov", "November");
   call set_month_name (german, Dec, "Dez", "Dezember");

   call set_day_name (german, Mon, "Mo", "Montag");
   call set_day_name (german, Tue, "Di", "Dienstag");
   call set_day_name (german, Wed, "Mi", "Mittwoch");
   call set_day_name (german, Thu, "Do", "Donnerstag");
   call set_day_name (german, Fri, "Fr", "Freitag");
   call set_day_name (german, Sat, "Sa", "Samstag");
   call set_day_name (german, Sun, "So", "Sonntag");

   call set_offset (german, Year,  "J",   "Jahre",   "Jahr",   "dieses");
   call set_offset (german, Month, "Mt",  "Monaten", "Monat",  "dieser");
   call set_offset (german, Week,  "Wo",  "Wochen",  "Woche",  "diese");
   call set_offset (german, Day,   "T",   "Tage",    "Tag",    "dieser");
   call set_offset (german, Hour,  "St",  "Stunden", "Stunde", "diese");
   call set_offset (german, Minute,"Min", "Minuten", "Minute", "diese");
   call set_offset (german, Second,"Sek", "Sekunden","Sekunde","diese");
   call set_offset (german, Microsecond, "Usek", "Mikrosekunden",
      "Mikrosekunde", "diese");

   call set_word (german, Before, "vor", "?");
   call set_word (german, Or, "oder", "?");
   call set_word (german, After, "nach", "?");
   call set_word (german, On, "am", "?");
   call set_word (german, Noon, "mittag", "?");
   call set_word (german, Midnight, "mitternacht", "?");
   call set_word (german, Now, "jetzt", "?");
   call set_word (german, Today, "heute", "?");
   call set_word (german, Yesterday, "gestern", "?");
   call set_word (german, Tomorrow, "morgen", "?");
   call set_word (german, FiscalWeek, "FW", "?");

   call set_zone (german, "nst ", "nst ", -3.5,  "Neufundlandzeit");
   call set_zone (german, "gst ", "gst ", -3,  "Groenlandzeit");
   call set_zone (german, "cet ", "cet ", +1,  "Central European Time");
   call set_zone (german, "met ", "mez ", +1,  "Mitteleuropaeische Zeit");
   call set_zone (german, "mewt", "mewz", +1,  "Mitteleuropaeische Winterzeit");
   call set_zone (german, "swt ", "swt ", +1,  "Schwedische Winterzeit");
   call set_zone (german, "fwt ", "fwt ", +1,  "Franzoesische Winterzeit");
   call set_zone (german, "mest", "mesz", +2,  "Mitteleuropaeische Sommerzeit");
   call set_zone (german, "eet ", "eet ", +2,  "Osteuropaeische Zeit");
   call set_zone (german, "sst ", "sst ", +2,  "Schwedische Sommerzeit");
   call set_zone (german, "fst ", "fst ", +2,  "Franzoesische Sommerzeit");
   call set_zone (german, "ist ", "ist ",+5.5, "Indische Standardzeit");
   call set_zone (german, "jt  ", "jt  ",+7.5,"Javazeit");
   call set_zone (german, "cct ", "cct ", +8, "Chinsische Kuerstenzeit");
   call set_zone (german, "jst ", "jst ", +9, "Japanische Standardzeit");
   call set_zone (german, "sast", "sast", +9.5,
      				      "Suedaustralische Standardzeit");
   call set_zone (german, "nzst", "nzst", +12,"Neuzeeland Standardzeit");
   

/*  +-+ +-+ +-+ +-+ +-+ +-+ spanish language values +-+ +-+ +-+ +-+ +-+ +-+  */

   call set_language (spanish, english, "ingles");
   call set_language (spanish, french, "frances");
   call set_language (spanish, german, "aleman");
   call set_language (spanish, spanish, "espa|ol");


   call set_month_name (spanish, Jan, "Ene", "Enero");
   call set_month_name (spanish, Feb, "Feb", "Febrero");
   call set_month_name (spanish, Mar, "Marzo", "Marzo");
   call set_month_name (spanish, Apr, "Abr", "Abril");
   call set_month_name (spanish, May, "May", "Mayo");
   call set_month_name (spanish, Jun, "Jun", "Junio");
   call set_month_name (spanish, Jul, "Jul", "Julio");
   call set_month_name (spanish, Aug, "Ago", "Agosto");
   call set_month_name (spanish, Sep, "Sep", "Septiembre");
   call set_month_name (spanish, Oct, "Oct", "Octubre");
   call set_month_name (spanish, Nov, "Nov", "Noviembre");
   call set_month_name (spanish, Dec, "Dic", "Diciembre");

   call set_day_name (spanish, Mon, "Lun", "Lunes");
   call set_day_name (spanish, Tue, "Mar", "Martes");
   call set_day_name (spanish, Wed, "Mie", "Mi{rcoles");
   call set_day_name (spanish, Thu, "Jue", "Jueves");
   call set_day_name (spanish, Fri, "Vie", "Viernes");
   call set_day_name (spanish, Sat, "Sab", "Sabado");
   call set_day_name (spanish, Sun, "Dom", "Domingo");

   call set_offset (spanish, Year, "a}o", "a}oa", "a}o", "este");
   call set_offset (spanish, Month, "mes", "meses", "mes", "este");
   call set_offset (spanish, Week, "semana", "semanas", "sem", "esta");
   call set_offset (spanish, Day, "dia", "dias", "dia",  "este");
   call set_offset (spanish, Hour, "hora", "horas", "hr", "esta");
   call set_offset (spanish, Minute, "minuto", "minutos", "min", "este");
   call set_offset (spanish, Second, "segundo", "segundos", "seg", "este");
   call set_offset (spanish, Microsecond, "microsegundo",
				"microsegundos", "useg", "este");

   call set_word (spanish, Before,    "antes", "?");
   call set_word (spanish, On,        "en", "?");
   call set_word (spanish, After,     "despues", "?");
   call set_word (spanish, Or,        "oh", "?");
   call set_word (spanish, Noon,      "mediodia", "?");
   call set_word (spanish, Midnight,  "medianoche", "?");
   call set_word (spanish, Now,       "ahorta", "?");
   call set_word (spanish, Today,     "hoy", "?");
   call set_word (spanish, Yesterday, "ayer", "?");
   call set_word (spanish, Tomorrow,  "ma}ana", "?");
   call set_word (spanish, FiscalWeek,"SF", "?");

   call build;
   return;

setup_error:
      call com_err_ (0, me, """call setup()"" must be done first.");
exit:
      return;%page;
/*****		     Internal Support Procedures		    ****/

setup: proc;


/* compose: off */
dcl get_temp_segments_ entry (char(*), (*) ptr, fixed bin(35));
dcl hcs_$make_entry entry (ptr, char(*), char(*), entry, fixed bin(35));
dcl i		fixed bin;

      if db_sw
      then call ioa_ ("setup:");
      call hcs_$make_entry (null(), "date_time_", "valid_format",
         valid_format, code);
      if (code ^= 0)
      then call hcs_$make_entry (null(), "new_date_time_", "valid_format",
	  valid_format, code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "
The known version of date_time_ does not contain the entrypoint
$valid_format.  The  new version of  date_time_ being installed
must exist in  the  working  directory  with the  added name of
new_date_time_ before time_info_ can be generated.
");
         goto exit;
      end;
      call get_temp_segments_ (me, temp_p, code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "getting tempsegs");
         goto exit;
      end;
      seg_p = temp_p (1);
      ZONE_p = addr (HOLD.z);
      string (zone_def) = ""b;
      HOLD.next_list_p = addr (HOLD.begin_list);
/**** Make room for a few entries which may need to be generated.	       */
      zones_filled = the_zone_count + 12;
      ZONE.zone_id (*) = "";
      zones_filled = 0;
      token_ct = 0;
      keywords_filled = 3;

/**** Begin building the table image				       */
      time_info.version = Vtime_info_2;
      time_info.gmt_zone_index = -1;	/* set undefined		       */
      time_info.default_language_index = Default_Language;

      time_info.date_time_keywords.number_kwd = the_keyword_count;
      time_info.date_time_keywords.pad = 0;
      time_info.date_time_keywords.name (site_date) = "";
      time_info.date_time_keywords.name (site_date_time) = "";
      time_info.date_time_keywords.name (site_time) = "";

      time_info.language_names.number_lang = the_language_count;
      time_info.language_names.pad = 0;

      time_info.month_names.number_lang = the_language_count;
      time_info.month_names.pad = 0;

      time_info.day_names.number_lang = the_language_count;
      time_info.day_names.pad = 0;

      time_info.offset_names.number_lang = the_language_count;
      time_info.offset_names.number_offset = the_offset_count;

      time_info.word_names.number_lang = the_language_count;
      time_info.word_names.number_word = the_word_count;

      call set_format ("multics_date",	   "^my/^dm/^yc");
      call set_format ("multics_date_time", "^my/^dm/^yc  ^Hd^99v.9MH ^xxxxza^xxxda");
      call set_format ("multics_time",	   "^Hd:^MH");

      do i = 1 to the_language_count;
         call set_word (i, AM, "AM", "A");
         call set_word (i, PM, "PM", "P");
      end;
				/* compose: on */
   end setup;
/**** This variable is set by setup for use by set_format.		       */
dcl valid_format	automatic
		entry (char(*), fixed bin, fixed bin(35));

%page;
set_format: proc (kwd, fmt);

dcl kwd		char (*),		/* keyword to set		       */
    fmt		char (*);		/* format to associate with it       */

      if (kwd = "date") | (kwd = "time") | (kwd = "date_time")
      then do;
         call ioa_ ("ERROR: Process default keyword may not be defined. ^a",
	  kwd);
         goto err_return;
      end;
      if (length (fmt) > 128)
      then do;
         call ioa_ ("ERROR: format string >128 characters. ^a", fmt);
         goto err_return;
      end;
      errloc = 0;
      if (index (fmt, "^") = 0)	/* You must ask for SOMETHING!       */
      then code = error_table_$dt_no_format_selector;
      else call valid_format ((fmt), errloc, code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "set_format ^a^[
Format is: ""^va""
 ERROR at: ^vx^^^]", kwd,
	  (errloc > 0), length (fmt), fmt, errloc);
         return;
      end;
      if (kwd = "system_date")
      then do;
         time_info.date_time_keywords.name (site_date) = kwd;
         time_info.date_time_keywords.str (site_date) = fmt;
         return;
      end;
      if (kwd = "system_date_time")
      then do;
         time_info.date_time_keywords.name (site_date_time) = kwd;
         time_info.date_time_keywords.str (site_date_time) = fmt;
         return;
      end;
      if (kwd = "system_time")
      then do;
         time_info.date_time_keywords.name (site_time) = kwd;
         time_info.date_time_keywords.str (site_time) = fmt;
         return;
      end;
      if (keywords_filled = the_keyword_count)
      then do;
         call ioa_ ("Too many keywords supplied, the_keyword_count is only = ^i",
	  the_keyword_count);
         goto err_return;
      end;
/**** if (keywords_filled = 3) then key_pos = 4; else */
      key_pos = 3;
      if (keywords_filled > 3)
      then
         do key_pos = keywords_filled to 4 by -1;
         if (time_info.date_time_keywords.name (key_pos) = kwd)
         then do;
	  call ioa_ ("ERROR: Duplicate keyword. ^a", kwd);
	  goto err_return;
         end;
         if (time_info.date_time_keywords.name (key_pos) < kwd)
         then goto insert;
         time_info.date_time_keywords.name (key_pos+1) = time_info.date_time_keywords.name (key_pos);
         time_info.date_time_keywords.str (key_pos+1) = time_info.date_time_keywords.str (key_pos);
      end;
insert:
      keywords_filled = keywords_filled + 1;
      time_info.date_time_keywords.name (key_pos+1) = kwd;
      time_info.date_time_keywords.str (key_pos+1) = fmt;
      return;

err_return:
      err_sw = "1"b;
      return;

dcl errloc	fixed bin;
dcl error_table_$dt_no_format_selector fixed bin(35) ext static;
dcl key_pos	fixed bin;

end set_format;%page;
set_language: proc (lang, element, value);

dcl lang		fixed bin,	/* which language to set	       */
    element	fixed bin,	/* which element to set	       */
    value		char (*);		/* value to put there	       */

      if db_sw
      then call ioa_ ("lang(^i,^i) '^a'", lang, element, value);
				/* compose: off */
      if (seg_p = null ())
      then goto setup_error;

      if (value = "")
      then call no_value_msg ("language", lang, char (element));
      if (length (time_info.language_names.name (lang, element)) ^= 0)
      then call reset_msg ("Language", lang, ltrim (char (element)),
	    time_info.language_names.name (lang, element), value);
      time_info.language_names.name (lang, element) = value;
				/* compose: on */
      return;

   end set_language;%skip(2);
set_month_name: proc (lang, element, short, long);

dcl lang		fixed bin,	/* which language to set	       */
    element	fixed bin,	/* which element to set	       */
    (short, long)	char (*);		/* values to put there	       */

      if db_sw
      then call ioa_ ("month(^i,^i) '^a' '^a'", lang, element, short, long);
				/* compose: off */
      if (seg_p = null ())
      then goto setup_error;

      if (short = "")
      then call no_value_msg ("short month", lang, mo_name (element));
      if (length (time_info.month_names.short (lang, element)) ^= 0)
      then call reset_msg ("Short month", lang, mo_name (element),
	    time_info.month_names.short (lang, element), short);
      time_info.month_names.short (lang, element) = short;

      if (long = "")
      then call no_value_msg ("long month", lang, mo_name (element));
      if (length (time_info.month_names.long (lang, element)) ^= 0)
      then call reset_msg ("Long month", lang, mo_name (element),
	    time_info.month_names.long (lang, element), long);
      time_info.month_names.long (lang, element) = long;
				/* compose: on */

      return;

   end set_month_name;%page;
set_day_name: proc (lang, element, short, long);

dcl lang		fixed bin,	/* which language to set	       */
    element	fixed bin,	/* which element to set	       */
    (short, long)	char (*);		/* values to put there	       */

      if db_sw
      then call ioa_ ("day(^i,^i) '^a' '^a'", lang, element, short, long);
				/* compose: off */
      if (seg_p = null ())
      then goto setup_error;

      if (short = "")
      then call no_value_msg ("short day", lang, da_name (element));
      if (length (time_info.day_names.short (lang, element)) ^= 0)
      then call reset_msg ("Short day", lang, da_name (element),
	    time_info.day_names.short (lang, element), short);
      time_info.day_names.short (lang, element) = short;

      if (long = "")
      then call no_value_msg ("Long day", lang, da_name (element));
      if (length (time_info.day_names.long (lang, element)) ^= 0)
      then call reset_msg ("Long day", lang, da_name (element),
	    time_info.day_names.long (lang, element), long);
      time_info.day_names.long (lang, element) = long;
				/* compose: on */

      return;

   end set_day_name;%page;
set_offset: proc (lang, element, short, plural, singular, this);

dcl lang		fixed bin,	/* which language< to set	       */
    element	fixed bin,	/* which element to set	       */
    (short, plural, singular, this)
		char (*);		/* values to put there	       */

      if db_sw
      then call ioa_ ("offset(^i,^i) '^a' '^a' '^a'",
         lang, element, short, plural, singular);
				/* compose: off */
      if (seg_p = null ())
      then goto setup_error;

      if (short = "")
      then call no_value_msg ("Short offset", lang, of_name (element));
      if (length (time_info.offset_names.short (lang, element)) ^= 0)
      then call reset_msg ("Short offset", lang, of_name (element),
	    time_info.offset_names.short (lang, element), (short));
	   time_info.offset_names.short (lang, element) = short;

      if (plural = "")
      then call no_value_msg ("Plural offset", lang, of_name (element));
      if (length (time_info.offset_names.plural (lang, element)) ^= 0)
      then call reset_msg ("Plural offset", lang, of_name (element),
	    time_info.offset_names.plural (lang, element), plural);
      time_info.offset_names.plural (lang, element) = plural;

      if (singular = "")
      then call no_value_msg ("singular offset", lang, of_name (element));
      if (length (time_info.offset_names.singular (lang, element)) ^= 0)
      then call reset_msg ("Singular offset", lang, of_name (element),
	    time_info.offset_names.singular (lang, element), singular);
      time_info.offset_names.singular (lang, element) = singular;

      if (this = "")
      then call no_value_msg ("This-word", lang, of_name (element));
      if (length (time_info.offset_names.this (lang, element)) ^= 0)
      then call reset_msg ("This-word", lang, of_name (element),
	    time_info.offset_names.this (lang, element), (this));
      time_info.offset_names.this (lang, element) = this;
				/* compose: on */
      return;

   end set_offset;%page;
set_word: proc (lang, element, value, v);

dcl lang		fixed bin,	/* which language to set	       */
    element	fixed bin,	/* which element to set	       */
    (value, v)	char (*);		/* long&short value to put there     */

      if db_sw
      then call ioa_ ("word(^i,^i) '^a'^a'", lang, element, value, v);
				/* compose: off */
      if (seg_p = null ())
      then goto setup_error;

      if (value = "")
      then call no_value_msg ("word", lang, wo_name (element));
      if (length (time_info.word_names.word (lang, element)) ^= 0)
      then call reset_msg ("Word", lang, wo_name (element),
	    time_info.word_names.word (lang, element), value);
      time_info.word_names.word (lang, element) = value;

      if (v = "")
      then call no_value_msg ("word", lang, wo_name (element));
      if (length (time_info.word_names.short (lang, element)) ^= 0)
      then call reset_msg ("Word", lang, wo_name (element),
	    time_info.word_names.short (lang, element), v);
      time_info.word_names.short (lang, element) = v;
      return;
				/* compose: on */

   end set_word;%page;
set_zone: proc (lang, id, brief, interval, long);

dcl lang		fixed bin,	/* which language to set	       */
    id		char (*),		/* which element to set	       */
    (brief, long)	char (*),		/* values to put there	       */
    interval	fixed dec (12, 8);	/* hour_value+GMT gives this zone    */

dcl element	fixed bin;
dcl range_check	bit (1) init (""b);
dcl ferr_sw	bit (1) init ("1"b);
				/* compose: off */
      if db_sw
      then call ioa_ ("zone(^2i,^4a) ^7f '^a' '^a'", 
         lang, id, interval, brief, long);

      if (seg_p = null ())
      then goto setup_error;

      if (id = "")
      then call no_value_msg ("zone id", lang, brief);
      range_check = "1"b;

add_zone: entry (lang, id, brief, interval, long);

      if (zones_filled = 0)
      then zones_filled = 1;
      else do;
         do element = 1 to zones_filled;
	  if (ZONE.zone_id (element) = id)
	  then goto found_id;
         end;
         if (zones_filled >= the_zone_count) & range_check
         then do;
	  if ferr_sw
	  then do;
	     ferr_sw = ""b;
	     call ioa_ ("ERROR: at ^a (^a,^a)", id, brief, interval);
	  end;
	  call ioa_ ("Too many zones supplied, the_zone_count is only = ^i",
	     the_zone_count);
	  err_sw = "1"b;
	  return;
         end;
         zones_filled = zones_filled + 1;
      end;
      element = zones_filled;
      ZONE.zone_id (element) = id;
found_id:
      if (length (ZONE.zone.short (element, lang)) ^= 0)
      then call reset_msg ("Brief zone", lang, ZONE.zone_id (element),
	    ZONE.zone.short (element, lang), brief);
      ZONE.zone.short (element, lang) = rtrim (brief);

      if (length (ZONE.zone.long (element, lang)) ^= 0)
      then call reset_msg ("Long zone", lang, ZONE.zone_id (element),
	    ZONE.zone.long (element, lang), long);
      ZONE.zone.long (element, lang) = long;

      if (interval < -11) | (interval > 13)
      then do;
         if ferr_sw
         then do;
	  ferr_sw = ""b;
	  call ioa_ ("ERROR: at ^a (^a,^a)", id, brief, interval);
         end;
         call ioa_ ("zone interval(^f) must be in the range -11<x<13.",
	  interval);
         err_sw = "1"b;
      end;
      else do;
         ZONE.zone.delta (element, lang) = -interval;
         if (interval = floor (interval))
         then zone_def (interval) = "1"b;
      end;
      if (time_info.gmt_zone_index < 0) & (interval = 0)
      then time_info.gmt_zone_index  = element;

      return;
				/* compose: on */

   end set_zone;%page;
build: proc;
				/* compose: off */
/**** Things to do in this routine:				       */
/****	generate any needed "zmX" and "zpX" zones		       */
/****	make sure gmt_zone_index got set			       */
/****	check for missing values in Fill_From language		       */
/****	fill in values from Fill_From language			       */
/****	check for missing values on everybody			       */
/****	check for zone ids having different values in different languages  */
/****	sort zones into order by interval			       */
/****	prepare binary search list for CBTB to use		       */
/****	check ambiguity (1) same string, different meaning, different lang */
/****	i.e. you can't tell the meaning w/o help of some other word	       */
/****	check ambiguity (2) same string,   same    meaning, different lang */
/****	i.e. you can't tell the language w/o help of some other word       */


      if (seg_p = null ())
      then goto setup_error;

/****	check for proper number of keywords set			       */
      if (keywords_filled < the_keyword_count)
      then do;
         call ioa_ ("ERROR: the_keyword_count is ^i, but only ^i keywords are set.",
	  the_keyword_count, keywords_filled);
         err_sw = "1"b;
      end;

/****	check for proper number of zones set			       */
      if (zones_filled < the_zone_count)
      then do;
         call ioa_ ("ERROR: the_zone_count is ^i, but only ^i zones are set.",
	  the_zone_count, zones_filled);
         err_sw = "1"b;
      end;

/****	make sure gmt_zone_index got set			       */
       if (time_info.gmt_zone_index < 0)
       then do;
	call ioa_ ("ERROR: No GMT zone has been set.");
	err_sw = "1"b;
       end;

/****     check for missing world zones.			       */
       first_sw = "1"b;
       done = ""b;
       do while (^done);
	done = "1"b;
	element = index (string (zone_def), "0"b);
	if (element > 0)
	then do;
	   done = ""b;
	   element = element - 12;
/**** Some of this may look strange, but historically the Multics offsets    */
/**** are of the opposite sign from those mentioned in the standards.  So    */
/**** we have to be sure to change sign when going from ext->int or int->ext */
	   ch4 = ltrim (char (abs (element)));
	   ch15 = "GMT +00 hours.";
	   substr (ch15, 6, 2) = ch4;
	   if (element < 0)
	   then do;
	      ch4 = "zm" || ch4;
	      substr (ch15, 5, 1) = "-";
	   end;
	   else ch4 = "zp" || ch4;
	   call add_zone (Fill_From, (ch4), (ch4), (element), (ch15));
	   if first_sw
	   then do;
	      first_sw = ""b;
	      call ioa_ ("
This procedure checks for the presence of at least 1 name for
each hourly time zone.  If any zone has no names, a name is
generated for that slot.  This is not an error.");
	   end;
	   call ioa_ ("  Generated zone: ^a", ch4);
	end;
       end;

/****	check for missing values in Fill_From language		       */
      do element = 1 to zones_filled;
         if (length (ZONE.zone.short (element, Fill_From)) = 0)
         then do;
	  call ioa_ (
	     "ERROR: Zone ^a in the Fill_From language (^a) isn't set.",
	     ZONE.zone_id (element), get_lang (Fill_From));
	  err_sw = "1"b;
         end;
      end;

/*	fill in values from Fill_From language			       */
      do lang = 1 to the_language_count;
         do element = 1 to zones_filled;
	  if (length (ZONE.zone.short (element, lang)) = 0)
	  then do;
	     ZONE.zone.short (element, lang)
	        = ZONE.zone.short (element, Fill_From);
	     ZONE.zone.long (element, lang)
	        = ZONE.zone.long (element, Fill_From);
	     ZONE.zone.delta (element, lang)
	        = ZONE.zone.delta (element, Fill_From);
	  end;
         end;
      end;

/**** Build the token/item tables, checking for missing values.	       */
      do lang = 1 to the_language_count;
         do element = 1 to the_language_count;
	  if (length (time_info.language_names.name (lang, element)) = 0)
	  then do;
	     call ioa_ ("ERROR: Language (^a, ^a) has not been specified.",
	        get_lang (lang), get_lang (element));
	     err_sw = "1"b;
	  end;
	  if ^err_sw
	  then do;
	     call add_token (time_info.language_names.name (lang, element),
	        Language_table, lang, element);
	  end;
         end;

         do element = 1 to zones_filled;
	  if (length (ZONE.zone.short (element, lang)) = 0)
	  then do;
	     call ioa_ ("ERROR: Zone ""^a"" is not specified in ^a.",
	        ZONE.zone_id (element), get_lang (lang));
	     err_sw = "1"b;
	  end;
         end;

         do element = 1 to 12;
	  if (length (time_info.month_names.short (lang, element)) = 0)
	  then do;
	     call ioa_ ("ERROR: Month ""^a"" is not specified in ^a.",
	        mo_name (element), get_lang (lang));
	     err_sw = "1"b;
	  end;
	  if ^err_sw
	  then do;
	     call add_token (time_info.month_names.short (lang, element),
	        Month_table, lang, element);
	     call add_token (time_info.month_names.long (lang, element),
	        Month_table, lang, element);
	  end;
         end;

         do element = 1 to 7;
	  if (length (time_info.day_names.short (lang, element)) = 0)
	  then do;
	     call ioa_ ("ERROR: Day ""^a"" is not specified in ^a.",
	        da_name (element), get_lang (lang));
	     err_sw = "1"b;
	  end;
	  if ^err_sw
	  then do;
	     call add_token (time_info.day_names.short (lang, element),
	        Day_table, lang, element);
	     call add_token (time_info.day_names.long (lang, element),
	        Day_table, lang, element);
	  end;
         end;

         do element = 1 to the_offset_count;
	  if (length (time_info.offset_names.short (lang, element)) = 0)
	  then do;
	     call ioa_ ("ERROR: Offset ""^a"" is not specified in ^a.",
	        of_name (element), get_lang (lang));
	     err_sw = "1"b;
	  end;
	  if ^err_sw
	  then do;
	     call add_token (time_info.offset_names.short (lang, element),
	        Offset_table, lang, element);
	     call add_token (time_info.offset_names.plural (lang, element),
	        Offset_table, lang, element);
	     call add_token (time_info.offset_names.singular (lang, element),
	        Offset_table, lang, element);
	     call add_token (time_info.offset_names.this (lang, element),
	        This_table, lang, element);
	  end;
         end;

         do element = 1 to the_word_count;
	  if (length (time_info.word (lang, element)) = 0)
	  then do;
	     call ioa_ ("ERROR: Word ""^a"" is not specified in ^a.",
	        wo_name (element), get_lang (lang));
	     err_sw = "1"b;
	  end;
	  if ^err_sw
	  then do;
	     call add_token (time_info.word_names.word (lang, element),
	        Word_table, lang, element);
	     call add_token (time_info.word_names.short (lang, element),
	        Word_table, lang, element);
	  end;
         end;
      end;

/*	check for zone ids having different values in different languages  */
      do element = 1 to zones_filled;
         do lang = 1 to Fill_From - 1, Fill_From + 1 to the_language_count;
	  if (ZONE.zone.delta (element, Fill_From))
	     ^= (ZONE.zone.delta (element, lang))
	  then do;
	     call ioa_ (
	        "ERROR: Zone offset ""^a"" is not the same in ^a and ^a.",
	        ZONE.zone_id (element), get_lang (lang),
	        get_lang (Fill_From));
	     err_sw = "1"b;
	  end;
         end;
      end;

/*	sort zones into order by interval			       */
      do i = 1 to zones_filled;	/* The methodology used here is very */
         ZONE.zone_order (i) = i;	/*  simple instead of being fast.    */
      end;			/*  This procedure will seldom be    */
				/*  used, thus it is not worth       */
      done = ""b;			/*  wringing CPU time out of it.     */
      do while (^done);
         done = "1"b;
         do i = 2 to zones_filled;
	  t1 = ZONE.zone_order (i - 1);
	  t2 = ZONE.zone_order (i);
	  if (ZONE.zone.delta (t1, 1) < ZONE.zone.delta (t2, 1))
	  then do;
	     done = ""b;
	     ZONE.zone_order (i - 1) = t2;
	     ZONE.zone_order (i) = t1;
	  end;
         end;
      end;
      time_info.gmt_zone_index = ZONE.zone_order (time_info.gmt_zone_index);

/*	fill in the ordered zone table			       */
      time_info.zone_names.number_lang = the_language_count;
      time_info.zone_names.number_zone = zones_filled;

      do t1 = 1 to zones_filled;
         element = ZONE.zone_order (t1);
         do lang = 1 to the_language_count;
	  time_info.zone_names (lang, t1).delta
	     = ZONE.zone (element, lang).delta * microseconds_per_hour;
	  time_info.zone_names (lang, t1).long
	     = ZONE.zone (element, lang).long;
	  time_info.zone_names (lang, t1).short
	     = ZONE.zone (element, lang).short;
	  call add_token (time_info.zone_names.short (lang, t1),
	     Zone_table, lang, t1);
         end;
      end;

/*	prepare binary search list for CDTB to use		       */
      time_info.tokens.count = token_ct;
      time_info.tokens.ambig = ""b;
      item_p = addr (time_info.tokens.item_space);
      item_size = 0;
      first_sw, msg_sw = "1"b;
      do element = 1 to token_ct;
         if db_sw
         then call ioa_ ("token(^i)=""^a""", element, HOLD.symbol (element));
         time_info.tokens.symbol (element) = HOLD.symbol (element);
         time_info.tokens.list_r (element) = rel (item_p);
         item.count = 0;
         do an_item_p = HOLD.list_p (element) repeat (an_item.next)
	  while (an_item_p ^= null ());
	  do ii = 1 to item.count;
	     if (item.table (ii) = (an_item.table))
	        & (item.element (ii) = an_item.elem)
	     then do;
	        item.ambig (ii) = item.ambig (ii) | an_item.ambig;
	        item.in_lang (ii)
		 = item.in_lang (ii) | an_item.lang;
	        goto end_an_item;
	     end;
	  end;
	  item.count = item.count + 1;
	  item.ambig (item.count) = an_item.ambig;
	  item.table (item.count) = an_item.table;
	  item.element (item.count) = an_item.elem;
	  item.in_lang (item.count) = an_item.lang;
end_an_item:
         end;
         if (item.count > 1)
         then do;
	  lang_check, lang_use = ""b;
	  do ii = 1 to item.count;
	     if (item.table (ii) = This_table)
	     then;		/* The "this" is used on all offsets */
				/* ..and may have the same token     */
				/* ..on several of them.  This is    */
				/* ..not a ambiguity. Forget it.     */
	     else do;
	        lang_check = item.in_lang (ii) & lang_use;
	        lang_use = item.in_lang (ii) | lang_use;
	     end;
	  end;
	  if (lang_check ^= ""b)
	  then do;
	     if msg_sw
	     then do;
	        call ioa_ ("
When a token is not unique within a language, some date/time
strings which use this token may be ambiguous and therefore
unparsable.  The date/time software is prepared to handle
such ambiguities.  This is not an error.");
	        msg_sw = ""b;
	     end;
	     call ioa_ ("  Non-unique token ""^a""", HOLD.symbol (element));
	  end;

	  if (item.table (1) ^= This_table)
	  then do;
	     if first_sw
	     then do;
	        call ioa_ ("
When a token does not have the same meaning in all languages,
some date/time strings which use this token may be ambiguous
and therefore unparsable.  The date/time software is prepared
to handle such ambiguities.  This is not an error.");
	        first_sw = ""b;
	     end;
	     call ioa_ ("  Ambiguous token: ^a", HOLD.symbol (element));
	  end;
         end;
         item_size = item_size + (item.count + 2);
         item_p = addrel (item_p, (item.count + 2));
      end;

/**** Fill in arg struc for create_data_segment_.			       */

      if err_sw
      then do;
         call com_err_ (0, "time_info_",
	  "An error has occurred. No new table generated.");
         return;
      end;
      cdsa.sections (1).p = seg_p;
      cdsa.sections (1).len = size (time_info);
      cdsa.sections (1).struct_name = "time_info";
      
      cdsa.sections (2).p = null();
      cdsa.sections (2).len = 0;
      cdsa.sections (2).struct_name = "";
      
      cdsa.seg_name = "time_info_";

      cdsa.num_exclude_names = 0;
      cdsa.exclude_array_ptr = null();
      cdsa.defs_in_link = ""b;
      cdsa.separate_static = ""b;
      cdsa.have_text = "1"b;
      cdsa.have_static = ""b;
      cdsa.pad = ""b;

      call create_data_segment_ (addr (cdsa), code);
      if code ^= 0
      then call com_err_ (code, "time_info_");

      call release_temp_segments_ (me, temp_p, code);
      if (code ^= 0)
      then do;
         call com_err_ (code, me, "releasing tempsegs");
         goto exit;
      end;

dcl release_temp_segments_ entry (char(*), (*) ptr, fixed bin(35));
dcl lang_check	bit (18)aligned;
dcl lang_use	bit (18)aligned;
dcl lang		fixed bin;
dcl element	fixed bin;
dcl done		bit (1);
dcl i		fixed bin;
dcl ii		fixed bin;
dcl msg_sw	bit (1);
dcl first_sw	bit (1);
dcl ch4		char (4)var;
dcl ch15		char (16);
dcl (t1, t2)	fixed bin;
				/* compose: on */

   end build;

/* compose: off */
add_token: proc (tok, tab_id, lang_id, elem_id);
dcl (tok		char (*) var,
    tab_id	fixed bin,	/* which table is it in	       */
    lang_id	fixed bin,	/* which language is it in	       */
    elem_id	fixed bin		/* which element in table is it      */
    )		parm;

dcl symb		char (32) var;

      if (tok = "?")
      then return;
      symb = translate (tok,
         "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
      if (token_ct = 0)
      then cur_token = 1;
      else do;
         lb = 1;
         hb = token_ct;
         do while (lb <= hb);
	  cur_token = divide (lb + hb, 2, 17, 0);
	  if (HOLD.symbol (cur_token) = symb)
	  then goto found_token;
	  if (HOLD.symbol (cur_token) < symb)
	  then do;
	     lb = cur_token + 1;
	     insert_point = cur_token + 1;
	  end;
	  else do;
	     hb = cur_token - 1;
	     insert_point = cur_token;
	  end;
         end;
         do cur_token = token_ct to insert_point by -1;
	  HOLD.token_list (cur_token + 1) = HOLD.token_list (cur_token);
         end;
         cur_token = insert_point;
      end;

      if db_sw
      then call ioa_ ("----new ^a|^a", symb, tok);
      token_ct = token_ct + 1;	/* insert a new token entry	       */
      HOLD.item_ct (cur_token) = 0;
      HOLD.symbol (cur_token) = symb;
      HOLD.list_p (cur_token) = null ();
      goto new_item;

found_token:
      if db_sw
      then call ioa_ ("--found ^a|^a", symb, tok);
      do an_item_p = HOLD.list_p (cur_token)
         repeat (an_item.next)
         while (an_item_p ^= null ());
         if (an_item.table = tab_id) & (an_item.elem = elem_id)
         then goto more_lang;
      end;

new_item:
      if db_sw
      then call ioa_ ("==item ^i(^i)",
         tab_id, elem_id);
      HOLD.item_ct (cur_token) = HOLD.item_ct (cur_token) + 1;
      an_item_p = HOLD.next_list_p;
      HOLD.next_list_p = addrel (HOLD.next_list_p, size (an_item));
      an_item.next = HOLD.list_p (cur_token);
      HOLD.list_p (cur_token) = an_item_p;
      an_item.ambig, an_item.lang = ""b;
      an_item.table = tab_id;
      an_item.elem = elem_id;
more_lang:
      if (an_item.lang ^= ""b) & (substr (an_item.lang, lang_id, 1) = "1"b)
      then an_item.ambig = "1"b;
      substr (an_item.lang, lang_id, 1) = "1"b;
      if db_sw
      then call ioa_ ("lang-^.3b", an_item.lang);
      return;

dcl (lb, hb)	fixed bin;
dcl cur_token	fixed bin;
dcl insert_point	fixed bin;

   end add_token;

get_lang: proc (lang) returns (char (32) var);

dcl lang		fixed bin;

dcl result	char (32) var;

      if (time_info.language_names.name (lang, Fill_From) ^= "")
      then result = time_info.language_names.name (lang, Fill_From);
      else result = ltrim (char (lang));
      return (result);

   end get_lang;

no_value_msg: proc (v1, v2, v3);

dcl v2		fixed bin,
    (v1, v3)	char (*);

      call ioa_ ("ERROR: Value not supplied when setting ^a (^a, ^a).",
         v1, get_lang (v2), v3);
      err_sw = "1"b;

   end no_value_msg;

reset_msg: proc (v1, v2, v3, v4, v5);

dcl v1		char (*),		/* what is being set	       */
    v2		fixed bin,	/* which language it's in	       */
    v3		char (*),		/* which element of table	       */
    v4		char (*) var,	/* prior value		       */
    v5		char (*);		/* new value		       */

      call ioa_ (
         "ERROR: ^a(^a,^a), with the value ""^a"", is being reset to ""^a"".",
         v1, get_lang (v2), v3, v4, v5);
      err_sw = "1"b;

   end reset_msg;

/****		  +-+ +-+automatic variables+-+ +-+ 		    ****/

dcl me		char (15) int static options (constant)
		init ("time_info_.cds");
dcl err_sw	bit (1) init ("0"b);
dcl sys_date_sw	bit (1) init ("0"b);
dcl sys_time_sw	bit (1) init ("0"b);
dcl sys_date_time_sw bit (1) init ("0"b);
dcl temp_p	(2)ptr;

/**** in this hold area, all uninitialized fields will be recognized by      */
/****  having a length of zero (this is what the temp_seg initially	       */
/****  contains).						       */
dcl ZONE_p	ptr;
dcl 1 ZONE	(zones_filled) like HOLD.z based (ZONE_p);
dcl 1 HOLD	based (temp_p(2)),
      2 token_list	(512),
        3 symbol	char (32) var,	/* lower-case form of token	       */
        3 item_ct	fixed bin,	/* # items for this token	       */
        3 list_p	ptr unal,		/* -> list of items for token	       */
      2 z		(the_zone_count),
        3 zone_id	char (16),
        3 zone_order fixed bin,
        3 zone	(the_language_count),
          4 long	char (64) var,
          4 short	char (4) var,
          4 delta	fixed dec (12, 8),
      2 zz	(12) like HOLD.z,	/* place for any generated zones     */
      2 next_list_p ptr,		/* -> next place to put an item      */
      2 begin_list	ptr;		/* 1st item based here	       */

dcl an_item_p	ptr;
dcl 1 an_item	based (an_item_p),
      2 next	ptr,
      2 table	fixed bin,	/* which table this item for	       */
      2 elem	fixed bin,	/* which element in table	       */
      2 lang	bit (18) aligned,	/* languages involved	       */
      2 ambig	bit (1) aligned;



/**** automatic arg struc for create_data_segment_.			 */
dcl 1 cdsa	aligned like cds_args;

dcl code		fixed bin (35);	/* status code.		       */
dcl zone_def	(-11:12) bit(1) unal;

dcl (abs, addr, addrel, char, divide, floor, index, length, ltrim, null, rel,
     rtrim, substr, size, string, translate
    )		builtin;

dcl com_err_	entry options (variable);
dcl ioa_		entry () options (variable);
				/* compose: on */
dcl create_data_segment_
		entry (ptr, fixed bin (35));

dcl microseconds_per_hour init (3600000000)
		fixed bin (71) int static options (constant);

/* format: off */
dcl (Jan	init (1),		Mon	init (1),
     Feb	init (2),		Tue	init (2),
     Mar	init (3),		Wed	init (3),
     Apr	init (4),		Thu	init (4),
     May	init (5),		Fri	init (5),
     Jun	init (6),		Sat	init (6),
     Jul	init (7),		Sun	init (7),
     Aug	init (8),
     Sep	init (9),		     Before	init (1),
     Oct	init (10),	     Or		init (2),
     Nov	init (11),	     After	init (3),
     Dec	init (12),	     On		init (4),
			     Noon		init (5),
     Year		init (1),	     Midnight	init (6),
     Month	init (2),      Now		init (7),
     Week		init (3),	     Yesterday	init (8),
     Day		init (4),	     Today	init (9),
     Hour		init (5),	     Tomorrow	init (10),
     Minute	init (6),	     FiscalWeek	init (11),
     Second	init (7),	     AM		init (12),
     Microsecond	init (8),	     PM		init (13)
    )		fixed bin int static options (constant);
/* format: on */
%include cds_args;

%include time_info_cds;
dcl keywords_filled	fixed bin;
dcl zones_filled	fixed bin;

%include time_info_search;
%include time_names;%skip(5);
dcl db_sw		bit (1) int static init (""b);
dbn: entry; db_sw = "1"b; return;
dbf: entry; db_sw = "0"b; return;

   end time_info_;






		    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