$compact
$title ('MP/M-86 2.0 Time and Date')
tod:
do;

$include(copyrt.lit)

$include(vaxcmd.lit)

declare dcl literally 'declare';
dcl lit literally 'literally';
dcl forever lit 'while 1';

dcl mpmproduct lit '11h';
dcl cpmversion lit '30h';

  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) <> cpmversion or high (vers) <> mpmproduct then
    do;
       call print$buffer(.(0dh,0ah,'Requires MP/M-86 2.0','$'));
       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 tod;