home *** CD-ROM | disk | FTP | other *** search
/ norge.freeshell.org (192.94.73.8) / 192.94.73.8.tar / 192.94.73.8 / pub / computers / cpm / alphatronic / DRIPAK.ZIP / CPM_3-0 / SOURCES / DATE.PLM < prev    next >
Text File  |  1982-12-31  |  15KB  |  581 lines
  1. $title ('CP/M V3.0 Date and Time')
  2. tod:
  3.    do;
  4.  
  5. /*
  6.   Revised:
  7.     14 Sept 81  by Thomas Rolander
  8.  
  9.   Modifications:
  10.    Date: September 2,1982
  11.  
  12.    Programmer: Thomas J. Mason
  13.  
  14.    Changes:
  15.     The 'P' option was changed to the 'C'ontinuous option.
  16.     Also added is the 'S'et option to let the user set either
  17.     the time or the date.
  18.  
  19.    Date: October 31,1982
  20.  
  21.    Programmer: Bruce K. Skidmore
  22.  
  23.    Changes:
  24.     Added Function 50 call to signal Time Set and Time Get.
  25. */
  26.  
  27.    declare PLM label public;
  28.  
  29.    mon1:
  30.     procedure (func,info) external;
  31.        declare func byte;
  32.        declare info address;
  33.     end mon1;
  34.  
  35.    mon2:
  36.     procedure (func,info) byte external;
  37.        declare func byte;
  38.        declare info address;
  39.     end mon2;
  40.  
  41.    mon2a:
  42.     procedure (func,info) address external;
  43.        declare func byte;
  44.        declare info address;
  45.     end mon2a;
  46.  
  47.    declare xdos literally 'mon2a';
  48.  
  49.    declare fcb (1) byte external;
  50.    declare fcb16 (1) byte external;
  51.    declare tbuff (1) byte external;
  52.  
  53.    RETURN$VERSION$FUNC:
  54.     procedure address;
  55.        return MON2A(12,0);
  56.     end RETURN$VERSION$FUNC;
  57.  
  58.    read$console:
  59.     procedure byte;
  60.        return mon2 (1,0);
  61.     end read$console;
  62.  
  63.    write$console:
  64.     procedure (char);
  65.        declare char byte;
  66.        call mon1 (2,char);
  67.     end write$console;
  68.  
  69.    print$buffer:
  70.     procedure (buffer$address);
  71.        declare buffer$address address;
  72.        call mon1 (9,buffer$address);
  73.     end print$buffer;
  74.  
  75.    READ$CONSOLE$BUFFER:
  76.     procedure (BUFF$ADR);
  77.     declare BUFF$ADR address;
  78.        call MON1(10,BUFF$ADR);
  79.     end READ$CONSOLE$BUFFER;
  80.  
  81.    check$console$status:
  82.     procedure byte;
  83.        return mon2 (11,0);
  84.     end check$console$status;
  85.  
  86.  
  87.    terminate:
  88.     procedure;
  89.        call mon1 (0,0);
  90.     end terminate;
  91.  
  92.    crlf:
  93.     procedure;
  94.        call write$console (0dh);
  95.        call write$console (0ah);
  96.     end crlf;
  97.  
  98.  
  99. /*****************************************************
  100.  
  101.           Time & Date ASCII Conversion Code
  102.  
  103.  *****************************************************/
  104. declare BUFFER$ADR structure (
  105.         MAX$CHARS byte,
  106.         NUMB$OF$CHARS byte,
  107.         CONSOLE$BUFFER(21) byte)
  108.         initial(21,0,0,0,0,0,0,0,0,0,0,0,
  109.                  0,0,0,0,0,0,0,0,0,0,0);
  110.  
  111. declare tod$adr address;
  112. declare tod based tod$adr structure (
  113.   opcode byte,
  114.   date address,
  115.   hrs byte,
  116.   min byte,
  117.   sec byte,
  118.   ASCII (21) byte );
  119.  
  120. declare string$adr address;
  121. declare string based string$adr (1) byte;
  122. declare index byte;
  123.  
  124. declare lit literally 'literally',
  125.   forever lit 'while 1',
  126.   word lit 'address';
  127.  
  128. /* - - - - - - - - - - - - - - - - - - - - - - */
  129.    emitchar:
  130.     procedure(c);
  131.     declare c byte;
  132.        string(index := index + 1) = c;
  133.     end emitchar;
  134.  
  135. /*- - - - - - - - - - - - - - - - - - - - - - -*/
  136.    emitn:
  137.     procedure(a);
  138.     declare a address;
  139.     declare c based a byte;
  140.        do while c <> '$';
  141.           string(index := index + 1) = c;
  142.           a = a + 1;
  143.        end;
  144.     end emitn;
  145.  
  146. /*- - - - - - - - - - - - - - - - - - - - - - -*/
  147.  
  148.    emit$bcd:
  149.     procedure(b);
  150.     declare b byte;
  151.        call emitchar('0'+b);
  152.     end emit$bcd;
  153.  
  154. /*- - - - - - - - - - - - - - - - - - - - - - -*/
  155.  
  156.    emit$bcd$pair:  
  157.     procedure(b);
  158.     declare b byte;
  159.        call emit$bcd(shr(b,4));
  160.        call emit$bcd(b and 0fh);
  161.     end emit$bcd$pair;
  162.  
  163. /*- - - - - - - - - - - - - - - - - - - - - - -*/
  164.  
  165.    emit$colon:
  166.     procedure(b);
  167.     declare b byte;
  168.        call emit$bcd$pair(b);
  169.        call emitchar(':');
  170.     end emit$colon;
  171.  
  172. /*- - - - - - - - - - - - - - - - - - - - - - -*/
  173.  
  174.    emit$bin$pair:
  175.     procedure(b);
  176.     declare b byte;
  177.        call emit$bcd(b/10);
  178.        call emit$bcd(b mod 10);
  179.     end emit$bin$pair;
  180.  
  181. /*- - - - - - - - - - - - - - - - - - - - - - -*/
  182.  
  183.    emit$slant:
  184.     procedure(b);
  185.     declare b byte;
  186.        call emit$bin$pair(b);
  187.        call emitchar('/');
  188.     end emit$slant;
  189.  
  190. /*- - - - - - - - - - - - - - - - - - - - - - -*/
  191.  
  192.    declare chr byte;
  193.  
  194. /*- - - - - - - - - - - - - - - - - - - - - - -*/
  195.  
  196.    gnc:
  197.     procedure;
  198.     /* get next command byte */
  199.        if chr = 0 then return;
  200.        if index = 20 then
  201.        do;
  202.           chr = 0;
  203.           return;
  204.        end;
  205.        chr = string(index := index + 1);
  206.     end gnc;
  207.  
  208. /*- - - - - - - - - - - - - - - - - - - - - - -*/
  209.    deblank:
  210.     procedure;
  211.        do while chr = ' ';
  212.           call gnc;
  213.        end;
  214.     end deblank;
  215.  
  216.    numeric:
  217.     procedure byte;
  218.     /* test for numeric */
  219.        return (chr - '0') < 10;
  220.     end numeric;
  221.  
  222.    scan$numeric:
  223.     procedure(lb,ub) byte;
  224.     declare (lb,ub) byte;
  225.     declare b byte;
  226.        b = 0;
  227.        call deblank;
  228.        if not numeric then go to error;
  229.        do while numeric;
  230.           if (b and 1110$0000b) <> 0 then go to error;
  231.           b = shl(b,3) + shl(b,1); /* b = b * 10 */
  232.           if carry then go to error;
  233.           b = b + (chr - '0');
  234.           if carry then go to error;
  235.           call gnc;
  236.        end;
  237.        if (b < lb) or (b > ub) then go to error;
  238.        return b;
  239.      end scan$numeric;
  240.  
  241.    scan$delimiter:
  242.     procedure(d,lb,ub) byte;
  243.     declare (d,lb,ub) byte;
  244.        call deblank;
  245.        if chr <> d then go to error;
  246.        call gnc;
  247.        return scan$numeric(lb,ub);
  248.     end scan$delimiter;
  249.  
  250. declare base$year lit '78',   /* base year for computations */
  251.         base$day  lit '0',    /* starting day for base$year 0..6 */
  252.         month$size (*) byte data
  253.         /* jan feb mar apr may jun jul aug sep oct nov dec */
  254.         (   31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
  255.         month$days (*) word data
  256.         /* jan feb mar apr may jun jul aug sep oct nov dec */
  257.         (  000,031,059,090,120,151,181,212,243,273,304,334);
  258.  
  259.    leap$days:
  260.     procedure(y,m) byte;
  261.     declare (y,m) byte;
  262.     /* compute days accumulated by leap years */
  263.     declare yp byte;
  264.        yp = shr(y,2); /* yp = y/4 */
  265.        if (y and 11b) = 0 and month$days(m) < 59 then
  266.         /* y not 00, y mod 4 = 0, before march, so not leap yr */
  267.           return yp - 1;
  268.     /* otherwise, yp is the number of accumulated leap days */
  269.        return yp;
  270.     end leap$days;
  271.  
  272.    declare word$value word;
  273.  
  274.    get$next$digit:
  275.     procedure byte;
  276.     /* get next lsd from word$value */
  277.     declare lsd byte;
  278.        lsd = word$value mod 10;
  279.        word$value = word$value / 10;
  280.        return lsd;
  281.     end get$next$digit;
  282.  
  283.    bcd:
  284.     procedure (val) byte;
  285.     declare val byte;
  286.        return shl((val/10),4) + val mod 10;
  287.     end bcd;
  288.  
  289.    declare (month, day, year, hrs, min, sec) byte;
  290.  
  291.    set$date:
  292.     procedure;
  293.     declare (i, leap$flag) byte; /* temporaries */
  294.        month = scan$numeric(1,12) - 1;
  295.     /* may be feb 29 */
  296.        if (leap$flag := month = 1) then i = 29;
  297.         else i = month$size(month);
  298.        day   = scan$delimiter('/',1,i);
  299.        year  = scan$delimiter('/',base$year,99);
  300.     /* ensure that feb 29 is in a leap year */
  301.        if leap$flag and day = 29 and (year and 11b) <> 0 then
  302.     /* feb 29 of non-leap year */ go to error;
  303.     /* compute total days */
  304.        tod.date = month$days(month)
  305.                 + 365 * (year - base$year)
  306.                 + day
  307.                 - leap$days(base$year,0)
  308.                 + leap$days(year,month);
  309.  
  310.      end SET$DATE;
  311.  
  312.    SET$TIME:
  313.     procedure;
  314.        tod.hrs   = bcd (scan$numeric(0,23));
  315.        tod.min   = bcd (scan$delimiter(':',0,59));
  316.        if tod.opcode = 2
  317.         then
  318.     /* date, hours and minutes only */
  319.         do;
  320.            if chr = ':'
  321.             then i = scan$delimiter (':',0,59);
  322.            tod.sec = 0;
  323.         end;
  324.     /* include seconds */
  325.         else tod.sec   = bcd (scan$delimiter(':',0,59));
  326.     end set$time;
  327.  
  328.    bcd$pair:
  329.     procedure(a,b) byte;
  330.     declare (a,b) byte;
  331.        return shl(a,4) or b;
  332.     end bcd$pair;
  333.  
  334.  
  335.    compute$year:
  336.     procedure;
  337.     /* compute year from number of days in word$value */
  338.     declare year$length word;
  339.        year = base$year;
  340.           do forever;
  341.              year$length = 365;
  342.              if (year and 11b) = 0 then /* leap year */
  343.                 year$length = 366;
  344.              if word$value <= year$length then
  345.                 return;
  346.              word$value = word$value - year$length;
  347.              year = year + 1;
  348.           end;
  349.     end compute$year;
  350.  
  351. declare week$day  byte, /* day of week 0 ... 6 */
  352.         day$list (*) byte data ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
  353.         leap$bias byte; /* bias for feb 29 */
  354.  
  355.    compute$month:
  356.     procedure;
  357.        month = 12;
  358.        do while month > 0;
  359.           if (month := month - 1) < 2 then /* jan or feb */
  360.              leapbias = 0;
  361.           if month$days(month) + leap$bias < word$value then return;
  362.        end;
  363.     end compute$month;
  364.  
  365. declare date$test byte,    /* true if testing date */
  366.         test$value word;   /* sequential date value under test */
  367.  
  368.    get$date$time:
  369.     procedure;
  370.     /* get date and time */
  371.        hrs = tod.hrs;
  372.        min = tod.min;
  373.        sec = tod.sec;
  374.        word$value = tod.date;
  375.     /* word$value contains total number of days */
  376.        week$day = (word$value + base$day - 1) mod 7;
  377.        call compute$year;
  378.     /* year has been set, word$value is remainder */
  379.        leap$bias = 0;
  380.        if (year and 11b) = 0 and word$value > 59 then
  381.         /* after feb 29 on leap year */ leap$bias = 1;
  382.        call compute$month;
  383.        day = word$value - (month$days(month) + leap$bias);
  384.        month = month + 1;
  385.     end get$date$time;
  386.  
  387.    emit$date$time:
  388.     procedure;
  389.        call emitn(.day$list(shl(week$day,2)));
  390.        call emitchar(' ');
  391.        call emit$slant(month);
  392.        call emit$slant(day);
  393.        call emit$bin$pair(year);
  394.        call emitchar(' ');
  395.        call emit$colon(hrs);
  396.        call emit$colon(min);
  397.        call emit$bcd$pair(sec);
  398.     end emit$date$time;
  399.  
  400.    tod$ASCII:
  401.     procedure (parameter);
  402.     declare parameter address;
  403.     declare ret address;
  404.        ret = 0;
  405.        tod$adr = parameter;
  406.        string$adr = .tod.ASCII;
  407.        if tod.opcode = 0 then
  408.        do;
  409.           call get$date$time;
  410.           index = -1;
  411.           call emit$date$time;
  412.        end;
  413.         else
  414.        do;
  415.           if (tod.opcode = 1) or
  416.            (tod.opcode = 2) then
  417.           do;
  418.              chr = string(index:=0);
  419.              call set$date;
  420.              call set$time;
  421.              ret = .string(index);
  422.           end;
  423.            else
  424.           do;
  425.              go to error;
  426.           end;
  427.        end;
  428.     end tod$ASCII;
  429.  
  430. /********************************************************
  431.  ********************************************************/
  432.  
  433.  
  434.    declare lcltod structure (
  435.      opcode byte,
  436.      date address,
  437.      hrs byte,
  438.      min byte,
  439.      sec byte,
  440.      ASCII (21) byte );
  441.  
  442.    declare datapgadr address;
  443.    declare datapg based datapgadr address;
  444.  
  445.    declare extrnl$todadr address;
  446.    declare extrnl$tod based extrnl$todadr structure (
  447.      date address,
  448.      hrs byte,
  449.      min byte,
  450.      sec byte );
  451.  
  452.    declare i byte;
  453.    declare ret address;
  454.  
  455.    display$tod:
  456.     procedure;
  457.        lcltod.opcode = 0; /* read tod */
  458.        call mon1(50,.(26,0,0,0,0,0,0,0)); /* BIOS TIME GET SIGNAL */
  459.        call move (5,.extrnl$tod.date,.lcltod.date);
  460.        call tod$ASCII (.lcltod);
  461.        call write$console (0dh);
  462.        do i = 0 to 20;
  463.           call write$console (lcltod.ASCII(i));
  464.        end;
  465.     end display$tod;
  466.  
  467.    comp:
  468.     procedure (cnt,parmadr1,parmadr2) byte;
  469.     declare (i,cnt) byte;
  470.     declare (parmadr1,parmadr2) address;
  471.     declare parm1 based parmadr1 (5) byte;
  472.     declare parm2 based parmadr2 (5) byte;
  473.        do i = 0 to cnt-1;
  474.           if parm1(i) <> parm2(i)
  475.            then return 0;
  476.        end;
  477.        return 0ffh;
  478.     end comp;
  479.  
  480.  
  481.   /**************************************
  482.  
  483.  
  484.     Main Program
  485.  
  486.  
  487.   **************************************/
  488.  
  489.    declare last$dseg$byte byte initial (0);
  490.    declare CURRENT$VERSION address initial (0);
  491.    declare CPM30 byte initial (030h);
  492.    declare MPM byte initial (01h);
  493.  
  494. PLM:
  495. do;
  496.    CURRENT$VERSION = RETURN$VERSION$FUNC;
  497.    if (low(CURRENT$VERSION) >= CPM30) and (high(CURRENT$VERSION) <> MPM) then
  498.    do;
  499.       datapgadr = xdos (49,.(03ah,0));
  500.       extrnl$todadr = xdos(49,.(03ah,0)) + 58H;
  501.       if (FCB(1) = 'C') then
  502.       do while FCB(1) = 'C';
  503.          if comp(5,.extrnl$tod.date,.lcltod.date) = 0 then
  504.             call display$tod;
  505.          if check$console$status then
  506.          do;
  507.             ret = read$console;
  508.             fcb(1) = 0;
  509.          end;
  510.       end;
  511.       else
  512.          if (FCB(1) = ' ') then
  513.          do;
  514.             call display$tod;
  515.          end;
  516.          else
  517.             if (FCB(1) = 'S')
  518.             then do;
  519.                call crlf;
  520.                call print$buffer(.('Enter today''s date (MM/DD/YY): ','$'));
  521.                call move(21,.(000000000000000000000),.buffer$adr.console$buffer);
  522.                call read$console$buffer(.buffer$adr);
  523.                if buffer$adr.numb$of$chars > 0
  524.                then do;
  525.                   call move(21,.buffer$adr.console$buffer,.lcltod.ASCII);
  526.                   tod$adr = .lcltod;
  527.                   string$adr = .tod.ASCII;
  528.                   chr = string(index := 0);
  529.                   call set$date;
  530.                   call move(2,.lcltod.date,.extrnl$tod.date);
  531.                end;  /* date initialization */
  532.                call crlf;
  533.                call print$buffer(.('Enter the time (HH:MM:SS):     ','$'));
  534.                call move(21,.(000000000000000000000),.buffer$adr.console$buffer);
  535.                call read$console$buffer(.buffer$adr);
  536.                if buffer$adr.numb$of$chars > 0
  537.                 then do;
  538.                   call move(21,.buffer$adr.console$buffer,.lcltod.ASCII);
  539.                   tod$adr = .lcltod;
  540.                   string$adr = .tod.ASCII;
  541.                   chr = string(index := 0);
  542.                   call set$time;
  543.                   call crlf;
  544.                   call print$buffer(.('Press any key to set time ','$'));
  545.                   ret = read$console;
  546.                   call move(3,.lcltod.hrs,.extrnl$tod.hrs);
  547.                   call mon1(50,.(26,0,0ffh,0,0,0,0,0,)); /* BIOS TIME SET SIGNAL */
  548.                 end;
  549.                 call crlf;
  550.              end;
  551.             else do;
  552.                call move (21,.tbuff(1),.lcltod.ASCII);
  553.                lcltod.opcode = 1;
  554.                call tod$ASCII (.lcltod);
  555.                call crlf;
  556.                call print$buffer (.('Strike key to set time','$'));
  557.                ret = read$console;
  558.                call move (5,.lcltod.date,.extrnl$tod.date);
  559.                call mon1(50,.(26,0,0ffh,0,0,0,0,0,)); /* BIOS TIME SET SIGNAL */
  560.                call crlf;
  561.              end;
  562.       call terminate;
  563.       end;
  564.       else
  565.       do;
  566.          call CRLF;
  567.          call PRINT$BUFFER(.('ERROR:  Requires CP/M3.','$'));
  568.          call CRLF;
  569.          call TERMINATE;
  570.       end;
  571.    end;
  572.  
  573.    error:
  574.    do;
  575.       call crlf;
  576.       call print$buffer (.('ERROR: Illegal time/date specification.','$'));
  577.       call terminate;
  578.    end;
  579.  
  580. end tod;
  581.