mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-26 18:04:07 +00:00
Upload
Digital Research
This commit is contained in:
@@ -0,0 +1,467 @@
|
||||
$compact
|
||||
$title ('DATE: Time and Date utility')
|
||||
DATE:
|
||||
do;
|
||||
|
||||
$include(:f1:copyrt.lit)
|
||||
|
||||
/* Revised:
|
||||
23 Jun 82 by Bill Fitler (CCP/M-86)
|
||||
*/
|
||||
|
||||
$include(:f1:vaxcmd.lit)
|
||||
|
||||
$include(:f1:vermpm.lit)
|
||||
|
||||
declare dcl literally 'declare';
|
||||
dcl lit literally 'literally';
|
||||
dcl forever lit 'while 1';
|
||||
|
||||
|
||||
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;
|
||||
|
||||
mon3:
|
||||
procedure (func,info) address external;
|
||||
declare func byte;
|
||||
declare info address;
|
||||
end mon3;
|
||||
|
||||
mon4:
|
||||
procedure (func,info) pointer external;
|
||||
declare func byte;
|
||||
declare info address;
|
||||
end mon4;
|
||||
|
||||
|
||||
|
||||
declare fcb (1) byte external;
|
||||
declare fcb16 (1) byte external;
|
||||
declare buff (1) byte external;
|
||||
|
||||
|
||||
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;
|
||||
|
||||
check$console$status:
|
||||
procedure byte;
|
||||
return mon2 (11,0);
|
||||
end check$console$status;
|
||||
|
||||
version:
|
||||
procedure address;
|
||||
return mon3(12,0);
|
||||
end version;
|
||||
|
||||
terminate:
|
||||
procedure;
|
||||
call mon1 (0,0);
|
||||
end terminate;
|
||||
|
||||
get$sysdat:
|
||||
procedure pointer;
|
||||
return (mon4(154,0));
|
||||
end get$sysdat;
|
||||
|
||||
crlf:
|
||||
procedure;
|
||||
call write$console (0dh);
|
||||
call write$console (0ah);
|
||||
end crlf;
|
||||
|
||||
error:
|
||||
procedure;
|
||||
call print$buffer (.(
|
||||
'Illegal time/date specification.','$'));
|
||||
call terminate;
|
||||
end;
|
||||
|
||||
/*****************************************************
|
||||
|
||||
Time & Date ASCII Conversion Code
|
||||
|
||||
*****************************************************/
|
||||
|
||||
declare tod$adr address;
|
||||
declare tod based tod$adr structure (
|
||||
opcode byte,
|
||||
date address,
|
||||
hrs byte,
|
||||
min byte,
|
||||
sec byte,
|
||||
ASCII (21) byte );
|
||||
|
||||
declare string$adr address;
|
||||
declare string based string$adr (1) byte;
|
||||
declare index byte;
|
||||
|
||||
|
||||
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 = 20 then
|
||||
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 call error;
|
||||
do while numeric;
|
||||
if (b and 1110$0000b) <> 0 then call error;
|
||||
b = shl(b,3) + shl(b,1); /* b = b * 10 */
|
||||
if carry then call error;
|
||||
b = b + (chr - '0');
|
||||
if carry then call error;
|
||||
call gnc;
|
||||
end;
|
||||
if (b < lb) or (b > ub) then call error;
|
||||
return b;
|
||||
end scan$numeric;
|
||||
|
||||
scan$delimiter: procedure(d,lb,ub) byte;
|
||||
declare (d,lb,ub) byte;
|
||||
call deblank;
|
||||
if chr <> d then call 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$time: procedure;
|
||||
declare
|
||||
(i, leap$flag) byte; /* temporaries */
|
||||
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);
|
||||
year = scan$delimiter('/',base$year,99);
|
||||
/* 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 */ call error;
|
||||
/* compute total days */
|
||||
tod.date = month$days(month)
|
||||
+ 365 * (year - base$year)
|
||||
+ day
|
||||
- leap$days(base$year,0)
|
||||
+ leap$days(year,month);
|
||||
|
||||
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$date$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;
|
||||
call emitn(.day$list(shl(week$day,2)));
|
||||
call emitchar(' ');
|
||||
call emit$slant(month);
|
||||
call emit$slant(day);
|
||||
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$time;
|
||||
ret = .string(index);
|
||||
end;
|
||||
else
|
||||
do;
|
||||
call error;
|
||||
end;
|
||||
end;
|
||||
end tod$ASCII;
|
||||
|
||||
/********************************************************
|
||||
********************************************************/
|
||||
|
||||
declare tod$pointer pointer;
|
||||
declare tod$ptr structure (
|
||||
offset word,
|
||||
segment word) at (@tod$pointer);
|
||||
declare extrnl$tod based tod$pointer structure (
|
||||
date address,
|
||||
hrs byte, /* in system data area */
|
||||
min byte,
|
||||
sec byte );
|
||||
|
||||
declare lcltod structure ( /* local to this program */
|
||||
opcode byte,
|
||||
date address,
|
||||
hrs byte,
|
||||
min byte,
|
||||
sec byte,
|
||||
ASCII (21) byte );
|
||||
|
||||
declare i byte;
|
||||
declare ret address;
|
||||
|
||||
display$tod:
|
||||
procedure;
|
||||
|
||||
lcltod.opcode = 0; /* read tod */
|
||||
call movb (@extrnl$tod.date,@lcltod.date,5);
|
||||
call tod$ASCII (.lcltod);
|
||||
call write$console (0dh);
|
||||
do i = 0 to 20;
|
||||
call write$console (lcltod.ASCII(i));
|
||||
end;
|
||||
end display$tod;
|
||||
|
||||
|
||||
/*
|
||||
Main Program
|
||||
*/
|
||||
|
||||
declare tod$sd$offset lit '7eh'; /* offset of TOD structure in MP/M-86 */
|
||||
declare vers address;
|
||||
declare last$dseg$byte byte
|
||||
initial (0);
|
||||
|
||||
plmstart:
|
||||
procedure public;
|
||||
vers = version;
|
||||
if low (vers) < Ver$BDOS or (high(vers) and Ver$Mask) = 0 then
|
||||
do;
|
||||
call print$buffer(.(0dh,0ah,Ver$Needs$OS,'$'));
|
||||
call mon1(0,0);
|
||||
end;
|
||||
|
||||
tod$pointer = get$sysdat;
|
||||
tod$ptr.offset = tod$sd$offset;
|
||||
if (fcb(1) <> ' ') and (fcb(1) <> 'P') then
|
||||
do;
|
||||
call move (21,.buff(1),.lcltod.ASCII);
|
||||
lcltod.opcode = 1;
|
||||
call tod$ASCII (.lcltod);
|
||||
call print$buffer (.(
|
||||
'Strike key to set time','$'));
|
||||
ret = read$console;
|
||||
call movb (@lcltod.date,@extrnl$tod.date,5); /* use pl/m-86 move */
|
||||
call crlf;
|
||||
end;
|
||||
do while fcb(1) = 'P';
|
||||
call display$tod;
|
||||
if check$console$status then
|
||||
do;
|
||||
ret = read$console;
|
||||
fcb(1) = 0;
|
||||
end;
|
||||
end;
|
||||
call display$tod;
|
||||
call terminate;
|
||||
end plmstart;
|
||||
|
||||
end DATE;
|
||||
Reference in New Issue
Block a user