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 / TIMEST.PLM < prev    next >
Text File  |  1982-12-31  |  6KB  |  226 lines
  1. $title('SDIR - Display Time Stamps')
  2. timestamp:
  3. do;
  4.        /* Display time stamp module for extended directory */
  5.        /* Time & Date ASCII Conversion Code               */
  6.        /* From MP/M 1.1 TOD program                   */
  7.  
  8. $include(comlit.lit)
  9.  
  10. print$char: procedure (char) external;
  11.     declare char byte;
  12. end print$char;
  13.  
  14. terminate: procedure external;
  15. end terminate;
  16.  
  17. declare tod$adr address;
  18. declare tod based tod$adr structure (
  19.   opcode byte,
  20.   date address,
  21.   hrs byte,
  22.   min byte,
  23.   sec byte,
  24.   ASCII (21) byte );
  25.  
  26. declare string$adr address;
  27. declare string based string$adr (1) byte;
  28. declare index byte;
  29.  
  30. emitchar: procedure(c);
  31.     declare c byte;
  32.     string(index := index + 1) = c;
  33.     end emitchar;
  34.  
  35. emitn: procedure(a);
  36.     declare a address;
  37.     declare c based a byte;
  38.     do while c <> '$';
  39.       string(index := index + 1) = c;
  40.       a = a + 1;
  41.     end;
  42.     end emitn;
  43.  
  44. emit$bcd: procedure(b);
  45.     declare b byte;
  46.     call emitchar('0'+b);
  47.     end emit$bcd;
  48.  
  49. emit$bcd$pair: procedure(b);
  50.     declare b byte;
  51.     call emit$bcd(shr(b,4));
  52.     call emit$bcd(b and 0fh);
  53.     end emit$bcd$pair;
  54.  
  55. emit$colon: procedure(b);
  56.     declare b byte;
  57.     call emit$bcd$pair(b);
  58.     call emitchar(':');
  59.     end emit$colon;
  60.  
  61. emit$bin$pair: procedure(b);
  62.     declare b byte;
  63.     call emit$bcd(b/10);    /* makes garbage if not < 10 */
  64.     call emit$bcd(b mod 10);
  65.     end emit$bin$pair;
  66.  
  67. emit$slant: procedure(b);
  68.     declare b byte;
  69.     call emit$bin$pair(b);
  70.     call emitchar('/');
  71.     end emit$slant;
  72.  
  73. declare
  74.     base$year lit '78',   /* base year for computations */
  75.     base$day  lit '0',    /* starting day for base$year 0..6 */
  76.     month$days (*) address data
  77.     /* jan feb mar apr may jun jul aug sep oct nov dec */
  78.     (  000,031,059,090,120,151,181,212,243,273,304,334);
  79.  
  80. leap$days: procedure(y,m) byte;
  81.     declare (y,m) byte;
  82.     /* compute days accumulated by leap years */
  83.     declare yp byte;
  84.     yp = shr(y,2); /* yp = y/4 */
  85.     if (y and 11b) = 0 and month$days(m) < 59 then
  86.         /* y not 00, y mod 4 = 0, before march, so not leap yr */
  87.         return yp - 1;
  88.     /* otherwise, yp is the number of accumulated leap days */
  89.     return yp;
  90.     end leap$days;
  91.  
  92. declare word$value address;
  93.  
  94. get$next$digit: procedure byte;
  95.     /* get next lsd from word$value */
  96.     declare lsd byte;
  97.     lsd = word$value mod 10;
  98.     word$value = word$value / 10;
  99.     return lsd;
  100.     end get$next$digit;
  101.  
  102. bcd:
  103.   procedure (val) byte;
  104.     declare val byte;
  105.     return shl((val/10),4) + val mod 10;
  106.   end bcd;
  107.  
  108. declare (month, day, year, hrs, min, sec) byte;
  109.  
  110. bcd$pair: procedure(a,b) byte;
  111.     declare (a,b) byte;
  112.     return shl(a,4) or b;
  113.     end bcd$pair;
  114.  
  115.  
  116. compute$year: procedure;
  117.     /* compute year from number of days in word$value */
  118.     declare year$length address;
  119.     year = base$year;
  120.         do while true;
  121.         year$length = 365;
  122.         if (year and 11b) = 0 then /* leap year */
  123.             year$length = 366;
  124.         if word$value <= year$length then
  125.             return;
  126.         word$value = word$value - year$length;
  127.         year = year + 1;
  128.         end;
  129.     end compute$year;
  130.  
  131. declare
  132.     week$day  byte, /* day of week 0 ... 6 */
  133.     day$list (*) byte data
  134.     ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
  135.     leap$bias byte; /* bias for feb 29 */
  136.  
  137. compute$month: procedure;
  138.     month = 12;
  139.         do while month > 0;
  140.         if (month := month - 1) < 2 then /* jan or feb */
  141.             leapbias = 0;
  142.         if month$days(month) + leap$bias < word$value then return;
  143.         end;
  144.     end compute$month;
  145.  
  146. declare
  147.     date$test byte,    /* true if testing date */
  148.     test$value address;   /* sequential date value under test */
  149.  
  150. get$date$time: procedure;
  151.     /* get date and time */
  152.     hrs = tod.hrs;
  153.     min = tod.min;
  154.     sec = tod.sec;
  155.     word$value = tod.date;
  156.     /* word$value contains total number of days */
  157.     week$day = (word$value + base$day - 1) mod 7;
  158.     call compute$year;
  159.     /* year has been set, word$value is remainder */
  160.     leap$bias = 0;
  161.     if (year and 11b) = 0 and word$value > 59 then
  162.         /* after feb 29 on leap year */ leap$bias = 1;
  163.     call compute$month;
  164.     day = word$value - (month$days(month) + leap$bias);
  165.     month = month + 1;
  166.     end get$date$time;
  167.  
  168. emit$date$time: procedure;
  169.     if tod.opcode = 0 then
  170.       do;
  171.       call emitn(.day$list(shl(week$day,2)));
  172.       call emitchar(' ');
  173.       end;
  174.     call emit$slant(month);
  175.     call emit$slant(day);
  176.     call emit$bin$pair(year);
  177.     call emitchar(' ');
  178.     call emit$colon(hrs);
  179.     call emit$colon(min);
  180.     if tod.opcode = 0 then
  181.       call emit$bcd$pair(sec);
  182.     end emit$date$time;
  183.  
  184. tod$ASCII:
  185.   procedure (parameter);
  186.     declare parameter address;
  187.     declare ret address;
  188.  
  189.     ret = 0;
  190.     tod$adr = parameter;
  191.     string$adr = .tod.ASCII;
  192.     if    (tod.opcode = 0) or (tod.opcode = 3) then
  193.     do;
  194.       call get$date$time;
  195.       index = -1;
  196.       call emit$date$time;
  197.     end;
  198.     else
  199.       call terminate;             /* error */
  200. end tod$ASCII;
  201.  
  202.   declare lcltod structure (
  203.     opcode byte,
  204.     date address,
  205.     hrs byte,
  206.     min byte,
  207.     sec byte,
  208.     ASCII (21) byte );
  209.  
  210. display$time$stamp: procedure (tsadr) public;
  211.     dcl tsadr address,
  212.     i byte;
  213.  
  214.      lcltod.opcode = 3;        /* display time and date stamp, no seconds */
  215.      call move (4,tsadr,.lcltod.date);    /* don't copy seconds */
  216.          
  217.      call tod$ASCII (.lcltod);
  218.      do i = 0 to 13;
  219.        call printchar (lcltod.ASCII(i));
  220.      end;    
  221. end display$time$stamp;
  222.  
  223. dcl last$data$byte byte initial(0);
  224.  
  225. end timestamp;
  226.