dynamic routine spec prompt(string (15) s)
dynamic routine spec rdint(integer name i)
system string fn spec itos(integer i)
system routine spec uctranslate(integer adr, len)
routine uctran(string name s)
uctranslate(addr(s)+1, length(s))
end {uctran}
routine kdate(integer name d, m, y, integer k)
! INPUT PARAMETER K IS DAYS SINCE 1ST JAN 1900
! RETURNS D, M, Y 2 DIGIT Y ONLY
! %integer W
! K=K+693902 {days since Cleopatras birthday}
! W=4*K-1
! Y=W//146097
! K=W-146097*Y
! D=K//4
! K=(4*D+3)//1461
! D=4*D+3-1461*K
! D=(D+4)//4
! M=(5*D-3)//153
! D=5*D-3-153*M
! D=(D+5)//5
! Y=K
*lss_k; *iad_693902
*imy_4; *isb_1; *imdv_146097
*lss_ tos ; *idv_4; *imy_4; *iad_3
*imdv_1461; *st_(y)
*lss_ tos ; *iad_4; *idv_4
*imy_5; *isb_3; *imdv_153
*st_(m); *lss_ tos
*iad_5; *idv_5; *st_(d)
if m<10 then m=m+3 else start
m=m-9
if y=99 then y=0 else y=y+1
finish
end {kdate}
integer fn day no
const long integer jms= x'141DD76000'
! This number is the number of microeconds in a day
! x'141DD76000000' is the number of IBM clock-units in
! a day. A clock unit is the time increment denoted by
! bit 63 of the TOD clock and CPU timer.
*rrtc_0
*ush_-1; ! This is a right-shift
*shs_1; ! left
*ush_1; ! left
*idv_jms
*stuh_ b
*exit_-64
end {dayno}
routine ibm clock(longintegername clock)
longinteger xxx
*rrtc_0; ! 8.1.3.11
*ush_-1; ! This is a right-shift
*shs_1; ! left
*ush_13; ! left
! ACC now contains a number of IBM clock units
*st_xxx
clock=xxx
end {IBM clock}
integer fn kday(integer d, m, y)
! This is the inverse function of KDATE
if m>2 then m=m-3 else m=m+9 and y=y-1
result =1461*y//4+(153*m+2)//5+d+58
end {kday}
string fn itosp(integer i, pl)
string (255) s
s=itos(i)
s="0".s while length(s)<pl
result =s
end {itosp}
!-----------------------------------------------------------------------------
string fn datestring(integer type)
! Type 1 06/06/83
! Type 2 1st Sep 83
! Type 3 1st September 1983
! Type 4 1st Septmeber, 1983
! Type 5 1 SEP 83
! Type 6 01 SEP 83
! Type 7 01SEP83
! Type 8 WED
! Type 9 Wednesday
const string (9) array day(0:6)="Monday","Tuesday","Wednesday","Thursday",
"Friday","Saturday","Sunday"
const integer sun=6,mon=0,tue=1,wed=2,thu=3,fri=4,sat=5
const string (2) array tags(0:4)="th", "st", "nd", "rd", "th"
const string (10) array months(1:12)="January", "February", "March", "April",
"May", "June", "July", "August", "September", "October", "November", "December"
integer k, todayno
string (71) ordinal, tag, s
record format df(integer y, m, d, dayno, dayname)
record (df) today
constinteger toptype=9
switch dtype(1:toptype)
todayno=dayno
kdate(today_d, today_m, today_y, todayno)
today_dayname=todayno-7*(todayno//7)
today_dayno=todayno
k=today_d
k=k-(k//10)*10 while not 0<=k<=9
k=4 if k>4
tag=tags(k)
ordinal=itos(today_d).tag
unless 0<type<=toptype then type=1
->dtype(type)
dtype(1): ! 06/06/83
result =itosp(today_d, 2)."/".itosp(today_m, 2)."/".itosp(today_y, 2)
dtype(2): ! 1st Sep 83
s=months(today_m)
length(s)=3
result =ordinal." ".s." ".itosp(today_y, 2)
dtype(3): ! 1st September 1983
dtype(4): ! 1st September, 1983
s=months(today_m)
s=ordinal." ".s
s=s."," if type=4
result =s." 19".itosp(today_y, 2)
dtype(5): ! 1 SEP 83
dtype(6): ! 01 SEP 83
dtype(7): ! 01SEP83
s=months(today_m)
length(s)=3
uctran(s)
if type=7 then type=6 else s=" ".s." "
result =itosp(today_d, type-4).s.itosp(today_y, 2)
dtype(8): ! WED
dtype(9): ! Wednesday
s=day(today_d)
if type=8 then length(s)=3 and uctran(s)
result =s
end {datestring}
external routine testdate(string (255) s)
integer type, d, m, y
longinteger clock, musecs, day from 1900
ibm clock(clock)
musecs=clock>>12
day from 1900=musecs//x'141DD76000'
kdate(d, m, y, day from 1900)
write(d, 1); write(m, 1); write(y, 1); newline
return
cycle
prompt("Date-type: ")
rdint(type)
exit if type<=0
printstring(datestring(type))
newline
exit if type<=0
repeat
end {testdate}
end of file