mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 16:34:07 +00:00
632 lines
17 KiB
Plaintext
632 lines
17 KiB
Plaintext
$title ('CP/M V3.0 Date and Time')
|
|
tod:
|
|
do;
|
|
|
|
/*
|
|
Revised:
|
|
14 Sept 81 by Thomas Rolander
|
|
|
|
Modifications:
|
|
Date: September 2,1982
|
|
|
|
Programmer: Thomas J. Mason
|
|
|
|
Changes:
|
|
The 'P' option was changed to the 'C'ontinuous option.
|
|
Also added is the 'S'et option to let the user set either
|
|
the time or the date.
|
|
|
|
Date: October 31,1982
|
|
|
|
Programmer: Bruce K. Skidmore
|
|
|
|
Changes:
|
|
Added Function 50 call to signal Time Set and Time Get.
|
|
|
|
Date: 17 May 1998
|
|
|
|
Programmer: John Elliott
|
|
|
|
Changes:
|
|
Year 2000 fixes (flagged [JCE] below)
|
|
Patch 17 implemented
|
|
*/
|
|
|
|
declare PLM label public;
|
|
|
|
mon1:
|
|
procedure (func,info) external;
|
|
declare func byte;
|
|
declare info address;
|
|
end mon1;
|
|
|
|
mon2:
|
|
procedure (func,info) byte external;
|
|
declare func byte;
|
|
declare info address;
|
|
end mon2;
|
|
|
|
mon2a:
|
|
procedure (func,info) address external;
|
|
declare func byte;
|
|
declare info address;
|
|
end mon2a;
|
|
|
|
declare xdos literally 'mon2a';
|
|
declare date$flag$offset literally '0ch'; /* [JCE] Date in UK format? */
|
|
|
|
declare fcb (1) byte external;
|
|
declare fcb16 (1) byte external;
|
|
declare tbuff (1) byte external;
|
|
|
|
RETURN$VERSION$FUNC:
|
|
procedure address;
|
|
return MON2A(12,0);
|
|
end RETURN$VERSION$FUNC;
|
|
|
|
read$console:
|
|
procedure byte;
|
|
return mon2 (1,0);
|
|
end read$console;
|
|
|
|
write$console:
|
|
procedure (char);
|
|
declare char byte;
|
|
call mon1 (2,char);
|
|
end write$console;
|
|
|
|
print$buffer:
|
|
procedure (buffer$address);
|
|
declare buffer$address address;
|
|
call mon1 (9,buffer$address);
|
|
end print$buffer;
|
|
|
|
READ$CONSOLE$BUFFER:
|
|
procedure (BUFF$ADR);
|
|
declare BUFF$ADR address;
|
|
call MON1(10,BUFF$ADR);
|
|
end READ$CONSOLE$BUFFER;
|
|
|
|
check$console$status:
|
|
procedure byte;
|
|
return mon2 (11,0);
|
|
end check$console$status;
|
|
|
|
|
|
terminate:
|
|
procedure;
|
|
call mon1 (0,0);
|
|
end terminate;
|
|
|
|
|
|
crlf:
|
|
procedure;
|
|
call write$console (0dh);
|
|
call write$console (0ah);
|
|
end crlf;
|
|
|
|
|
|
get$date$flag: procedure byte; /* [JCE] Read the date format flag */
|
|
declare scbpb structure
|
|
(offset byte,
|
|
set byte,
|
|
value address);
|
|
scbpb.offset = date$flag$offset;
|
|
scbpb.set = 0;
|
|
return (mon2(49,.scbpb) and 1);
|
|
end get$date$flag; /* [JCE] ends */
|
|
|
|
/*****************************************************
|
|
|
|
Time & Date ASCII Conversion Code
|
|
|
|
*****************************************************/
|
|
declare BUFFER$ADR structure (
|
|
MAX$CHARS byte,
|
|
NUMB$OF$CHARS byte,
|
|
CONSOLE$BUFFER(23) byte) /* [JCE] size 21 -> 23 throughout */
|
|
initial(23,0,0,0,0,0,0,0,0,0,0,0, /* because of printing */
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0); /* four-figure year nos. */
|
|
|
|
declare tod$adr address;
|
|
declare tod based tod$adr structure (
|
|
opcode byte,
|
|
date address,
|
|
hrs byte,
|
|
min byte,
|
|
sec byte,
|
|
ASCII (23) byte );
|
|
|
|
declare string$adr address;
|
|
declare string based string$adr (1) byte;
|
|
declare index byte;
|
|
|
|
declare lit literally 'literally',
|
|
forever lit 'while 1',
|
|
word lit 'address';
|
|
|
|
/* - - - - - - - - - - - - - - - - - - - - - - */
|
|
emitchar:
|
|
procedure(c);
|
|
declare c byte;
|
|
string(index := index + 1) = c;
|
|
end emitchar;
|
|
|
|
/*- - - - - - - - - - - - - - - - - - - - - - -*/
|
|
emitn:
|
|
procedure(a);
|
|
declare a address;
|
|
declare c based a byte;
|
|
do while c <> '$';
|
|
string(index := index + 1) = c;
|
|
a = a + 1;
|
|
end;
|
|
end emitn;
|
|
|
|
/*- - - - - - - - - - - - - - - - - - - - - - -*/
|
|
|
|
emit$bcd:
|
|
procedure(b);
|
|
declare b byte;
|
|
call emitchar('0'+b);
|
|
end emit$bcd;
|
|
|
|
/*- - - - - - - - - - - - - - - - - - - - - - -*/
|
|
|
|
emit$bcd$pair:
|
|
procedure(b);
|
|
declare b byte;
|
|
call emit$bcd(shr(b,4));
|
|
call emit$bcd(b and 0fh);
|
|
end emit$bcd$pair;
|
|
|
|
/*- - - - - - - - - - - - - - - - - - - - - - -*/
|
|
|
|
emit$colon:
|
|
procedure(b);
|
|
declare b byte;
|
|
call emit$bcd$pair(b);
|
|
call emitchar(':');
|
|
end emit$colon;
|
|
|
|
/*- - - - - - - - - - - - - - - - - - - - - - -*/
|
|
|
|
emit$bin$pair:
|
|
procedure(b);
|
|
declare b byte;
|
|
call emit$bcd(b/10);
|
|
call emit$bcd(b mod 10);
|
|
end emit$bin$pair;
|
|
|
|
/*- - - - - - - - - - - - - - - - - - - - - - -*/
|
|
|
|
emit$slant:
|
|
procedure(b);
|
|
declare b byte;
|
|
call emit$bin$pair(b);
|
|
call emitchar('/');
|
|
end emit$slant;
|
|
|
|
/*- - - - - - - - - - - - - - - - - - - - - - -*/
|
|
|
|
declare chr byte;
|
|
|
|
/*- - - - - - - - - - - - - - - - - - - - - - -*/
|
|
|
|
gnc:
|
|
procedure;
|
|
/* get next command byte */
|
|
if chr = 0 then return;
|
|
if index = 22 then /* [JCE] 20 -> 22 */
|
|
do;
|
|
chr = 0;
|
|
return;
|
|
end;
|
|
chr = string(index := index + 1);
|
|
end gnc;
|
|
|
|
/*- - - - - - - - - - - - - - - - - - - - - - -*/
|
|
deblank:
|
|
procedure;
|
|
do while chr = ' ';
|
|
call gnc;
|
|
end;
|
|
end deblank;
|
|
|
|
numeric:
|
|
procedure byte;
|
|
/* test for numeric */
|
|
return (chr - '0') < 10;
|
|
end numeric;
|
|
|
|
scan$numeric:
|
|
procedure(lb,ub) byte;
|
|
declare (lb,ub) byte;
|
|
declare b byte;
|
|
b = 0;
|
|
call deblank;
|
|
if not numeric then go to error;
|
|
do while numeric;
|
|
if (b and 1110$0000b) <> 0 then go to error;
|
|
b = shl(b,3) + shl(b,1); /* b = b * 10 */
|
|
if carry then go to error;
|
|
b = b + (chr - '0');
|
|
if carry then go to error;
|
|
call gnc;
|
|
end;
|
|
if (b < lb) or (b > ub) then go to error;
|
|
return b;
|
|
end scan$numeric;
|
|
|
|
scan$delimiter:
|
|
procedure(d,lb,ub) byte;
|
|
declare (d,lb,ub) byte;
|
|
call deblank;
|
|
if chr <> d then go to error;
|
|
call gnc;
|
|
return scan$numeric(lb,ub);
|
|
end scan$delimiter;
|
|
|
|
declare base$year lit '78', /* base year for computations */
|
|
base$day lit '0', /* starting day for base$year 0..6 */
|
|
month$size (*) byte data
|
|
/* jan feb mar apr may jun jul aug sep oct nov dec */
|
|
( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
|
|
month$days (*) word data
|
|
/* jan feb mar apr may jun jul aug sep oct nov dec */
|
|
( 000,031,059,090,120,151,181,212,243,273,304,334);
|
|
|
|
leap$days:
|
|
procedure(y,m) byte;
|
|
declare (y,m) byte;
|
|
/* compute days accumulated by leap years */
|
|
declare yp byte;
|
|
yp = shr(y,2); /* yp = y/4 */
|
|
if (y and 11b) = 0 and month$days(m) < 59 then
|
|
/* y not 00, y mod 4 = 0, before march, so not leap yr */
|
|
return yp - 1;
|
|
/* otherwise, yp is the number of accumulated leap days */
|
|
return yp;
|
|
end leap$days;
|
|
|
|
declare word$value word;
|
|
|
|
get$next$digit:
|
|
procedure byte;
|
|
/* get next lsd from word$value */
|
|
declare lsd byte;
|
|
lsd = word$value mod 10;
|
|
word$value = word$value / 10;
|
|
return lsd;
|
|
end get$next$digit;
|
|
|
|
bcd:
|
|
procedure (val) byte;
|
|
declare val byte;
|
|
return shl((val/10),4) + val mod 10;
|
|
end bcd;
|
|
|
|
declare (month, day, year, hrs, min, sec) byte;
|
|
|
|
set$date:
|
|
procedure;
|
|
declare (i, leap$flag) byte; /* temporaries */
|
|
if get$date$flag = 1 then /* [JCE] UK format */
|
|
do;
|
|
day = scan$numeric(1,31);
|
|
month = scan$delimiter('/',1,12) - 1;
|
|
if (leap$flag := month = 1) then i = 29;
|
|
else i = month$size(month);
|
|
if day > i then go to error;
|
|
end;
|
|
else /* US format */
|
|
do;
|
|
month = scan$numeric(1,12) - 1;
|
|
/* may be feb 29 */
|
|
if (leap$flag := month = 1) then i = 29;
|
|
else i = month$size(month);
|
|
day = scan$delimiter('/',1,i);
|
|
end;
|
|
/* [JCE] year2000: Was year = scan$delimiter('/',base$year,99); */
|
|
year = scan$delimiter('/',0,99); /* [JCE] */
|
|
if year < base$year /* [JCE] */
|
|
then year = year + 100; /* [JCE] Dates past 2000 */
|
|
/* ensure that feb 29 is in a leap year */
|
|
if leap$flag and day = 29 and (year and 11b) <> 0 then
|
|
/* feb 29 of non-leap year */ go to error;
|
|
/* compute total days */
|
|
tod.date = month$days(month)
|
|
+ 365 * (year - base$year)
|
|
+ day
|
|
- leap$days(base$year,0)
|
|
+ leap$days(year,month);
|
|
|
|
end SET$DATE;
|
|
|
|
SET$TIME:
|
|
procedure;
|
|
tod.hrs = bcd (scan$numeric(0,23));
|
|
tod.min = bcd (scan$delimiter(':',0,59));
|
|
if tod.opcode = 2
|
|
then
|
|
/* date, hours and minutes only */
|
|
do;
|
|
if chr = ':'
|
|
then i = scan$delimiter (':',0,59);
|
|
tod.sec = 0;
|
|
end;
|
|
/* include seconds */
|
|
else tod.sec = bcd (scan$delimiter(':',0,59));
|
|
end set$time;
|
|
|
|
bcd$pair:
|
|
procedure(a,b) byte;
|
|
declare (a,b) byte;
|
|
return shl(a,4) or b;
|
|
end bcd$pair;
|
|
|
|
|
|
compute$year:
|
|
procedure;
|
|
/* compute year from number of days in word$value */
|
|
declare year$length word;
|
|
year = base$year;
|
|
do forever;
|
|
year$length = 365;
|
|
if (year and 11b) = 0 then /* leap year */
|
|
year$length = 366;
|
|
if word$value <= year$length then
|
|
return;
|
|
word$value = word$value - year$length;
|
|
year = year + 1;
|
|
end;
|
|
end compute$year;
|
|
|
|
declare week$day byte, /* day of week 0 ... 6 */
|
|
day$list (*) byte data ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
|
|
leap$bias byte; /* bias for feb 29 */
|
|
|
|
compute$month:
|
|
procedure;
|
|
month = 12;
|
|
do while month > 0;
|
|
if (month := month - 1) < 2 then /* jan or feb */
|
|
leapbias = 0;
|
|
if month$days(month) + leap$bias < word$value then return;
|
|
end;
|
|
end compute$month;
|
|
|
|
declare date$test byte, /* true if testing date */
|
|
test$value word; /* sequential date value under test */
|
|
|
|
get$date$time:
|
|
procedure;
|
|
/* get date and time */
|
|
hrs = tod.hrs;
|
|
min = tod.min;
|
|
sec = tod.sec;
|
|
word$value = tod.date;
|
|
/* word$value contains total number of days */
|
|
week$day = (word$value + base$day - 1) mod 7;
|
|
call compute$year;
|
|
/* year has been set, word$value is remainder */
|
|
leap$bias = 0;
|
|
if (year and 11b) = 0 and word$value > 59 then
|
|
/* after feb 29 on leap year */ leap$bias = 1;
|
|
call compute$month;
|
|
day = word$value - (month$days(month) + leap$bias);
|
|
month = month + 1;
|
|
end get$date$time;
|
|
|
|
emit$date$time:
|
|
procedure;
|
|
declare century byte; /* [JCE] century */
|
|
|
|
century = 19; /* [JCE] start in the 1900s */
|
|
call emitn(.day$list(shl(week$day,2)));
|
|
call emitchar(' ');
|
|
if get$date$flag = 0 then /* [JCE] US or UK format for dates? */
|
|
do;
|
|
call emit$slant(month);
|
|
call emit$slant(day);
|
|
end;
|
|
else
|
|
do;
|
|
call emit$slant(day);
|
|
call emit$slant(month);
|
|
end;
|
|
century = century + (year / 100); /* [JCE] Y2000 fix for output */
|
|
year = year mod 100; /* [JCE] */
|
|
call emit$bin$pair(century); /* [JCE] end of Y2000 fix for output */
|
|
call emit$bin$pair(year);
|
|
call emitchar(' ');
|
|
call emit$colon(hrs);
|
|
call emit$colon(min);
|
|
call emit$bcd$pair(sec);
|
|
end emit$date$time;
|
|
|
|
tod$ASCII:
|
|
procedure (parameter);
|
|
declare parameter address;
|
|
declare ret address;
|
|
ret = 0;
|
|
tod$adr = parameter;
|
|
string$adr = .tod.ASCII;
|
|
if tod.opcode = 0 then
|
|
do;
|
|
call get$date$time;
|
|
index = -1;
|
|
call emit$date$time;
|
|
end;
|
|
else
|
|
do;
|
|
if (tod.opcode = 1) or
|
|
(tod.opcode = 2) then
|
|
do;
|
|
chr = string(index:=0);
|
|
call set$date;
|
|
call set$time;
|
|
ret = .string(index);
|
|
end;
|
|
else
|
|
do;
|
|
go to error;
|
|
end;
|
|
end;
|
|
end tod$ASCII;
|
|
|
|
/********************************************************
|
|
********************************************************/
|
|
|
|
|
|
declare lcltod structure (
|
|
opcode byte,
|
|
date address,
|
|
hrs byte,
|
|
min byte,
|
|
sec byte,
|
|
ASCII (23) byte ); /* [JCE] 21 -> 23 */
|
|
|
|
declare datapgadr address;
|
|
declare datapg based datapgadr address;
|
|
|
|
declare extrnl$todadr address;
|
|
declare extrnl$tod based extrnl$todadr structure (
|
|
date address,
|
|
hrs byte,
|
|
min byte,
|
|
sec byte );
|
|
|
|
declare i byte;
|
|
declare ret address;
|
|
|
|
display$tod:
|
|
procedure;
|
|
lcltod.opcode = 0; /* read tod */
|
|
call mon1(50,.(26,0,0,0,0,0,0,0)); /* BIOS TIME GET SIGNAL */
|
|
call move (5,.extrnl$tod.date,.lcltod.date);
|
|
call tod$ASCII (.lcltod);
|
|
call write$console (0dh);
|
|
do i = 0 to 22; /* [JCE] 20 -> 22 */
|
|
call write$console (lcltod.ASCII(i));
|
|
end;
|
|
end display$tod;
|
|
|
|
comp:
|
|
procedure (cnt,parmadr1,parmadr2) byte;
|
|
declare (i,cnt) byte;
|
|
declare (parmadr1,parmadr2) address;
|
|
declare parm1 based parmadr1 (5) byte;
|
|
declare parm2 based parmadr2 (5) byte;
|
|
do i = 0 to cnt-1;
|
|
if parm1(i) <> parm2(i)
|
|
then return 0;
|
|
end;
|
|
return 0ffh;
|
|
end comp;
|
|
|
|
|
|
/**************************************
|
|
|
|
|
|
Main Program
|
|
|
|
|
|
**************************************/
|
|
|
|
declare last$dseg$byte byte initial (0);
|
|
declare CURRENT$VERSION address initial (0);
|
|
declare CPM30 byte initial (030h);
|
|
declare MPM byte initial (01h);
|
|
|
|
PLM:
|
|
do;
|
|
CURRENT$VERSION = RETURN$VERSION$FUNC;
|
|
if (low(CURRENT$VERSION) >= CPM30) and (high(CURRENT$VERSION) <> MPM) then
|
|
do;
|
|
datapgadr = xdos (49,.(03ah,0));
|
|
extrnl$todadr = xdos(49,.(03ah,0)) + 58H;
|
|
if (FCB(1) = 'C') then
|
|
do while FCB(1) = 'C';
|
|
call mon1(105,.(0,0,0,0)); /* [JCE] this implements Patch 17 */
|
|
if comp(5,.extrnl$tod.date,.lcltod.date) = 0 then
|
|
call display$tod;
|
|
if check$console$status then
|
|
do;
|
|
ret = read$console;
|
|
fcb(1) = 0;
|
|
end;
|
|
end;
|
|
else
|
|
if (FCB(1) = ' ') then
|
|
do;
|
|
call display$tod;
|
|
end;
|
|
else
|
|
if (FCB(1) = 'S')
|
|
then do;
|
|
call crlf;
|
|
call print$buffer(.('Enter today''s date (','$')); /* [JCE] UK-format */
|
|
if get$date$flag then /* [JCE] */
|
|
call print$buffer(.('DD/MM/YY): ','$')); /* [JCE] UK format */
|
|
else call print$buffer(.('MM/DD/YY): ','$')); /* [JCE] US format */
|
|
call move(23,.(000000000000000000000),.buffer$adr.console$buffer);
|
|
call read$console$buffer(.buffer$adr);
|
|
if buffer$adr.numb$of$chars > 0
|
|
then do;
|
|
call move(23,.buffer$adr.console$buffer,.lcltod.ASCII);
|
|
tod$adr = .lcltod;
|
|
string$adr = .tod.ASCII;
|
|
chr = string(index := 0);
|
|
call set$date;
|
|
call move(2,.lcltod.date,.extrnl$tod.date);
|
|
end; /* date initialization */
|
|
call crlf;
|
|
call print$buffer(.('Enter the time (HH:MM:SS): ','$'));
|
|
call move(23,.(000000000000000000000),.buffer$adr.console$buffer);
|
|
call read$console$buffer(.buffer$adr);
|
|
if buffer$adr.numb$of$chars > 0
|
|
then do;
|
|
call move(23,.buffer$adr.console$buffer,.lcltod.ASCII);
|
|
tod$adr = .lcltod;
|
|
string$adr = .tod.ASCII;
|
|
chr = string(index := 0);
|
|
call set$time;
|
|
call crlf;
|
|
call print$buffer(.('Press any key to set time ','$'));
|
|
ret = read$console;
|
|
call move(3,.lcltod.hrs,.extrnl$tod.hrs);
|
|
call mon1(50,.(26,0,0ffh,0,0,0,0,0)); /* BIOS TIME SET SIGNAL */
|
|
end;
|
|
call crlf;
|
|
end;
|
|
else do;
|
|
call move (23,.tbuff(1),.lcltod.ASCII);
|
|
lcltod.opcode = 1;
|
|
call tod$ASCII (.lcltod);
|
|
call crlf;
|
|
call print$buffer (.('Strike key to set time','$'));
|
|
ret = read$console;
|
|
call move (5,.lcltod.date,.extrnl$tod.date);
|
|
call mon1(50,.(26,0,0ffh,0,0,0,0,0)); /* BIOS TIME SET SIGNAL */
|
|
call crlf;
|
|
end;
|
|
call terminate;
|
|
end;
|
|
else
|
|
do;
|
|
call CRLF;
|
|
call PRINT$BUFFER(.('ERROR: Requires CP/M3.','$'));
|
|
call CRLF;
|
|
call TERMINATE;
|
|
end;
|
|
end;
|
|
|
|
error:
|
|
do;
|
|
call crlf;
|
|
call print$buffer (.('ERROR: Illegal time/date specification.','$'));
|
|
call terminate;
|
|
end;
|
|
|
|
end tod;
|