```/*REXX*/
/*---------------------------------------------------------------------------*/
/* Time Bif Specifications                                                   */
/*     Acknowledgements: Klaus Hansjakob provided the basic algorithm for    */
/*      time conversion.  Brian Marks provided the coding specific to the    */
/*      Rexx builtin functions.  Ian Collier and Kurt Maerker have provided  */
/*      corrections to errors.                                               */
/*                                                                           */
/*    Note: This version has the extensions which the Rexx standardizing     */
/*      committee proposes for conversion of delimiters.  That is not part   */
/*      of the current Rexx standard.                                        */
/*---------------------------------------------------------------------------*/

Time: procedure
/* This routine is essentially the code from the standard, put in
stand-alone form.  The only 'tricky bit' is that there is no Rexx way
for it to fail with the same error codes as a "real" implementation
would.  It can however give a SYNTAX error, albeit not the desirable
one.  This causing of an error is done by returning with no value.
Since the routine will have been called as a function, this produces
an error. */

/* Backslash is avoided as some systems don't handle that negation sign. */
if arg()>3 then
return
numeric digits 18
if arg(1,'E') then
if pos(translate(left(arg(1),1)),"CEHLMNRS")=0 then
return
/* (The standard would also allow 'O' but what this code is running
on would not.) */
if arg(3,'E') then    if pos(translate(left(arg(3),1)),"CHLMNS")=0 then
return
/* If the third argument is given then the second is mandatory. */
if arg(3,'E') & arg(2,'E')=0 then
return
/* Default the first argument. */
if arg(1,'E') then
Option = translate(left(arg(1),1))
else
Option = 'N'
/* If there is no second argument, the current time is returned. */
if arg(2,'E') = 0 then
if arg(1,'E') then
return 'TIME'(arg(1))
else
return 'TIME'()
/* One cannot convert to elapsed times. */
if pos(Option, 'ERO') > 0 then
return
InValue = arg(2)
if arg(3,'E') then
InOption = arg(3)
else
InOption = 'N'
HH = 0
MM = 0
SS = 0
select
when InOption == 'C' then do
parse var InValue HH ':' . +1 MM +2 XX
if HH = 12 then
HH = 0
if XX == 'pm' then
end
when InOption == 'H' then
HH = InValue
when InOption == 'L' | InOption == 'N' then
parse var InValue HH ':' MM ':' SS
when InOption == 'M' then
MM = InValue
otherwise
SS = InValue
end
if datatype(HH,'W')=0 | datatype(MM,'W')=0 | datatype(SS,'N')=0 then
return
/* Convert to microseconds */
Micro = trunc((((HH * 60) + MM) * 60 + SS) * 1000000)
/* There is no special message for time-out-of-range; the bad-format
message is used. */
if Micro 24*3600*1000000 then
return
/* Reconvert to further check the original. */
if TimeFormat(Micro,InOption) == InValue then
return TimeFormat(Micro, Option)
return

TimeFormat: procedure
/* Convert from microseconds to given format. */
/* The day will be irrelevant; actually it will be the first day possible. */
x = Time2Date2(arg(1))
parse value x with Year Month Day Hour Minute Second Microsecond Base Days
select
when arg(2) == 'C' then
select
when Hour>12 then
return Hour-12':'right(Minute,2,'0')'pm'
when Hour=12 then
return '12:'right(Minute,2,'0')'pm'        when Hour>0 then
return Hour':'right(Minute,2,'0')'am'
when Hour=0 then
return '12:'right(Minute,2,'0')'am'
end
when arg(2) == 'H' then return Hour
when arg(2) == 'L' then
return right(Hour,2,'0')':'right(Minute,2,'0')':'right(Second,2,'0'),
|| '.'right(Microsecond,6,'0')
when arg(2) == 'M' then
return 60*Hour+Minute
when arg(2) == 'N' then
return right(Hour,2,'0')':'right(Minute,2,'0')':'right(Second,2,'0')
otherwise /* arg(2) == 'S' */
return 3600*Hour+60*Minute+Second
end

Time2Date:
/* These are checks on the range of the date. */
if arg(1) = 315537897600000000 then
return Time2Date2(arg(1))

Time2Date2: Procedure
/*  Convert a timestamp to a date.
Argument is a timestamp (the number of microseconds relative to
0001 01 01 00:00:00.000000)
Returns a date in the form:
year month day hour minute second microsecond base days     */

/* Argument is relative to the virtual date 0001 01 01 00:00:00.000000 */
Time = arg(1)

Second = Time   % 1000000    ; Microsecond = Time   // 1000000
Minute = Second %      60    ; Second      = Second //      60
Hour   = Minute %      60    ; Minute      = Minute //      60
Day    = Hour   %      24    ; Hour        = Hour   //      24

/* At this point, the days are the days since the 0001 base date. */
BaseDays = Day
Day = Day + 1

/* Compute either the fitting year, or some year not too far earlier.
Compute the number of days left on the first of January of this year. */
Year   = Day % 366
Day    = Day - (Year*365 + Year%4 - Year%100 + Year%400)
Year   = Year + 1

/* Now if the number of days left is larger than the number of days
in the year we computed, increment the year, and decrement the
number of days accordingly. */
do while Day > (365 + Leap(Year))
Day = Day - (365 + Leap(Year))
Year = Year + 1
end

/* At this point, the days left pertain to this year. */
YearDays = Day

/* Now step through the months, increment the number of the month,
and decrement the number of days accordingly (taking into
consideration that in a leap year February has 29 days), until
further reducing the number of days and incrementing the month
would lead to a negative number of days */
Days = '31 28 31 30 31 30 31 31 30 31 30 31'
do Month = 1 to words(Days)
ThisMonth = Word(Days, Month) + (Month = 2) * Leap(Year)
if Day <= ThisMonth then leave
Day = Day - ThisMonth
end

return Year Month Day Hour Minute Second Microsecond BaseDays YearDays

Leap: procedure
/* Return 1 if the year given as argument is a leap year, or 0
otherwise. */
return (arg(1)//4 = 0) & ((arg(1)//100 <> 0) | (arg(1)//400 = 0))

/*---------------------------------------------------------------------------*/
/* Date Bif Specifications                                                   */
/*---------------------------------------------------------------------------*/

date: procedure
/* This routine is essentially the code from the standard, put in
stand-alone form.  The only 'tricky bit' is that there is no Rexx way
for it to fail with the same error codes as a "real" implementation
would.  It can however give a SYNTAX error, albeit not the desirable
one.  This causing of an error is done by returning with no value.
Since the routine will have been called as a function, this produces
an error. */

if arg() > 5 then return
numeric digits 18
if arg(1,'E') then
if pos(translate(left(arg(1),1)),"BDEMNOSUW")=0 then
return

if arg(3,'E') then
if pos(translate(left(arg(3),1)),"BDENOSU")=0 then
return

/* If the third argument is given then the second is mandatory. */
if arg(3,'E') & arg(2,'E')=0 then
return

/* Default the first argument. */
if arg(1,'E') then                             /* OutOption                */
Option = translate(left(arg(1),1))
else
Option = 'N'

/* If there is no second argument, the current time is returned. */
if arg() <= 1 then
if arg(1,'E') then
return 'DATE'(arg(1))
else
return 'DATE'()

if arg(3,'E') then                             /* InOption                 */
InOption = arg(3)
else
InOption = 'N'

/*>> In September 97 the standardizing committee decided how DATE should <<
>> be extended to generalize the separators used.                      <<*/

if Option == 'S' then
OutSeparator = ''
else
OutSeparator = translate(Option,"xx/x //x","BDEMNOUW")

if arg(4,'E') then do                          /* OutSeparator             */
/*-----------------------------------------------------------------------*/
/* The text for the following error 40.46 is:                            */
/* '<bif> argument <argnumber>, "<value>", is a format incompatible with */
/* separator specified in argument <argnumber>'                          */
/*-----------------------------------------------------------------------*/
if OutSeparator == 'x' then
return
OutSeparator = arg(4)

/*-----------------------------------------------------------------------*/
/* The text for the following error 40.45 is;                            */
/* '<bif> argument <argnumber> must be a single non-alphanumeric         */
/* character or the null string; found <value>"'                         */
/*-----------------------------------------------------------------------*/
if length(OutSeparator) > 1 | datatype(OutSeparator,'A') then
return
end

if InOption == 'S' then
InSeparator = ''
else
InSeparator = translate(InOption,"xx/ //","BDENOU")

if arg(5,'E') then do                          /* InSeparator              */
if InSeparator == 'x' then
return
InSeparator = arg(5)
if length(InSeparator) > 1 | datatype(InSeparator,'A') then
return
end

/* English spellings are used, even if messages not in English are used.   */
Months = 'January February March April May June July',
'August September October November December'

WeekDays = 'Monday Tuesday Wednesday Thursday Friday Saturday Sunday'

Value = arg(2)

/* First try for Year Month Day */
Logic = 'NS'
select
when InOption == 'N' then do
if InSeparator == '' then do
if length(Value)<9 then return
Year = right(Value,4)
MonthIs = substr(right(Value,7),1,3)
Day = left(Value,length(Value)-7)
end
else
parse var Value Day (InSeparator) MonthIs (InSeparator) Year
do Month = 1 to 12
if left(word(Months, Month), 3) == MonthIs then leave
end Month
end
when InOption == 'S' then
if InSeparator == '' then
parse var Value Year +4 Month +2 Day
else
parse var Value Year (InSeparator) Month (InSeparator) Day
otherwise
Logic = 'EOU' /* or BD */
end

/* Next try for year without century */
if logic = 'EOU' then
Select
when InOption == 'E' then
if InSeparator == '' then
parse var Value Day +2 Month +2 YY
else
parse var Value Day (InSeparator) Month (InSeparator) YY
when InOption == 'O' then
if InSeparator == '' then
parse var Value YY +2 Month +2 Day
else
parse var Value YY (InSeparator) Month (InSeparator) Day
when InOption == 'U' then
if InSeparator == '' then
parse var Value Month +2 Day +2 YY
else
parse var Value Month (InSeparator) Day (InSeparator) YY
otherwise
Logic = 'BD'
end

if Logic = 'EOU' then do
/* The century is assumed, on the basis of the current year. */
if datatype(YY,'W')=0 then
return
YearNow = left('DATE'('S'),4)
Year = YY
do while Year < YearNow-50
Year = Year + 100
end
end /* Century assumption */

if Logic <> 'BD' then do
/* Convert Month & Day to Days of year. */
if datatype(Month,'W')=0 | datatype(Day,'W')=0 | datatype(Year,'W')=0 then
return
Days = word('0 31 59 90 120 151 181 212 243 273 304 334',Month),
+ (Month>2)*Leap(Year) + Day-1
end
else
if datatype(Value,'W')=0 then
return
if InOption == 'D' then do
Year = left('DATE'('S'),4)
Days = Value - 1 /* 'D' includes current day */
end

/* Convert to BaseDays */
if InOption <> 'B' then
BaseDays = (Year-1)*365 + (Year-1)%4 - (Year-1)%100 + (Year-1)%400 + Days
else
Basedays = Value

/* Convert to microseconds from 0001 */
Micro = BaseDays * 86400 * 1000000

/* Reconvert to check the original. (eg for Month = 99) */
if DateFormat(Micro,InOption,InSeparator) == Value then
return DateFormat(Micro,Option,OutSeparator)
return

DateFormat:

/* Convert from microseconds to given format and separator. */
x = Time2Date(arg(1))
parse value x with Year Month Day Hour Minute Second Microsecond Base Days
select
when arg(2) == 'B' then
return Base
when arg(2) == 'D' then
return Days
when arg(2) == 'E' then
return right(Day,2,'0')(arg(3))right(Month,2,'0')(arg(3))right(Year,2,'0')
when arg(2) == 'M' then
return word(Months,Month)
when arg(2) == 'N' then
return (Day)(arg(3))left(word(Months,Month),3)(arg(3))right(Year,4,'0')
when arg(2) == 'O' then
return right(Year,2,'0')(arg(3))right(Month,2,'0')(arg(3))right(Day,2,'0')
when arg(2) == 'S' then
return right(Year,4,'0')(arg(3))right(Month,2,'0')(arg(3))right(Day,2,'0')
when arg(2) == 'U' then
return right(Month,2,'0')(arg(3))right(Day,2,'0')(arg(3))right(Year,2,'0')
otherwise /* arg(2) == 'W' */
return word(Weekdays,1+Base//7)
end

/* It must be a variant of Murphy's law that if you write some code that
others might use it turns out that the code depends on something that
different interpreters treat differently.  In this particular case,
interpreters differ on whether the error of a function failing to
return a result is an error that the level calling the function sees,or an error that the function itself sees. */

GoodDate: procedure
signal on syntax name Better_Be_Unique1
/* Next two clauses are deliberately on the same line. */
GoodDateSigl = RecordSigl(); GoodDateResult = date(arg(2),arg(1),arg(2))
if GoodDateResult='*' then
return 0
return 1

Better_Be_Unique1:
if sigl==GoodDateSigl then
/* This code being run by interpreter that raises error in the caller */
return 0
/* This code being run by interpreter that raises error in the callee */
return '*'

RecordSigl:
return sigl

GoodTime: procedure
signal on syntax name Better_Be_Unique2
/* Next two clauses are deliberately on the same line. */
GoodTimeSigl = RecordSigl(); GoodTimeResult = time(arg(2),arg(1),arg(2))
if GoodTimeResult='*' then
return 0
return 1

Better_Be_Unique2:
if sigl==GoodTimeSigl then
/* This code being run by interpreter that raises error in the caller */
return 0
/* This code being run by interpreter that raises error in the callee */
return '*'
```