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 / SHOW.PLM < prev    next >
Text File  |  1982-12-31  |  55KB  |  1,878 lines
  1. $ TITLE('CP/M 3.0 --- SHOW 3.1')
  2. /*
  3.    Revised:
  4.         Oct 82 by Phillip Balma
  5.      14 Sept 81 by Doug Huskey
  6. */
  7.  
  8. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  9.  
  10.  
  11.                        * * *  SHOW  * * *
  12.  
  13.  
  14.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  15.  
  16.  
  17. show:
  18. do;
  19. declare
  20.     mpm        literally '30h';
  21.  
  22. declare plm     label public;
  23.  
  24. declare copyright(*) byte data 
  25.     (' Copyright (c) 1982, Digital Research ');
  26.  
  27. declare verdate(*)      byte data('10/27/82'),
  28.         version(*)      byte data('Show 3.1');
  29.  
  30.  
  31. /*
  32.             copyright(c) 1975, 1976, 1977, 1978, 1979, 1980, 1981,1982
  33.             digital research
  34.             box 579
  35.             pacific grove, ca
  36.             93950
  37.  
  38.   */
  39.  
  40. /* modified 10/30/78 to fix the space computation */
  41. /* modified 01/28/79 to remove despool dependencies */
  42. /* modified 07/26/79 to operate under cp/m 2.0 */
  43. /* modified 01/20/80 by Thomas Rolander */
  44. /* show created 05/19/81 */
  45. /* modified 7/82 to add new options parser, # dir FCB's left, new DISK option,
  46.    # of files           by Phillip Balma */
  47. /* added paging, # SFCB's  Phillip Balma*/
  48.  
  49. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  50.  
  51.  
  52.                   * * *  DISK INTERFACE * * *
  53.  
  54.  
  55.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  56.  
  57.  
  58. declare         dcnt            byte,
  59.                 anything        byte,
  60.                 dirbuf(128)     byte;
  61.  
  62. declare 
  63.                 line$page       byte,
  64.                 line$out        byte,
  65.                 drives(16)      byte,
  66.                 drive           byte,
  67.                 all             byte initial(0),
  68.                 once$only       byte initial(0),
  69.                 done$drive(16)  byte initial(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
  70.  
  71.                 PAGE            byte initial(0),
  72.                 NONBANK         byte initial(0),
  73.  
  74.                 user(16)        byte,           /* any files in user i? */
  75.                 used(16)        address,        /* # files in user i */
  76.                 free$dir        address,        /* # free directories */
  77.                 nSFCB           address,        /* # SFCB's */
  78.  
  79.                 SCBPB           structure(
  80.                  where          byte,
  81.                  set            byte,
  82.                  value          address) initial(0,0,0),
  83.  
  84.                 ERRORM(*)       byte data('ERROR: ',0),
  85.                 input(*)        byte data('INPUT: ',0),
  86.                 eoption(*)      byte data('OPTION: ',0),
  87.                 dirdrive(*)     byte data('DRIVE: ',0),
  88.  
  89.                 err$unrecopt(*) byte data('Unrecognized Option.',0),
  90.                 err$unrecd(*)   byte data('Unrecognized drive.',0),
  91.                 err$version(*)  byte data('Requires CP/M 3 or higher.',0),
  92.                 err$nolabel(*)  byte 
  93.                                 data('No directory label exists on drive ',0),
  94.                 err$input(*)    byte data('Unrecognized input.',0),
  95.  
  96.                 opt$dir         byte data(1),
  97.                 opt$drive       byte data(2),
  98.                 opt$label       byte data(3),
  99.                 opt$space       byte data(0),
  100.                 opt$user        byte data(4),
  101.                 opt$page        byte data(6),          /*rel to 1 */
  102.                 opt$nopage      byte data(7);
  103.  
  104.         declare
  105.  
  106.                 dirs(*) byte data
  107.                              ('A:0B:0C:0D:0E:0F:0G:0H:0I:0J:0K:0L:0M:0N:0',
  108.                               'O:0P:',0ffh),
  109.                 options(*) byte data('SPACE0DIRECTORY0DRIVES0LABEL0USERS0',
  110.                                       'PAGE0NOPAGE',0ffh),
  111.  
  112.                 off$dirs(*) byte data(0,3,6,9,12,15,18,21,24,27,30,33,36,39,42,
  113.                                      45,47),
  114.                 off$opt(*) byte data(0,6,16,23,29,35,40,46),
  115.  
  116.                 end$list        byte data (0ffh),
  117.                 end$of$string   byte data (0),
  118.  
  119.                 delimiters(*) byte data (0,'[]=, :;<>%\|"()/#!@&+-*?',0,0ffh),
  120.                 SPACE           byte data(5),   /* index into delim to space */
  121.                 EOS             byte data(25),
  122.                 COMMA           byte data(4),
  123.                 COLON           byte data(6),
  124.                 LBRACKET        byte data(1),
  125.                 RBRACKET        byte data(2),
  126.  
  127.                 opt$map(21)     structure ( option(5) byte),
  128.  
  129.                 j               byte initial(0),
  130.                 buf$ptr         address,
  131.                 opt$index       byte,
  132.                 endbuf          byte,
  133.                 delimiter       byte;
  134. $ eject
  135.  
  136. declare
  137.         maxb            address external,       /* addr field of jmp BDOS */
  138.         fcb(33)         byte external,          /* default fcb */
  139.         buff(128)       byte external,          /* default buffer */
  140.         fcba            literally '.fcb',       /* default fcb */
  141.         dolla           literally '.fcb(6dh-5ch)',      /* $ position */
  142.         rreca           literally '.fcb(7dh-5ch)',      /* ran rcd 7d,7e,7f */
  143.         rreco           literally '.fcb(7fh-5ch)',      /* ran overflow */
  144.         sectorlen       literally '128',                /* sector length */
  145.         rrec            address at(rreca),      /* random record address */
  146.         rovf            byte at(rreco),         /* overflow on getfile */
  147.         doll            byte at(dolla),         /* dollar parameter */
  148.         user$code       byte,                   /* current user code */
  149.         cversion        address,                /* BDOS version # */
  150.         cdisk           byte,                   /* current disk  */
  151.  
  152. /* function call 32 returns the address of the disk parameter
  153. block for the currently selected disk, which consists of:
  154.         scptrk      (2 by) number of sectors per track
  155.         blkshf      (1 by) log2 of blocksize (2**blkshf=blksize)
  156.         blkmsk      (1 by) 2**blkshf-1
  157.         extmsk      (1 by) logical/physical extents
  158.         maxall      (2 by) max alloc number
  159.         dirmax      (2 by) size of directory-1
  160.         alloc       (2 by) reservation bits for directory
  161.         chksiz      (2 by) size of checksum vector
  162.         offset      (2 by) offset for operating system
  163.         psh         (1 by) log2 of physical record size(2**psh * 128 = size)
  164.         psm         (1 by) 2**psh - 1 
  165. */
  166.  
  167.         dpba            address,         /* disk parameter block address */
  168.         dpb             based dpba structure(
  169.                 spt     address, 
  170.                 bls     byte, 
  171.                 bms     byte, 
  172.                 exm     byte, 
  173.                 mxa     address,
  174.                 dmx     address, 
  175.                 dbl     address, 
  176.                 cks     address, 
  177.                 ofs     address,
  178.                 psh     byte,
  179.                 psm     byte),
  180.  
  181.         scptrk  literally 'dpb.spt',
  182.         blkshf  literally 'dpb.bls',
  183.         blkmsk  literally 'dpb.bms',
  184.         extmsk  literally 'dpb.exm',
  185.         maxall  literally 'dpb.mxa',
  186.         dirmax  literally 'dpb.dmx',
  187.         dirblk  literally 'dpb.dbl',
  188.         chksiz  literally 'dpb.cks',
  189.         offset  literally 'dpb.ofs',
  190.         physhf  literally 'dpb.psh',
  191.         phymsk  literally 'dpb.psm';
  192.  
  193.  
  194. boot: procedure external;
  195.     /* reboot */
  196.     end boot;
  197.  
  198. mon1: procedure(f,a) external;
  199.     declare f byte, a address;
  200.     end mon1;
  201.  
  202. mon2: procedure(f,a) byte external;
  203.     declare f byte, a address;
  204.     end mon2;
  205.  
  206. declare mon3 literally 'mon2a';
  207.  
  208. mon3: procedure(f,a) address external;
  209.     declare f byte, a address;
  210.     end mon3;
  211.  
  212. declare alloca address,
  213.     /* alloca is the address of the disk allocation vector */
  214.     alloc based alloca (1024) byte;  /* allocation vector */
  215.  
  216. declare
  217.     true        literally '1',
  218.     false       literally '0',
  219.     forever     literally 'while true',
  220.     lit         literally 'literally',
  221.     proc        literally 'procedure',
  222.     dcl         literally 'declare',
  223.     addr        literally 'address',
  224.     ctlc        literally '3',
  225.     cr          literally '13',
  226.     lf          literally '10';
  227.  
  228.  
  229. printchar: procedure(char);
  230.     declare char byte;
  231.     call mon1(2,char);
  232. end printchar;
  233.  
  234. printb: procedure;
  235.                         /* print blank character */
  236.     call printchar(' ');
  237. end printb;
  238.  
  239. printx: procedure(a);
  240.     declare a address;
  241.     declare s based a byte;
  242.  
  243.         do while s <> 0;
  244.                 call printchar(s);
  245.                 a = a + 1;
  246.         end;
  247.  
  248. end printx;
  249.  
  250. break: procedure byte;
  251.     return mon2(11,0);          /* console ready */
  252. end break;
  253.  
  254.  
  255. crlf2: procedure;
  256.  
  257.         call printchar(cr);
  258.         call printchar(lf);
  259.  
  260. end crlf2;
  261.  
  262.  
  263. terminate: procedure;
  264.         call crlf2;
  265.         call mon1 (0,0);                                /* system reset */
  266. end terminate;
  267.  
  268.  
  269.  
  270. crlf: procedure;
  271.  
  272.     if PAGE then do;
  273.                 line$out = line$out + 1;
  274.                 if line$out + 2 > line$page then do;
  275.  
  276.                         call crlf2;
  277.                         call crlf2;
  278.  
  279.                         call printx(.('Press RETURN to continue.',0));
  280.  
  281.                         do while not break;     /* wait until a console break*/
  282.                         end;
  283.                         if mon2(1,0) = ctlc then call terminate;
  284.                         line$out = 1;
  285.                         call crlf2;
  286.                 end;
  287.     end;
  288.  
  289.         call crlf2;
  290.  
  291. end crlf;
  292.  
  293.  
  294. print: procedure(a);
  295.     declare a address;
  296.                         /* print the string starting at address a until the
  297.                            next 0 is encountered */
  298.     call crlf;
  299.     call printx(a);
  300.  
  301. end print;
  302.  
  303.  
  304. get$version: procedure byte;
  305.                                 /* returns current cp/m version # */
  306.     return mon3(12,0);
  307. end get$version;
  308.  
  309. select: procedure(d);
  310.     declare d byte;
  311.  
  312.     call mon1(14,d);
  313. end select;
  314.  
  315. check$user: procedure;
  316.     do forever;
  317.         if anything then return;
  318.         if dcnt = 0ffh then return;
  319.         if dirbuf(ror (dcnt,3) and 110$0000b) = user$code then return;
  320.  
  321.         dcnt = mon2(18,0);
  322.  
  323.     end;
  324. end check$user;
  325.  
  326. search: procedure(fcb);
  327.     declare fcb address;
  328.     declare fcb0 based fcb byte;
  329.  
  330.     anything = (fcb0 = '?');
  331.     dcnt = mon2(17,fcb);
  332.     call check$user;
  333. end search;
  334.  
  335. searchn: procedure;
  336.     dcnt = mon2(18,0);
  337.     call check$user;
  338. end searchn;
  339.  
  340. cselect: procedure byte;
  341.                                         /* return current disk number */
  342.     return mon2(25,0);
  343. end cselect;
  344.  
  345. setdma: procedure(dma);
  346.     declare dma address;
  347.  
  348.     call mon1(26,dma);
  349. end setdma;
  350.  
  351. getalloca: procedure address;
  352.                                         /* get base address of alloc vector */
  353.     return mon3(27,0);
  354. end getalloca;
  355.  
  356. getlogin: procedure address;
  357.                                         /* get the login vector */
  358.     return mon3(24,0);
  359. end getlogin;
  360.  
  361. getpage: procedure byte;                /* get the conole page length */
  362.  
  363.         SCBPB.where = 01ch;
  364.         return mon2(49,.SCBPB);
  365.  
  366. end getpage;
  367.  
  368. getpagemode: procedure byte;
  369.  
  370.         SCBPB.where = 02ch;
  371.         return mon2(49,.SCBPB);
  372.  
  373. end getpagemode;
  374.  
  375. getNB: procedure byte;
  376.        SCBPB.where = 05dh;
  377.        return high(mon3(49,.SCBPB));
  378. end getNB;
  379.  
  380. getrodisk: procedure address;
  381.                                         /* get the read-only disk vector */
  382.     return mon3(29,0);
  383. end getrodisk;
  384.  
  385. /*setind: procedure;
  386.     call mon1(30,fcba);
  387. end setind;
  388. */
  389.  
  390. set$dpb: procedure;
  391.                                         /* set disk parameter block values */
  392.     dpba = mon3(31,0);                  /* base of dpb */
  393. end set$dpb;
  394.  
  395. getuser: procedure byte;
  396.                                         /* return current user number */
  397.     return mon2(32,0ffh);
  398. end getuser;
  399.  
  400. /*setuser: procedure(user);
  401.     declare user byte;
  402.  
  403.     call mon1(32,user);
  404. end setuser;
  405. */
  406.  
  407. getfreesp: procedure(d);
  408.     declare d byte;
  409.  
  410.     call mon1(46,d);
  411. end getfreesp;
  412.  
  413. getlbl: procedure(d) byte;
  414.     declare d byte;
  415.  
  416.     return mon2(101,d);
  417. end getlbl;
  418.  
  419. e$print: procedure(msg);
  420.         declare msg     address;
  421.  
  422.         call print(.ERRORM);
  423.         call printx(msg);
  424.  
  425. end e$print;
  426.  
  427.  
  428. /*****************************************************
  429.  
  430.           Time & Date ASCII Conversion Code
  431.  
  432.  *****************************************************/
  433.  
  434. declare tod$adr address;
  435. declare tod based tod$adr structure (
  436.   opcode byte,
  437.   date address,
  438.   hrs byte,
  439.   min byte,
  440.   sec byte,
  441.   ASCII (21) byte );
  442.  
  443. declare string$adr address;
  444. declare string based string$adr (1) byte;
  445. declare index byte;
  446.  
  447. emitchar: procedure(c);
  448.     declare c byte;
  449.     string(index := index + 1) = c;
  450.     end emitchar;
  451.  
  452. emitn: procedure(a);
  453.     declare a address;
  454.     declare c based a byte;
  455.     do while c <> '$';
  456.       string(index := index + 1) = c;
  457.       a = a + 1;
  458.     end;
  459.     end emitn;
  460.  
  461.  
  462. emit$bcd: procedure(b);
  463.     declare b byte;
  464.     call emitchar('0'+b);
  465.     end emit$bcd;
  466.  
  467. emit$bcd$pair: procedure(b);
  468.     declare b byte;
  469.     call emit$bcd(shr(b,4));
  470.     call emit$bcd(b and 0fh);
  471.     end emit$bcd$pair;
  472.  
  473. emit$colon: procedure(b);
  474.     declare b byte;
  475.     call emit$bcd$pair(b);
  476.     call emitchar(':');
  477.     end emit$colon;
  478.  
  479. emit$bin$pair: procedure(b);
  480.     declare b byte;
  481.     call emit$bcd(b/10);        /* makes garbage if not < 10 */
  482.     call emit$bcd(b mod 10);
  483.     end emit$bin$pair;
  484.  
  485. emit$slant: procedure(b);
  486.     declare b byte;
  487.     call emit$bin$pair(b);
  488.     call emitchar('/');
  489.     end emit$slant;
  490.  
  491. declare chr byte;
  492.  
  493. gnc: procedure;
  494.     /* get next command byte */
  495.     if chr = 0 then return;
  496.     if index = 20 then
  497.     do;
  498.       chr = 0;
  499.       return;
  500.     end;
  501.     chr = string(index := index + 1);
  502.     end gnc;
  503.  
  504. deblank: procedure;
  505.         do while chr = ' ';
  506.         call gnc;
  507.         end;
  508.     end deblank;
  509.  
  510. numeric: procedure byte;
  511.     /* test for numeric */
  512.     return (chr - '0') < 10;
  513.     end numeric;
  514.  
  515. scan$numeric: procedure(lb,ub) byte;
  516.     declare (lb,ub) byte;
  517.     declare b byte;
  518.     b = 0;
  519.     call deblank;
  520.     if not numeric then call terminate;
  521.         do while numeric;
  522.         if (b and 1110$0000b) <> 0 then call terminate;
  523.         b = shl(b,3) + shl(b,1); /* b = b * 10 */
  524.         if carry then call terminate;
  525.         b = b + (chr - '0');
  526.         if carry then call terminate;
  527.         call gnc;
  528.         end;
  529.     if (b < lb) or (b > ub) then call terminate;
  530.     return b;
  531.     end scan$numeric;
  532.  
  533. scan$delimiter: procedure(d,lb,ub) byte;
  534.     declare (d,lb,ub) byte;
  535.     call deblank;
  536.     if chr <> d then call terminate;
  537.     call gnc;
  538.     return scan$numeric(lb,ub);
  539.     end scan$delimiter;
  540.  
  541. declare
  542.     base$year lit '78',   /* base year for computations */
  543.     base$day  lit '0',    /* starting day for base$year 0..6 */
  544.     month$size (*) byte data
  545.     /* jan feb mar apr may jun jul aug sep oct nov dec */
  546.     (   31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
  547.     month$days (*) address data
  548.     /* jan feb mar apr may jun jul aug sep oct nov dec */
  549.     (  000,031,059,090,120,151,181,212,243,273,304,334);
  550.  
  551. leap$days: procedure(y,m) byte;
  552.     declare (y,m) byte;
  553.     /* compute days accumulated by leap years */
  554.     declare yp byte;
  555.     yp = shr(y,2); /* yp = y/4 */
  556.     if (y and 11b) = 0 and month$days(m) < 59 then
  557.         /* y not 00, y mod 4 = 0, before march, so not leap yr */
  558.         return yp - 1;
  559.     /* otherwise, yp is the number of accumulated leap days */
  560.     return yp;
  561.     end leap$days;
  562.  
  563. declare word$value address;
  564.  
  565. bcd:
  566.   procedure (val) byte;
  567.     declare val byte;
  568.     return shl((val/10),4) + val mod 10;
  569.   end bcd;
  570.  
  571. declare (month, day, year, hrs, min, sec) byte;
  572.  
  573.  set$date$time: procedure;
  574.     declare
  575.         (i, leap$flag) byte; /* temporaries */
  576.     month = scan$numeric(1,12) - 1;
  577.     /* may be feb 29 */
  578.     if (leap$flag := month = 1) then i = 29;
  579.         else i = month$size(month);
  580.     day   = scan$delimiter('/',1,i);
  581.     year  = scan$delimiter('/',base$year,99);
  582.     /* ensure that feb 29 is in a leap year */
  583.     if leap$flag and day = 29 and (year and 11b) <> 0 then
  584.         /* feb 29 of non-leap year */ call terminate;
  585.     /* compute total days */
  586.     tod.date = month$days(month)
  587.                 + 365 * (year - base$year)
  588.                 + day
  589.                 - leap$days(base$year,0)
  590.                 + leap$days(year,month);
  591.  
  592.     tod.hrs   = bcd (scan$numeric(0,23));
  593.     tod.min   = bcd (scan$delimiter(':',0,59));
  594.     if tod.opcode = 2 then
  595.     /* date, hours and minutes only */
  596.     do;
  597.       if chr = ':'
  598.         then i = scan$delimiter (':',0,59);
  599.       tod.sec = 0;
  600.     end;
  601.     /* include seconds */
  602.     else tod.sec   = bcd (scan$delimiter(':',0,59));
  603.  
  604.     end set$date$time;
  605.  
  606. bcd$pair: procedure(a,b) byte;
  607.     declare (a,b) byte;
  608.     return shl(a,4) or b;
  609.     end bcd$pair;
  610.  
  611.  
  612. compute$year: procedure;
  613.     /* compute year from number of days in word$value */
  614.     declare year$length address;
  615.     year = base$year;
  616.         do forever;
  617.         year$length = 365;
  618.         if (year and 11b) = 0 then /* leap year */
  619.             year$length = 366;
  620.         if word$value <= year$length then
  621.             return;
  622.         word$value = word$value - year$length;
  623.         year = year + 1;
  624.         end;
  625.     end compute$year;
  626.  
  627. declare
  628.     week$day  byte, /* day of week 0 ... 6 */
  629.     day$list (*) byte data
  630.     ('Sun$Mon$Tue$Wed$Thu$Fri$Sat$'),
  631.     leap$bias byte; /* bias for feb 29 */
  632.  
  633. compute$month: procedure;
  634.     month = 12;
  635.         do while month > 0;
  636.         if (month := month - 1) < 2 then /* jan or feb */
  637.             leapbias = 0;
  638.         if month$days(month) + leap$bias < word$value then return;
  639.         end;
  640.     end compute$month;
  641.  
  642. get$date$time: procedure;
  643.     /* get date and time */
  644.     hrs = tod.hrs;
  645.     min = tod.min;
  646.     sec = tod.sec;
  647.     word$value = tod.date;
  648.     /* word$value contains total number of days */
  649.     week$day = (word$value + base$day - 1) mod 7;
  650.     call compute$year;
  651.     /* year has been set, word$value is remainder */
  652.     leap$bias = 0;
  653.     if (year and 11b) = 0 and word$value > 59 then
  654.         /* after feb 29 on leap year */ leap$bias = 1;
  655.     call compute$month;
  656.     day = word$value - (month$days(month) + leap$bias);
  657.     month = month + 1;
  658.     end get$date$time;
  659.  
  660. emit$date$time: procedure;
  661.     if tod.opcode = 0 then
  662.       do;
  663.       call emitn(.day$list(shl(week$day,2)));
  664.       call emitchar(' ');
  665.       end;
  666.     call emit$slant(month);
  667.     call emit$slant(day);
  668.     call emit$bin$pair(year);
  669.     call emitchar(' ');
  670.     call emit$colon(hrs);
  671.     call emit$colon(min);
  672.     if tod.opcode = 0 then
  673.       call emit$bcd$pair(sec);
  674.     end emit$date$time;
  675.  
  676. tod$ASCII:
  677.   procedure (parameter);
  678.     declare parameter address;
  679.     declare ret address;
  680.  
  681.     ret = 0;
  682.     tod$adr = parameter;
  683.     string$adr = .tod.ASCII;
  684.     if  (tod.opcode = 0) or
  685.         (tod.opcode = 3) then
  686.     do;
  687.       call get$date$time;
  688.       index = -1;
  689.       call emit$date$time;
  690.     end;
  691.     else
  692.     do;
  693.       if (tod.opcode = 1) or
  694.          (tod.opcode = 2) then
  695.       do;
  696.         chr = string(index:=0);
  697.         call set$date$time;
  698.         ret = .string(index);
  699.       end;
  700.       else
  701.       do;
  702.         call terminate;
  703.       end;
  704.     end;
  705.   end tod$ASCII;
  706.  
  707. /********************************************************
  708.  
  709.  
  710.                   TOD INTERFACE TO SHOW
  711.  
  712.  
  713.  ********************************************************/
  714.  
  715.  
  716.   declare lcltod structure (
  717.     opcode byte,
  718.     date address,
  719.     hrs byte,
  720.     min byte,
  721.     sec byte,
  722.     ASCII (21) byte );
  723.  
  724. /*  declare extrnl$todadr address;
  725.   declare extrnl$tod based extrnl$todadr structure (
  726.     date address,
  727.     hrs byte,
  728.     min byte,
  729.     sec byte );
  730. */
  731.  
  732.   declare ret address;
  733.  
  734. /*  display$tod:
  735.     procedure;
  736.       lcltod.opcode = 0; 
  737.       call move (5,.extrnl$tod.date,.lcltod.date);
  738.       call tod$ASCII (.lcltod);
  739.       call write$console (0dh);
  740.       do i = 0 to 20;
  741.         call write$console (lcltod.ASCII(i));
  742.       end;
  743.     end display$tod; */
  744.  
  745.   display$ts:
  746.      procedure (tsadr);
  747.      dcl i byte;
  748.      dcl tsadr address;
  749.      lcltod.opcode = 3;         /* display time and date stamp, no seconds */
  750.      call move (4,tsadr,.lcltod.date);  /* don't copy seconds */
  751.      call tod$ASCII (.lcltod);
  752.      do i = 0 to 13;
  753.        call printchar (lcltod.ASCII(i));
  754.      end;       
  755.   end display$ts;
  756.  
  757. /******** End TOD Code ********/
  758.  
  759.  
  760.  
  761.  
  762. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  763.  
  764.  
  765.                        * * *  BASIC ROUTINES * * *
  766.  
  767.  
  768.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  769.  
  770.  
  771. declare
  772.     fcbmax literally '512'; /* max fcb count */
  773.  
  774. declare bpb address; /* bytes per block */
  775.  
  776.  
  777. set$bpb: procedure;
  778.  
  779.     call set$dpb;                               /* disk parameters set */
  780.     bpb = shl(double(1),blkshf) * sectorlen;
  781.  
  782. end set$bpb;
  783.  
  784.  
  785. select$disk: procedure(d);
  786.     declare d byte;
  787.                                                 /* select disk and set bpb */
  788.     call select(cdisk:=d);
  789.     call set$bpb;                               /* bytes per block */
  790.  
  791. end select$disk;
  792.  
  793.  
  794. getalloc: procedure(i) byte;    /* return the ith bit of the alloc vector */
  795.     declare i address;
  796.  
  797.     return
  798.     rol(alloc(shr(i,3)), (i and 111b) + 1);
  799.     end getalloc;
  800.  
  801.  
  802. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  803.  
  804.  
  805.                   /* fill string @ s for c bytes with f */
  806. fill:   proc(s,f,c);
  807.     dcl s addr,
  808.         (f,c) byte,
  809.         a based s byte;
  810.  
  811.         do while (c:=c-1)<>255;
  812.         a = f;
  813.         s = s+1;
  814.         end;
  815.     end fill;
  816.  
  817.  
  818. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  819.  
  820.  
  821.                    * * *  PRINT A NUMBER  * * *
  822.  
  823.  
  824.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  825.  
  826.  
  827. declare
  828.     val (7) byte initial(0,0,0,0,0,0,0),   /* BCD digits    */
  829.     fac (7) byte initial(0,0,0,0,0,0,0),   /* hibyte factor */
  830.     f0  (7) byte initial(6,3,5,5,6,0,0),   /*    65,536     */
  831.     f1  (7) byte initial(2,7,0,1,3,1,0),   /*   131,072     */
  832.     f2  (7) byte initial(4,4,1,2,6,2,0),   /*   262,144     */
  833.     f3  (7) byte initial(8,8,2,4,2,5,0),   /*   524,288     */
  834.     f4  (7) byte initial(6,7,5,8,4,0,1),   /* 1,048,576     */
  835.     f5  (7) byte initial(2,5,1,7,9,0,2),   /* 2,097,152     */
  836.     f6  (7) byte initial(4,0,3,4,9,1,4),   /* 4,194,304     */
  837.     ptr (7) address initial(.f0,.f1,.f2,.f3,.f4,.f5,.f6);
  838.  
  839.  
  840.  
  841.                   /* print decimal value of address v */
  842. pdecimal: procedure(v,prec,zerosup);
  843.     /* print value v with precision prec (1,10,100,1000,10000)
  844.     with leading zero suppression if zerosup = true */
  845.     declare
  846.         v address,    /* value to print */
  847.         prec address, /* precision */
  848.         zerosup byte, /* zero suppression flag */
  849.         d byte;       /* current decimal digit */
  850.  
  851.         do while prec <> 0;
  852.                 d = v / prec;           /* get next digit */
  853.                 v = v mod prec;         /* get remainder back to v */
  854.                 prec = prec/10;         /* ready for next digit */
  855.  
  856.                 if prec = 0 then go to pd0;
  857.                 if d <> 0 then go to pd0;
  858.                 if zerosup then do;
  859.                         call printb;
  860.                         go to pd1;
  861.                 end;
  862. pd0:                    zerosup = false;
  863.                         call printchar('0'+d);
  864. pd1:    end;
  865.  
  866. end pdecimal;
  867.  
  868. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  869.  
  870.  
  871.                   /* BCD - convert 16 bit binary to 
  872.                      7 one byte BCD digits */
  873. getbcd: procedure(value);
  874.     declare
  875.         (value,prec) address,
  876.         i byte;
  877.  
  878.     prec = 10000;
  879.     i = 5;                            /* digits: 4,3,2,1,0 */
  880.         do while prec <> 0;
  881.         val(i:=i-1) = value / prec;   /* get next digit */
  882.         value = value mod prec;       /* remainder in value */
  883.         prec = prec / 10;
  884.         end;
  885.     end getbcd;
  886. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  887.  
  888.  
  889.                   /* print BCD number in val array */
  890. printbcd: procedure;
  891.    declare 
  892.        (zerosup, i) byte;
  893.  
  894.    pchar: procedure(c);
  895.        declare c byte;
  896.        if val(i) = 0 then
  897.            if zerosup then 
  898.                if i <> 0 then do;
  899.                    call printb;
  900.                    return;
  901.                    end;
  902.        /* else */
  903.        call printchar(c);
  904.        zerosup = false;
  905.    end pchar;
  906.  
  907.    zerosup = true;
  908.    i = 7;
  909.        do while (i:=i-1) <> -1;
  910.        call pchar('0'+val(i));
  911.        if i = 6 or i = 3 then 
  912.            call pchar(',');
  913.        end;
  914.    end printbcd;
  915. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  916.  
  917.  
  918.                   /* add two BCD numbers result in second */
  919. add: procedure(ap,bp);
  920.     declare
  921.         (ap,bp)        address,
  922.         a based ap (7) byte,
  923.         b based bp (7) byte,
  924.         (c,i)          byte;
  925.  
  926.     c = 0;                               /* carry   */
  927.         do i = 0 to 6;                   /* 0 = LSB */
  928.         b(i) = a(i) + b(i) + c;
  929.         c = b(i) / 10;
  930.         b(i) = b(i) mod 10;
  931.         end;
  932.     end add;
  933. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  934.  
  935.  
  936.                   /* print 3 byte value based at byte3adr */
  937. p3byte: procedure(byte3adr);
  938.    declare
  939.       i         byte,  
  940.       high$byte byte,
  941.       byte3adr  address,
  942.       b3 based  byte3adr structure (
  943.           lword address,
  944.           hbyte byte);
  945.  
  946.     call fill(.val,0,7);
  947.     call fill(.fac,0,7);
  948.     call getbcd(b3.lword);         /* put 16 bit value in val */
  949.     high$byte = b3.hbyte;
  950.         do i = 0 to 6;                 /* factor for bit i */
  951.         if high$byte then              /* LSB is 1 */
  952.             call add(ptr(i),.fac);     /* add in factor */
  953.         high$byte = shr(high$byte,1);  /* get next bit  */
  954.         end;
  955.     call add(.fac,.val);              /* add factor to value */
  956.     call printbcd;                    /* print value */
  957.     end p3byte;
  958.  
  959.  
  960.         /* divide 3 byte value by 8 */
  961. shr3byte: procedure(byte3adr);
  962.       dcl byte3adr address,
  963.           b3 based byte3adr structure (
  964.           lword address,
  965.           hbyte byte),
  966.           temp1 based byte3adr (2) byte,
  967.           temp2 byte;
  968.  
  969.         temp2  = ror(b3.hbyte,3) and 11100000b;  /* get 3 bits */
  970.         b3.hbyte = shr(b3.hbyte,3);
  971.         b3.lword = shr(b3.lword,3);
  972.         temp1(1) = temp1(1) or temp2;   /* or in 3 bits from hbyte */
  973.         end shr3byte;
  974.  
  975.  
  976.         /* multiply 3 byte value by #records per block */
  977. shl3byte: procedure(byte3adr);
  978.       dcl byte3adr address,
  979.           b3 based byte3adr structure (
  980.           lword address,
  981.           hbyte byte),
  982.           temp1 based byte3adr (2) byte;
  983.  
  984.         b3.hbyte = (rol(temp1(1),blkshf) and blkmsk) or shl(b3.hbyte,blkshf);
  985.         b3.lword = shl(b3.lword,blkshf);
  986.         end shl3byte;
  987.  
  988.  
  989. show$drive: procedure;
  990.  
  991.         call printchar(cdisk+'A');
  992.         call printx(.(': ',0));
  993.  
  994. end show$drive;
  995.  
  996.  
  997.  
  998.  
  999. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1000.  
  1001.  
  1002.                 * * *  CALCULATE SIZE  * * *
  1003.  
  1004.  
  1005.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1006.  
  1007.  
  1008. add$block: procedure(ak,ab);
  1009.     declare (ak, ab) address;
  1010.     /* add one block to the kilobyte accumulator */
  1011.     declare kaccum based ak address; /* kilobyte accum */
  1012.     declare baccum based ab address; /* byte accum */
  1013.     baccum = baccum + bpb;
  1014.         do while baccum >= 1024;
  1015.         baccum = baccum - 1024;
  1016.         kaccum = kaccum + 1;
  1017.         end;
  1018.     end add$block;
  1019.  
  1020. count: procedure(mode) address;
  1021.     declare mode byte; /* true if counting 0's */
  1022.     /* count kb remaining, kaccum set upon exit */
  1023.     declare
  1024.         ka  address,  /* kb accumulator */
  1025.         ba  address,  /* byte accumulator */
  1026.         i   address,  /* local index */
  1027.         bit byte;     /* always 1 if mode = false */
  1028.     ka, ba = 0;
  1029.     bit = 0;
  1030.         do i = 0 to maxall;
  1031.         if mode then bit = getalloc(i);
  1032.         if not bit then call add$block(.ka,.ba);
  1033.         end;
  1034.     return ka;
  1035.     end count;
  1036.  
  1037.  
  1038.  
  1039.  
  1040. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1041.  
  1042.  
  1043.                  * * *  STATUS ROUTINES  * * *
  1044.  
  1045.  
  1046.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1047.  
  1048.  
  1049.  
  1050.                                   /* characteristics of current drive */
  1051. drivestatus: procedure;
  1052.       dcl b3a address,
  1053.           b3 based b3a structure (
  1054.              lword address,
  1055.              hbyte byte),
  1056.  
  1057.           psize address;
  1058.  
  1059.  
  1060.                                  /* print 3 byte value */
  1061.     pv3: procedure;
  1062.          call crlf;
  1063.          call p3byte(.dirbuf);
  1064.          call printchar(':');
  1065.          call printb;
  1066.     end pv3;
  1067.  
  1068.                                  /* print address value v */
  1069.      pv: procedure(v);
  1070.          dcl v address;
  1071.          b3.hbyte = 0;
  1072.          b3.lword = v;
  1073.          call pv3;
  1074.      end pv;
  1075.  
  1076.     /* print the characteristics of the currently selected drive */
  1077.  
  1078.     b3a = .dirbuf;
  1079.     call print(.('        ',0));
  1080.     call show$drive;
  1081.     call printx(.('Drive Characteristics',0));
  1082.     b3.hbyte = 0;
  1083.     b3.lword = maxall + 1;       /* = # blocks */
  1084.     call shl3byte(.dirbuf);        /* # blocks * records/block */
  1085.     call pv3;
  1086.     call printx(.('128 Byte Record Capacity',0));
  1087.     call shr3byte(.dirbuf);        /* divide by 8 */
  1088.     call pv3;
  1089.     call printx(.('Kilobyte Drive  Capacity',0));
  1090.     call pv(dirmax+1);
  1091.     call printx(.('32 Byte  Directory Entries',0));
  1092.     call pv(shl(chksiz,2));
  1093.     call printx(.('Checked  Directory Entries',0));
  1094.     call pv((extmsk+1) * 128);
  1095.     call printx(.('Records / Directory Entry',0));
  1096.     call pv(shl(double(1),blkshf));
  1097.     call printx(.('Records / Block',0));
  1098.     call pv(scptrk);
  1099.     call printx(.('Sectors / Track',0));
  1100.     call pv(offset);
  1101.     call printx(.('Reserved  Tracks',0));
  1102.  
  1103.         psize = 128;            /* 2**psh * 128 */
  1104.         if physhf > 0 then psize = shl(psize,physhf);
  1105.  
  1106.         call pv(psize);
  1107.         call printx(.('Bytes / Physical Record',0));
  1108.         call crlf;
  1109.  
  1110.     end drivestatus;
  1111. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1112.  
  1113.  
  1114. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1115.  
  1116.  
  1117.                        * * *  DISK STATUS  * * *
  1118.  
  1119.  
  1120.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1121.  
  1122.  
  1123. pvalue: procedure(v);
  1124.     declare (d,zero) byte,
  1125.         (k,v) address;
  1126.     k = 10000;
  1127.     zero = false;
  1128.         do while k <> 0;
  1129.         d = low(v/k); v = v mod k;
  1130.         k = k / 10;
  1131.         if zero or k = 0 or d <> 0 then
  1132.              do; zero = true; call printchar('0'+d);
  1133.              end;
  1134.         end;
  1135.     end pvalue;
  1136.  
  1137.  
  1138. prcount: procedure;
  1139.  
  1140.     /* print the actual byte count */
  1141.     if cversion < mpm then do;
  1142.         alloca = getalloca;
  1143.         call pvalue(count(true));
  1144.         end;
  1145.     else do;
  1146.         call setdma(.dirbuf);
  1147.         call getfreesp(cdisk);
  1148.         call shr3byte(.dirbuf);
  1149.         call p3byte(.dirbuf);
  1150.         end; 
  1151.     call printchar('k');
  1152.     end prcount;
  1153.  
  1154. stat: procedure(rodisk);
  1155.         declare rodisk address;
  1156.  
  1157.         call crlf;
  1158.         call show$drive;
  1159.         call printchar('R');
  1160.         if low(rodisk) then
  1161.             call printchar('O'); else
  1162.             call printchar('W');
  1163.         call printx(.(', Space: ',0));
  1164.         call prcount;
  1165.         end stat;
  1166.  
  1167. prstatus: procedure;            /* print the status of the disk system */
  1168.     declare (login, rodisk) address;
  1169.     declare (d,save) byte;
  1170.  
  1171.         if once$only then return;               /* only execute this once if 
  1172.                                                    all was specified > 1 */
  1173.  
  1174.         save = cdisk;
  1175.         login = getlogin;                       /* login vector set */
  1176.         rodisk = getrodisk;                     /* read only disk vector set */
  1177.  
  1178.         d = 0;
  1179.         do while login <> 0;
  1180.                 if low(login) then do; 
  1181.                         if not all then do;     /* do specified disk */
  1182.                            if d = save then call stat(rodisk);
  1183.                         end;
  1184.  
  1185.                         else do;
  1186.                                 call select$disk(d);    /* do all disks */
  1187.                                 call stat(rodisk);              
  1188.                         end;
  1189.                 end;
  1190.  
  1191.                 login = shr(login,1); rodisk = shr(rodisk,1);
  1192.                 d = d + 1;
  1193.         end;
  1194.  
  1195.         if all then once$only = true;
  1196.         call crlf;
  1197.  
  1198.     end prstatus;
  1199.  
  1200.  
  1201.  
  1202.  
  1203. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1204.  
  1205.  
  1206.                 * * *  USER STATUS * * *
  1207.  
  1208.  
  1209.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1210.  
  1211.  
  1212. prdir: procedure;
  1213.  
  1214.         call crlf;
  1215.         call crlf;
  1216.         call show$drive;
  1217.  
  1218.         if nSFCB > 0 then do;
  1219.                 call printx(.('Number of time/date directory entries: ',0));
  1220.                 call pdecimal(nSFCB,1000,true);
  1221.                 call crlf;
  1222.                 call show$drive;
  1223.         end;
  1224.  
  1225.         call printx(.('Number of free directory entries:      ',0));
  1226.         call pdecimal(free$dir,1000,true);
  1227.         call crlf;
  1228.  
  1229. end prdir;
  1230.  
  1231.  
  1232. get$usr$files: procedure;
  1233.         declare ufcb(*) byte data ('????????????',0,0,0),
  1234.                 (i,j)   byte,
  1235.                 nfcbs   address,
  1236.                 extptr  address,
  1237.                 modptr  address,
  1238.                 fmod    based modptr byte,
  1239.                 fext    based extptr byte;
  1240.  
  1241.         do i = 0 to 15;
  1242.                 user(i),used(i) = 0;
  1243.         end;
  1244.         nSFCB = 0;
  1245.  
  1246.         call setdma(.dirbuf);
  1247.         call search(.ufcb);
  1248.         nfcbs = 0;
  1249.  
  1250.         do while dcnt <> 255;
  1251.                 j = shl(dcnt,5);                /* which fcb in dirbuf */
  1252.  
  1253. ge0:            if (i := dirbuf(j)) <> 0e5h then do;
  1254.                   if i <> 33 then do;           /* SFCB ? */
  1255.                         extptr = .dirbuf(j + 12);
  1256.                         modptr = extptr + 2;
  1257.                         nfcbs = nfcbs + 1;
  1258.                         j = i;                  /* save for xfcb test */
  1259.                         user(i := i and 0fh) = true;
  1260.  
  1261.                         if j > 15 then go to ge2;
  1262.                         if fext > extmsk then go to ge2;
  1263.                         if fmod = 0 then used(i) = used(i) + 1;
  1264.                   end;
  1265.                   else nSFCB = nSFCB + 1;
  1266.                 end;
  1267.  
  1268. ge2:            call searchn;
  1269.         end;
  1270.  
  1271.         done$drive(cdisk) = true;
  1272.         if nSFCB > 0 then nSFCB = shr(dirmax+1,2);      /* because search ends
  1273.                                                            at high water mark*/
  1274.         free$dir = ((dirmax + 1) - nSFCB) - nfcbs;
  1275.  
  1276. end get$usr$files;
  1277.  
  1278.  
  1279. userstatus: procedure;          /* display active user numbers */
  1280.     declare i byte;
  1281.  
  1282.         call crlf;
  1283.         call show$drive;
  1284.         call printx(.('Active User : ',0));
  1285.         call pdecimal(getuser,1000,true);
  1286.         call crlf;
  1287.         call show$drive;
  1288.         call printx(.('Active Files: ',0));
  1289.  
  1290.         if not done$drive(cdisk) then call get$usr$files;
  1291.  
  1292.         do i = 0 to last(user);
  1293.                 if user(i) then call pdecimal(i,1000,true);
  1294.         end;
  1295.  
  1296.         call crlf;
  1297.         call show$drive;
  1298.         call printx(.('# of files  : ',0));
  1299.         do i = 0 to last(user);
  1300.                 if user(i) then call pdecimal(used(i),1000,true);
  1301.         end;
  1302.  
  1303.         call prdir;
  1304.  
  1305. end userstatus;
  1306.  
  1307.  
  1308.  
  1309. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1310.  
  1311.  
  1312.             * * *  DISK & FILE STATUS * * *
  1313.  
  1314.  
  1315.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1316.  
  1317.  
  1318.  
  1319. directory: procedure;
  1320.  
  1321.         if not done$drive(cdisk) then call get$usr$files;
  1322.         call prdir;
  1323.  
  1324. end directory;
  1325.  
  1326. /*******************************************************
  1327.  
  1328.                 L A B E L   S T A T U S
  1329.  
  1330. ********************************************************/
  1331.  
  1332. readlbl: proc(relog);
  1333.         declare relog   byte,
  1334.                 d       byte data('?');
  1335.  
  1336.     call setdma(.dirbuf);
  1337.     call search(.d);
  1338.     if relog > 0 then return;
  1339.  
  1340.     do while dcnt <> 0ffH;
  1341.         if dirbuf(ror(dcnt,3) and 110$0000b)=20H then return;
  1342.         call searchn;
  1343.     end;
  1344.  
  1345. end readlbl;
  1346.  
  1347. /* HEADER */
  1348.  
  1349. dcl label1 (*) byte data (
  1350. 'Directory     Passwds  Stamp   Stamp',0);
  1351. dcl label2 (*) byte data (
  1352. 'Label         Reqd     ',0);
  1353. dcl label3 (*) byte data (
  1354.                                     '  Update  Label Created   Label Updated',0)
  1355.  
  1356. ;
  1357. dcl label4 (*) byte data (
  1358. '------------  -------  ------  ------  --------------  --------------',0
  1359.  
  1360. );
  1361.  
  1362.  
  1363. labelstatus: procedure;
  1364.     dcl lbl             byte;
  1365.     dcl fnam lit '11';
  1366.     dcl ftyp lit '9';
  1367.     dcl fcbp address;
  1368.     dcl fcbv based fcbp (32) byte;      /* template over dirbuf */
  1369.  
  1370.   printfn: proc;                        /* print file name */
  1371.         declare k byte;
  1372.  
  1373.         do k = 1 to fnam;
  1374.                 if k = ftyp then 
  1375.                     call printchar('.');
  1376.                 call printchar(fcbv(k) and 7fh);
  1377.         end;
  1378.   end printfn;
  1379.  
  1380.  
  1381.     lbl = getlbl(cdisk);
  1382.     if lbl > 0 then do;
  1383.         call readlbl(0);
  1384.         fcbp = shl(dcnt,5) + .dirbuf;
  1385.  
  1386.         call print(.('Label for drive ',0));    /* print heading */
  1387.         call show$drive;
  1388.         call crlf;
  1389.         call print(.label1);
  1390.         call print(.label2);
  1391.         if (lbl and 40h) = 40h then
  1392.             call printx(.('Access',0));
  1393.         else
  1394.             call printx(.('Create',0));
  1395.         call printx(.label3);
  1396.         call print(.label4);
  1397.         call crlf;
  1398.         call printfn;
  1399.         if not NONBANK and ((lbl and 80h) = 80h) then
  1400.             call printx(.('    on   ',0));
  1401.         else
  1402.             call printx(.('    off  ',0));
  1403.  
  1404.         if (lbl and 40h) = 40h then
  1405.             call printx(.('   on   ',0));
  1406.         else if(lbl and 10h) = 10h then
  1407.             call printx(.('   on   ',0));
  1408.         else call printx(.('   off  ',0));
  1409.  
  1410.         if (lbl and 20h) = 20h then
  1411.             call printx(.('   on ',0));
  1412.         else
  1413.             call printx(.('   off',0));
  1414.  
  1415.         call printx(.('    ',0));
  1416.         call display$ts(.fcbv(24));
  1417.         call printx(.('  ',0));
  1418.         call display$ts(.fcbv(28));
  1419.         end;
  1420.     else do;
  1421.         call e$print(.err$nolabel);
  1422.         call printchar(cdisk+'A');
  1423.     end;
  1424.  
  1425.     call crlf;
  1426.  
  1427. end labelstatus;
  1428.  
  1429.  
  1430. $eject
  1431. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1432.  
  1433.  
  1434.                     * * *  Option scanner  * * *
  1435.  
  1436.  
  1437.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1438.  
  1439.  
  1440. separator: procedure(character) byte;
  1441.  
  1442.                                         /* determines if character is a 
  1443.                                            delimiter and which one */
  1444.         declare k       byte,
  1445.                 character       byte;
  1446.  
  1447.         k = 1;
  1448. loop:   if delimiters(k) = end$list then return(0);
  1449.         if delimiters(k) = character then return(k);    /* null = 25 */
  1450.                 k = k + 1;
  1451.                 go to loop;
  1452.  
  1453. end separator;
  1454.  
  1455. opt$scanner:    procedure(list$ptr,off$ptr) byte;
  1456.                                         /* scans the list pointed at by idxptr
  1457.                                            for any strings that are in the 
  1458.                                            list pointed at by list$ptr.
  1459.                                            Offptr points at an array that 
  1460.                                            contains the indices for the known
  1461.                                            list. Idxptr points at the index 
  1462.                                            into the list. If the input string
  1463.                                            is unrecognizable then the index is
  1464.                                            0, otherwise > 0.
  1465.  
  1466.                                         First, find the string in the known
  1467.                                         list that starts with the same first 
  1468.                                         character.  Compare up until the next
  1469.                                         delimiter on the input. if every input
  1470.                                         character matches then check for 
  1471.                                         uniqueness.  Otherwise try to find 
  1472.                                         another known string that has its first
  1473.                                         character match, and repeat.  If none
  1474.                                         can be found then return invalid.
  1475.  
  1476.                                         To test for uniqueness, start at the 
  1477.                                         next string in the knwon list and try
  1478.                                         to get another match with the input.
  1479.                                         If there is a match then return invalid.
  1480.  
  1481.                                         else move pointer past delimiter and 
  1482.                                         return.
  1483.  
  1484.                                 P.Balma         */
  1485.  
  1486.         declare
  1487.                 buff            based buf$ptr (1) byte,
  1488.                 off$ptr         address,
  1489.                 list$ptr        address;
  1490.  
  1491.         declare
  1492.                 i               byte,
  1493.                 j               byte,
  1494.                 list            based list$ptr (1) byte,
  1495.                 offsets         based off$ptr (1) byte,
  1496.                 wrd$pos         byte,
  1497.                 character       byte,
  1498.                 letter$in$word  byte,
  1499.                 found$first     byte,
  1500.                 start           byte,
  1501.                 index           byte,
  1502.                 save$index      byte,
  1503.                 (len$new,len$found)     byte,
  1504.                 valid           byte;
  1505.  
  1506. /*****************************************************************************/
  1507. /*                      internal subroutines                                 */
  1508. /*****************************************************************************/
  1509.  
  1510. check$in$list: procedure;
  1511.                                 /* find known string that has a match with 
  1512.                                    input on the first character.  Set index
  1513.                                    = invalid if none found.   */
  1514.                         
  1515.         declare i       byte;
  1516.  
  1517.         i = start;
  1518.         wrd$pos = offsets(i);
  1519.         do while list(wrd$pos) <> end$list;
  1520.                 i = i + 1;
  1521.                 index = i;
  1522.                 if list(wrd$pos) = character then return;
  1523.                 wrd$pos = offsets(i);
  1524.         end;
  1525.                         /* could not find character */
  1526.         index = 0;
  1527.         return;
  1528. end check$in$list;
  1529.  
  1530. setup:  procedure;
  1531.         character = buff(0);
  1532.         call check$in$list;
  1533.         letter$in$word = wrd$pos;
  1534.                         /* even though no match may have occurred, position
  1535.                            to next input character.  */
  1536.         i = 1;
  1537.         character = buff(1);
  1538. end setup;
  1539.  
  1540. test$letter:    procedure;
  1541.                         /* test each letter in input and known string */
  1542.  
  1543.         letter$in$word = letter$in$word + 1;
  1544.  
  1545.                                         /* too many chars input? 0 means
  1546.                                            past end of known string */
  1547.         if list(letter$in$word) = end$of$string then valid = false;
  1548.         else
  1549.         if list(letter$in$word) <> character then valid = false;
  1550.  
  1551.         i = i + 1;
  1552.         character = buff(i);
  1553.  
  1554. end test$letter;
  1555.  
  1556. skip:   procedure;
  1557.                                         /* scan past the offending string;
  1558.                                            position buf$ptr to next string...
  1559.                                            skip entire offending string;
  1560.                                            ie., falseopt=mod, [note: comma or
  1561.                                            space is considered to be group 
  1562.                                            delimiter] */
  1563.         character = buff(i);
  1564.         delimiter = separator(character);
  1565.         do while ((delimiter <> 2) and (delimiter <> 4) and (delimiter <> 5)
  1566.                    and (delimiter <> 25));
  1567.                 i = i + 1;
  1568.                 character = buff(i);
  1569.                 delimiter = separator(character);
  1570.         end;
  1571.         endbuf = i;
  1572.         buf$ptr = buf$ptr + endbuf + 1;
  1573.         return;
  1574. end skip;
  1575.  
  1576. eat$blanks: procedure;
  1577.  
  1578.         declare charac  based buf$ptr byte;
  1579.  
  1580.  
  1581.         do while(delimiter := separator(charac)) = SPACE;
  1582.                 bufptr = buf$ptr + 1;
  1583.         end;
  1584.  
  1585. end eat$blanks;
  1586.  
  1587. /*****************************************************************************/
  1588. /*                      end of internals                                     */
  1589. /*****************************************************************************/
  1590.  
  1591.  
  1592.                                         /* start of procedure */
  1593.         call eat$blanks;
  1594.         start = 0;
  1595.         call setup;
  1596.  
  1597.                                         /* match each character with the option
  1598.                                            for as many chars as input 
  1599.                                            Please note that due to the array
  1600.                                            indices being relative to 0 and the
  1601.                                            use of index both as a validity flag
  1602.                                            and as a index into the option/mods
  1603.                                            list, index is forced to be +1 as an
  1604.                                            index into array and 0 as a flag*/
  1605.  
  1606.         do while index <> 0;
  1607.                 start = index;
  1608.                 delimiter = separator(character);
  1609.  
  1610.                                         /* check up to input delimiter */
  1611.  
  1612.                 valid = true;           /* test$letter resets this */
  1613.                 do while delimiter = 0;
  1614.                         call test$letter;
  1615.                         if not valid then go to exit1;
  1616.                         delimiter = separator(character);
  1617.                 end;
  1618.  
  1619.                 go to good;
  1620.  
  1621.                                         /* input ~= this known string;
  1622.                                            get next known string that 
  1623.                                            matches */
  1624. exit1:          call setup;
  1625.         end;
  1626.                                         /* fell through from above, did
  1627.                                            not find a good match*/
  1628.         endbuf = i;                     /* skip over string & return*/
  1629.         call skip;
  1630.         return(index);
  1631.  
  1632.                                         /* is it a unique match in options
  1633.                                            list? */
  1634. good:   endbuf = i;
  1635.         len$found = endbuf;
  1636.         save$index = index;
  1637.         valid = false;
  1638. next$opt:
  1639.                 start = index;
  1640.                 call setup;
  1641.                 if index = 0 then go to finished;
  1642.  
  1643.                                         /* look at other options and check
  1644.                                            uniqueness */
  1645.  
  1646.                 len$new = offsets(index + 1) - offsets(index) - 1;
  1647.                 if len$new = len$found then do;
  1648.                         valid = true;
  1649.                         do j = 1 to len$found;
  1650.                                 call test$letter;
  1651.                                 if not valid then go to next$opt;
  1652.                         end;
  1653.                 end;
  1654.                 else go to nextopt;
  1655.                                         /* fell through...found another valid
  1656.                                            match --> ambiguous reference */
  1657.         index = 0;
  1658.         call skip;              /* skip input field to next delimiter*/
  1659.         return(0);
  1660.  
  1661. finished:                       /* unambiguous reference */
  1662.         index = save$index;
  1663.         buf$ptr = buf$ptr + endbuf;
  1664.         call eat$blanks;
  1665.         if delimiter <> 0 then  buf$ptr = buf$ptr + 1;
  1666.         else delimiter = SPACE;
  1667.         return(index);
  1668.  
  1669. end opt$scanner;
  1670.  
  1671. error$prt:      procedure;
  1672.         declare i       byte,
  1673.                 t       address,
  1674.                 char    based t byte;
  1675.  
  1676.         t = buf$ptr - endbuf - 1;
  1677.         do i = 1 to endbuf;
  1678.                 call printchar(char);
  1679.                 t = t + 1;
  1680.         end;
  1681.  
  1682. end error$prt;
  1683.  
  1684. $eject
  1685. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1686.  
  1687.  
  1688.                     * * *  EXECUTE * * *
  1689.  
  1690.  
  1691.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1692.  
  1693. do$option: procedure(i);
  1694.         declare i       byte;
  1695.  
  1696.  
  1697.                 if opt$map(i).option(opt$space) <> 0 then call prstatus;
  1698.                 if opt$map(i).option(opt$label) <> 0 then call labelstatus;
  1699.                 if opt$map(i).option(opt$drive) <> 0 then call drivestatus;
  1700.                 if opt$map(i).option(opt$user) <> 0 then call userstatus;
  1701.                 if opt$map(i).option(opt$dir) <> 0 then call directory;
  1702.  
  1703. end do$option;
  1704.  
  1705. $eject
  1706.  
  1707. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  1708.  
  1709.  
  1710.                     * * *  PARSING  * * *
  1711.  
  1712.  
  1713.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  1714.  
  1715. declare         character       based buf$ptr byte;
  1716.  
  1717. setdef$drive: procedure;
  1718.  
  1719.         if drive = 0ffh then do;
  1720.                 drive = cdisk;
  1721.                 drives(drive) = drive;
  1722.         end;
  1723.  
  1724.         return;
  1725.  
  1726. end setdef$drive;
  1727.  
  1728.  
  1729. parseoptions: procedure byte;
  1730.                                 /* find all options within [...] */
  1731.  
  1732.         buf$ptr = buf$ptr + 1;
  1733.         delimiter = separator(character);
  1734.         call setdef$drive;
  1735.  
  1736.         if delimiter = 0 then go to preloop;
  1737.         if delimiter <> RBRACKET then 
  1738.            if delimiter <> EOS then go to preloop;
  1739.  
  1740.                                                         /* [], turn on space */
  1741.         opt$map(drive).option(opt$space) = 1;
  1742.         buf$ptr = buf$ptr + 1;
  1743.         return(2);
  1744.  
  1745. preloop:
  1746.         if opt$map(drive).option(opt$space) = 0ffh then /* reset forced space*/
  1747.                 opt$map(drive).option(opt$space) = 0;
  1748.  
  1749. loop:   if (opt$index := optscanner(.options,.off$opt)) = 0 then go to error;
  1750.  
  1751.         if opt$index = opt$page then PAGE = true;
  1752.         else if opt$index = opt$nopage then PAGE = false;
  1753.         else opt$map(drive).option(opt$index - 1) = 1;
  1754.  
  1755.         go to looptest;
  1756.  
  1757. error:  call e$print(.err$unrecopt);
  1758.         call print(.eoption);
  1759.         call error$prt;
  1760.  
  1761. looptest:
  1762.         if delimiter = EOS then return(25);
  1763.         if delimiter = RBRACKET then return(2);
  1764.  
  1765.         go to loop;
  1766.  
  1767. end parseoptions;
  1768.  
  1769. parsedir: procedure;
  1770.  
  1771.         declare dirindex        byte;
  1772.  
  1773.         if (dir$index := optscanner(.dirs,.off$dirs)) = 0 then go to error1;
  1774.  
  1775.                 drive = dir$index - 1;
  1776.                 drives(drive) = drive;
  1777.                 opt$map(drive).option(opt$space) = 0ffh;/* only drive:,reset
  1778.                                                            if other options and
  1779.                                                            not space picked */
  1780.                 if delimiter <> COLON then buf$ptr = buf$ptr - 1;
  1781.  
  1782.         return;
  1783.  
  1784. error1: call e$print(.err$unrecd);
  1785. dprint: call print(.dirdrive);
  1786.         call error$prt;
  1787.         call terminate;
  1788.  
  1789. end parsedir;
  1790.  
  1791.  
  1792. parser: procedure;
  1793.  
  1794.         drive = 0ffh;
  1795.  
  1796.         if (delimiter := separator(character)) = EOS then do;
  1797.                 call setdef$drive;
  1798.                 opt$map(drive).option(opt$space) = 1;           /* default*/
  1799.                 all = true;
  1800.                 return;
  1801.         end;
  1802.  
  1803. loop:   if delimiter = LBRACKET then delimiter = parseoptions;
  1804.         else if delimiter = 0 then call parsedir;
  1805.  
  1806.         else do;
  1807.                 if delimiter <> COMMA then
  1808.                 if delimiter <> SPACE then go to error;
  1809.  
  1810.                 drive = 0ffh;
  1811.                 buf$ptr = buf$ptr + 1;
  1812.         end;
  1813.  
  1814.  
  1815. looptest:
  1816.         if delimiter <> EOS then
  1817.            if (delimiter := separator(character)) <> EOS then go to loop;
  1818.  
  1819.         return;
  1820.  
  1821. error:  call e$print(.err$input);
  1822.         call print(.input);
  1823.         call error$prt;
  1824.         call terminate;
  1825.  
  1826. end parser;
  1827.  
  1828. $eject
  1829. /*************************************************************************
  1830.  
  1831.  
  1832.                         ***  MAIN PROGRAM  ***
  1833.  
  1834.  
  1835. **************************************************************************/
  1836.  
  1837.         declare
  1838.                 i       byte initial(1);
  1839.  
  1840.         plm:
  1841.                 cversion = get$version;
  1842.                 if cversion < mpm then call e$print(.err$version);
  1843.                 else do;
  1844.  
  1845.                         do while buff(i) = ' ';
  1846.                                 i = i + 1;
  1847.                         end;
  1848.                         buf$ptr = .buff(i);
  1849.  
  1850.                         cdisk = cselect;
  1851.                         user$code = getuser;
  1852.  
  1853.                         do i = 0 to 15;
  1854.                                 drives(i) = 0ffh;
  1855.                         end;
  1856.  
  1857.                         if getpagemode = 0 then PAGE = true;
  1858.                         line$page = getpage;
  1859.                         line$out = 0;
  1860.                         if getNB = 0 then NONBANK = true;
  1861.  
  1862.                         call parser;
  1863.  
  1864.                         do i = 0 to 15;
  1865.                                 if (drive := drives(i)) <> 0ffh then do;
  1866.                                         call select$disk(drives(i));
  1867.                                         call readlbl(1); /* force login
  1868.                                                             by wild card drive
  1869.                                                             search.  */
  1870.                                         call do$option(i);
  1871.                                 end;
  1872.                         end;
  1873.  
  1874.                 end;
  1875.                 call terminate;
  1876.  
  1877. end;
  1878.