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 / SETDEF.PLM < prev    next >
Text File  |  1982-12-31  |  25KB  |  861 lines
  1. $ TITLE('CP/M 3.0 --- SETDEF')
  2. setdef:
  3. do;
  4.  
  5. /*
  6.   Copyright (C) 1982
  7.   Digital Research
  8.   P.O. Box 579
  9.   Pacific Grove, CA 93950
  10. */
  11.  
  12. /*
  13. Written:  27 July 82  by John Knight 
  14. Modified: 30 Sept 82  by Doug Huskey
  15. Modified: 03 Dec  82  by Bruce Skidmore
  16. */
  17.  
  18. /********************************************
  19. *                                           *
  20. *       LITERALS AND GLOBAL VARIABLES       *
  21. *                         *
  22. ********************************************/
  23.  
  24. declare
  25.     true            literally '1',
  26.     false           literally '0',
  27.     forever         literally 'while true',
  28.     lit             literally 'literally',
  29.     proc            literally 'procedure',
  30.     dcl             literally 'declare',
  31.     addr            literally 'address',
  32.     cr              literally '13',
  33.     tab            literally '9',
  34.     lf              literally '10',
  35.     ctrlc           literally '3',
  36.     ctrlx           literally '18h',
  37.     bksp            literally '8',
  38.     con$width$offset    literally '1ah',
  39.     drive0$offset    literally '4ch',
  40.     drive1$offset    literally '4dh',
  41.     drive2$offset    literally '4eh',
  42.     drive3$offset    literally '4fh',
  43.     temp$drive$offset    literally '50h',
  44.     ccp$flag1$offset    literally '17h',
  45.     ccp$flag2$offset    literally '18h',
  46.     pg$mode$offset    literally '2ch',
  47.     pg$def$offset    literally '2dh',
  48.     cpmversion        literally '30h';
  49.     
  50.   declare drive$table (4) byte;
  51.   declare order$table (2) byte initial(0);
  52.   declare drive (4) byte;
  53.   declare temp$drive byte;
  54.   declare ccp$flag1 byte;
  55.   declare ccp$flag2 byte;
  56.   declare con$width byte;
  57.   declare i byte;
  58.   declare begin$buffer address;
  59.   declare buf$length byte;
  60.  
  61.   /* display control variables */
  62.   declare show$drive   byte initial(true);
  63.   declare show$order   byte initial(true);
  64.   declare show$temp    byte initial(true);
  65.   declare show$page    byte initial(true);
  66.   declare show$display byte initial(true);
  67.  
  68.  
  69.   declare scbpd structure
  70.     (offset byte,
  71.      set    byte,
  72.      value  address);
  73.  
  74.   /* scanner variables and data */
  75.   declare
  76.     options(*) byte data
  77.         ('TEMPORARY~ORDER~PAGE~DISPLAY~NO~COM~SUB~NOPAGE~NODISPLAY',
  78.           '~ON~OFF',0ffh),
  79.         
  80.     options$offset(*) byte data
  81.         (0,10,16,21,29,32,36,40,47,57,60,63),
  82.  
  83.     drives(*) byte data
  84.         ('*~A:~B:~C:~D:~E:~F:~G:~H:~I:~J:~K:~',
  85.          'L:~M:~N:~O:~P:',0ffh),
  86.                    
  87.     drives$offset(*) byte data
  88.         (0,2,5,8,11,14,17,20,23,26,29,32,
  89.          35,38,41,44,47,49),
  90.  
  91.     end$list    byte data (0ffh),
  92.  
  93.     delimiters(*) byte data (0,'[]=, ./;()',0,0ffh),
  94.  
  95.     SPACE    byte data(5),
  96.     j        byte initial(0),
  97.     buf$ptr    address,
  98.     index    byte,
  99.     endbuf    byte,
  100.     delimiter    byte;
  101.     
  102.     declare end$of$string    byte initial ('~');
  103.  
  104.  declare plm label public;
  105.  
  106.   /**************************************
  107.    *                                    *
  108.    *       B D O S   INTERFACE          *
  109.    *                                    *
  110.    **************************************/
  111.  
  112.  
  113.   mon1:
  114.     procedure (func,info) external;
  115.       declare func byte;
  116.       declare info address;
  117.     end mon1;
  118.  
  119.   mon2:
  120.     procedure (func,info) byte external;
  121.       declare func byte;
  122.       declare info address;
  123.     end mon2;
  124.  
  125.   mon3:
  126.     procedure (func,info) address external;
  127.       declare func byte;
  128.       declare info address;
  129.     end mon3;
  130.  
  131.   declare cmdrv     byte    external;    /* command drive      */
  132.   declare fcb (1)   byte    external;    /* 1st default fcb    */
  133.   declare fcb16 (1) byte    external;    /* 2nd default fcb    */
  134.   declare pass0     address external;    /* 1st password ptr   */
  135.   declare len0      byte    external;    /* 1st passwd length  */
  136.   declare pass1     address external;    /* 2nd password ptr   */
  137.   declare len1      byte    external;    /* 2nd passwd length  */
  138.   declare tbuff (1) byte    external;    /* default dma buffer */
  139.  
  140.  
  141.   /**************************************
  142.    *                                    *
  143.    *       B D O S   Externals          *
  144.    *                                    *
  145.    **************************************/
  146.  
  147.   printchar: 
  148.     procedure(char);
  149.     declare char byte;
  150.     call mon1(2,char);
  151.     end printchar;
  152.  
  153.   print$buf:
  154.     procedure (buffer$address);
  155.       declare buffer$address address;
  156.       call mon1 (9,buffer$address);
  157.     end print$buf;
  158.  
  159.   version: procedure address;
  160.     /* returns current cp/m version # */
  161.     return mon3(12,0);
  162.     end version;
  163.  
  164.   getscbbyte: procedure (offset) byte;
  165.     declare offset byte;
  166.     scbpd.offset = offset;
  167.     scbpd.set = 0;
  168.     return mon2(49,.scbpd);
  169.   end getscbbyte;
  170.  
  171.   setscbbyte:
  172.     procedure (offset,value);
  173.     declare offset byte;
  174.     declare value byte;
  175.     scbpd.offset = offset;
  176.     scbpd.set = 0ffh;
  177.     scbpd.value = double(value);
  178.     call mon1(49,.scbpd);
  179.   end setscbbyte;
  180.     
  181.   /**************************************
  182.    *                                    *
  183.    *       S U B R O U T I N E S        *
  184.    *                                    *
  185.    **************************************/
  186.  
  187.  
  188. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  189.  
  190.  
  191.                     * * *  Option scanner  * * *
  192.  
  193.  
  194.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  195.  
  196.  
  197. separator: procedure(character) byte;
  198.  
  199.                     /* determines if character is a 
  200.                        delimiter and which one */
  201.     declare    k    byte,
  202.         character    byte;
  203.  
  204.     k = 1;
  205. loop:    if delimiters(k) = end$list then return(0);
  206.     if delimiters(k) = character then return(k);    /* null = 25 */
  207.         k = k + 1;
  208.         go to loop;
  209.  
  210. end separator;
  211.  
  212. opt$scanner:    procedure(list$ptr,off$ptr,idx$ptr);
  213.                     /* scans the list pointed at by idxptr
  214.                        for any strings that are in the 
  215.                        list pointed at by list$ptr.
  216.                        Offptr points at an array that 
  217.                        contains the indices for the known
  218.                        list. Idxptr points at the index 
  219.                        into the list. If the input string
  220.                        is unrecognizable then the index is
  221.                           0, otherwise > 0.
  222.  
  223.                     First, find the string in the known
  224.                     list that starts with the same first 
  225.                     character.  Compare up until the next
  226.                     delimiter on the input. if every input
  227.                     character matches then check for 
  228.                     uniqueness.  Otherwise try to find 
  229.                     another known string that has its first
  230.                     character match, and repeat.  If none
  231.                     can be found then return invalid.
  232.  
  233.                     To test for uniqueness, start at the 
  234.                     next string in the knwon list and try
  235.                     to get another match with the input.
  236.                     If there is a match then return invalid.
  237.  
  238.                     else move pointer past delimiter and 
  239.                     return.
  240.  
  241.                 P.Balma        */
  242.  
  243.     declare
  244.         buff        based buf$ptr (1) byte,
  245.         idx$ptr        address,
  246.         off$ptr        address,
  247.         list$ptr    address;
  248.  
  249.     declare
  250.         i        byte,
  251.         j        byte,
  252.         list        based list$ptr (1) byte,
  253.         offsets        based off$ptr (1) byte,
  254.         wrd$pos      byte,
  255.         character    byte,
  256.         letter$in$word    byte,
  257.         found$first    byte,
  258.         start        byte,
  259.         index        based idx$ptr byte,
  260.         save$index    byte,
  261.         (len$new,len$found)    byte,
  262.         valid        byte;
  263.  
  264. /*****************************************************************************/
  265. /*            internal subroutines                     */
  266. /*****************************************************************************/
  267.  
  268. check$in$list: procedure;
  269.                 /* find known string that has a match with 
  270.                    input on the first character.  Set index
  271.                    = invalid if none found.   */
  272.             
  273.     declare    i    byte;
  274.  
  275.     i = start;
  276.     wrd$pos = offsets(i);
  277.     do while list(wrd$pos) <> end$list;
  278.         i = i + 1;
  279.         index = i;
  280.         if list(wrd$pos) = character then return;
  281.         wrd$pos = offsets(i);
  282.     end;
  283.             /* could not find character */
  284.     index = 0;
  285.     return;
  286. end check$in$list;
  287.  
  288. setup:    procedure;
  289.     character = buff(0);
  290.     call check$in$list;
  291.     letter$in$word = wrd$pos;
  292.             /* even though no match may have occurred, position
  293.                to next input character.  */
  294.     i = 1;
  295.     character = buff(1);
  296. end setup;
  297.  
  298. test$letter:    procedure;
  299.             /* test each letter in input and known string */
  300.  
  301.     letter$in$word = letter$in$word + 1;
  302.  
  303.                     /* too many chars input? 0 means
  304.                        past end of known string */
  305.     if list(letter$in$word) = end$of$string then valid = false;
  306.     else
  307.     if list(letter$in$word) <> character then valid = false;
  308.  
  309.     i = i + 1;
  310.     character = buff(i);
  311.  
  312. end test$letter;
  313.  
  314. skip:    procedure;
  315.                     /* scan past the offending string;
  316.                        position buf$ptr to next string...
  317.                        skip entire offending string;
  318.                        ie., falseopt=mod, [note: comma or
  319.                        space is considered to be group 
  320.                        delimiter] */
  321.     character = buff(i);
  322.     delimiter = separator(character);
  323.     /* No skip for SETPATH */
  324.         do while ((delimiter < 1) or (delimiter > 11));
  325.         i = i + 1;
  326.         character = buff(i);
  327.         delimiter = separator(character);
  328.     end;
  329.     endbuf = i;
  330.     buf$ptr = buf$ptr + endbuf + 1;
  331.     return;
  332. end skip;
  333.  
  334. eat$blanks: procedure;
  335.  
  336.     declare    charac    based buf$ptr byte;
  337.  
  338.  
  339.     do while ((delimiter := separator(charac)) = SPACE);
  340.         buf$ptr = buf$ptr + 1;
  341.     end;
  342.  
  343. end eat$blanks;
  344.  
  345. /*****************************************************************************/
  346. /*            end of internals                     */
  347. /*****************************************************************************/
  348.  
  349.  
  350.                     /* start of procedure */
  351.     call eat$blanks;
  352.     start = 0;
  353.     call setup;
  354.  
  355.                     /* match each character with the option
  356.                        for as many chars as input 
  357.                        Please note that due to the array
  358.                        indices being relative to 0 and the
  359.                        use of index both as a validity flag
  360.                        and as a index into the option/mods
  361.                        list, index is forced to be +1 as an
  362.                        index into array and 0 as a flag*/
  363.  
  364.     do while index <> 0;
  365.         start = index;
  366.         delimiter = separator(character);
  367.  
  368.                     /* check up to input delimiter */
  369.  
  370.         valid = true;        /* test$letter resets this */
  371.         do while delimiter = 0;
  372.             call test$letter;
  373.             if not valid then go to exit1;
  374.             delimiter = separator(character);
  375.         end;
  376.  
  377.         go to good;
  378.  
  379.                     /* input ~= this known string;
  380.                        get next known string that 
  381.                        matches */
  382. exit1:        call setup;
  383.     end;
  384.                     /* fell through from above, did
  385.                        not find a good match*/
  386.     endbuf = i;            /* skip over string & return*/
  387.     call skip;
  388.     return;
  389.  
  390.                     /* is it a unique match in options
  391.                        list? */
  392. good:    endbuf = i;
  393.     len$found = endbuf;
  394.     save$index = index;
  395.     valid = false;
  396. next$opt:
  397.         start = index;
  398.         call setup;
  399.         if index = 0 then go to finished;
  400.  
  401.                     /* look at other options and check
  402.                        uniqueness */
  403.  
  404.         len$new = offsets(index + 1) - offsets(index) - 1;
  405.         if len$new = len$found then do;
  406.             valid = true;
  407.             do j = 1 to len$found;
  408.                 call test$letter;
  409.                 if not valid then go to next$opt;
  410.             end;
  411.         end;
  412.         else go to nextopt;
  413.                     /* fell through...found another valid
  414.                        match --> ambiguous reference */
  415.     index = 0;
  416.     call skip;        /* skip input field to next delimiter*/
  417.     return;
  418.  
  419. finished:            /* unambiguous reference */
  420.     index = save$index;
  421.     buf$ptr = buf$ptr + endbuf;
  422.     call eat$blanks;
  423.     if delimiter <> 0 then
  424.           buf$ptr = buf$ptr + 1;
  425.         else
  426.           delimiter = 5;
  427.     return;
  428.  
  429. end opt$scanner;
  430.  
  431. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  432.  
  433. crlf:   proc;
  434.     call printchar(cr);
  435.     call printchar(lf);
  436.     end crlf;
  437.  
  438. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  439.  
  440. /* The error processor.  This routine prints the command line
  441.   with a carot '^' under the offending delimiter, or sub-string.
  442.   The code passed to the routine determines the error message
  443.   to be printed beneath the command string.                  */
  444.  
  445. error: procedure (code);
  446.   declare (code,i,j,nlines,rem) byte;
  447.   declare (string$ptr,tstring$ptr) address;
  448.   declare chr1 based string$ptr byte;
  449.   declare chr2 based tstring$ptr byte;
  450.   declare carot$flag byte;
  451.  
  452. print$command: procedure (size);
  453.   declare size byte;
  454.   do j=1 to size;    /* print command string */
  455.     call printchar(chr1);
  456.     string$ptr = string$ptr + 1;
  457.   end;
  458.   call crlf;
  459.   do j=1 to size;    /* print carot if applicable */
  460.     if .chr2 = buf$ptr then do;
  461.       carot$flag = true;
  462.       call printchar('^');
  463.     end;
  464.     else
  465.       call printchar(' ');
  466.     tstring$ptr = tstring$ptr + 1;
  467.   end;
  468.   call crlf;
  469. end print$command;
  470.  
  471.   carot$flag = false;
  472.   string$ptr,tstring$ptr = begin$buffer;
  473.   con$width = getscbbyte(con$width$offset);
  474.   if con$width < 40 then con$width = 40;
  475.   nlines = buf$length / con$width;    /* num lines to print */
  476.   rem = buf$length mod con$width;    /* num extra chars to print */
  477.   if ((code = 1) or (code = 5)) then    /* adjust carot pointer */
  478.     buf$ptr = buf$ptr - 1;    /* for delimiter errors */
  479.   else
  480.     buf$ptr = buf$ptr - endbuf - 1;    /* all other errors */
  481.   call crlf;
  482.   do i=1 to nlines;
  483.     tstring$ptr = string$ptr;
  484.     call print$command(con$width);
  485.   end;
  486.   call print$command(rem);
  487.   if carot$flag then
  488.     call print$buf(.('Error at the ''^''; $'));
  489.   else
  490.     call print$buf(.('Error at end of line; $'));
  491.   if con$width < 65 then
  492.     call crlf;
  493.   do case code;
  494.     call print$buf(.('More than four drives specified$'));
  495.     call print$buf(.('Invalid delimiter$'));
  496.     call print$buf(.('Invalid drive$'));
  497.     call print$buf(.('Invalid type for ORDER option$'));
  498.     call print$buf(.('Invalid option$'));
  499.     call print$buf(.('End of line expected$'));
  500.     call print$buf(.('Drive defined twice in search path$'));
  501.     call print$buf(.('Invalid ORDER specification$'));
  502.     call print$buf(.('Must be ON or OFF$'));
  503.   end;
  504.   call crlf;
  505.   call mon1(0,0);
  506. end error;
  507.  
  508. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  509.  
  510. /* This is the main screen display for SETPATH.  After every
  511.    successful operation, this procedure will be called to 
  512.    show the results.  This routine is also called whenever the
  513.    user just types SETPATH with no options.                  */
  514.  
  515. display$path: procedure;
  516.   declare i byte;
  517.   declare (display$flag,pg$mode,order) byte;
  518.  
  519.   /* GET SETTINGS FROM SYSTEM CONTROL BLOCK */
  520.   drive(0)     = getscbbyte(drive0$offset);
  521.   drive(1)     = getscbbyte(drive1$offset);
  522.   drive(2)     = getscbbyte(drive2$offset);
  523.   drive(3)     = getscbbyte(drive3$offset);
  524.   temp$drive   = getscbbyte(temp$drive$offset);
  525.   pg$mode      = getscbbyte(pg$mode$offset);
  526.   ccp$flag2    = getscbbyte(ccp$flag2$offset);
  527.   display$flag = ccp$flag2 and 00$000$011b;
  528.   order        = shr((ccp$flag2 and 00$011$000b),3);  
  529.                  /* 0 = COM, 1 = COM,SUB, 2 = SUB,COM  */
  530.  
  531.   /* DRIVE SEARCH PATH */
  532.   if show$drive then do;
  533.     call crlf;
  534.     call print$buf(.('Drive Search Path:',cr,lf,'$'));
  535.     i = 0;
  536.     do while ((drive(i) <> 0ffh) and (i < 4));
  537.       call printchar(i + '1');
  538.       do case i;
  539.         call print$buf(.('st$'));
  540.         call print$buf(.('nd$'));
  541.         call print$buf(.('rd$'));
  542.         call print$buf(.('th$'));
  543.       end;
  544.          call print$buf(.(' Drive            - $'));
  545.       if drive(i) = 0 then
  546.         call print$buf(.('Default$'));
  547.       else do;
  548.         call printchar(drive(i) + 40h);
  549.         call printchar(':');
  550.       end;
  551.       call crlf;
  552.       i = i + 1;
  553.     end;
  554.   end;
  555.  
  556.   /* PROGRAM vs. SUBMIT SEARCH ORDER */
  557.   if show$order then do;
  558.     call crlf;
  559.     call print$buf(.('Search Order         - $'));
  560.     do case order;
  561.       call print$buf(.('COM$'));
  562.       call print$buf(.('COM, SUB$'));
  563.       call print$buf(.('SUB, COM$'));
  564.     end;
  565.   end;
  566.  
  567.   /* TEMPORARY FILE DRIVE */
  568.   if show$temp then do;
  569.     call crlf;
  570.     call print$buf(.('Temporary Drive      - $'));
  571.     if temp$drive > 16
  572.       then temp$drive = 0;
  573.     if temp$drive = 0 then
  574.       call print$buf(.('Default$'));
  575.     else do;
  576.       call printchar(temp$drive + 40h);
  577.       call printchar(':');
  578.     end;
  579.   end;
  580.  
  581.   /* CONSOLE PAGE MODE */
  582.   if show$page then do;
  583.     call crlf;
  584.     call print$buf(.('Console Page Mode    - $'));
  585.     if pg$mode = 0 then
  586.       call print$buf(.('On$'));
  587.     else
  588.       call print$buf(.('Off$'));
  589.   end;
  590.  
  591.   /* PROGRAM NAME & DRIVE DISPLAY */
  592.   if show$display then do;
  593.     call crlf;
  594.     call print$buf(.('Program Name Display - $'));
  595.     if display$flag = 0 then
  596.       call print$buf(.('Off$'));
  597.     else
  598.       call print$buf(.('On$'));
  599.   end;
  600. call crlf;
  601. end display$path;
  602.  
  603. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  604.  
  605. /* This routine processes the search drives string.  When called
  606.    this routine scans the command line expecting a drive name, a:-p:.
  607.    It puts the drive code in a drive table and continues the scan
  608.    collecting drives until more than 4 drives are specified (an error)
  609.    or an eoln or the delimiter '[' is encountered.  Next it modifies
  610.    the SCB searchchain bytes so that it reflects the drive order as
  611.    inputed.  No check is made to insure that the drive specified is
  612.    a known drive to the particular system being used.         */
  613.  
  614. process$drives: procedure;
  615.   declare (i,ct) byte;
  616.   show$drive = true;
  617.   index = 0;
  618.   delimiter = 0;
  619.   do i=0 to 3;    /* clear drive table */
  620.     drive$table(i) = 0ffh;
  621.   end;
  622.   ct = 0;
  623.   do while ((delimiter <> 1) and (delimiter <> 11));    /* not eoln */
  624.     call opt$scanner(.drives(0),.drives$offset(0),.index);
  625.     if ct > 3 then    /* too many drives */
  626.       call error(0);
  627.     if index = 0 then    /* invalid drive */
  628.       call error(2);
  629.     do i=0 to 3;
  630.       if drive$table(i) = (index-1) then
  631.         call error(6);    /* Drive already defined */
  632.     end;
  633.     drive$table(ct) = index-1;
  634.     ct = ct + 1;
  635.   end;
  636.   do i=0 to 3;    /* update scb drive table */
  637.     call setscbbyte(drive0$offset+i,drive$table(i));
  638.   end;
  639. end process$drives;
  640.  
  641. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  642.  
  643. /* This routine does all the processing for the options. Ie. any
  644.    string beginning with a '['.  The routine will handle basically
  645.    five options: Temporary, Order, Display, Page, No Display and
  646.    No Page.  Each routine is fairly short and can be found as a 
  647.    branch in the case statement.
  648.    */
  649.  
  650. process$options: procedure;
  651.   declare next$delim based buf$ptr byte;
  652.   declare (first$sub,paren,val) byte;
  653.   do while (delimiter <> 2) and (delimiter <> 11);
  654.     index = 0;
  655.     delimiter = 1;
  656.     call opt$scanner(.options(0),.options$offset(0),.index);
  657.     do case index;
  658.       
  659.       call error(4);        /* not in options list (INVALID) */
  660.  
  661.       do;    /* temporary drive option */
  662.         show$temp = true;
  663.         if delimiter <> 3 then  /* = */
  664.           call error(1);
  665.         call opt$scanner(.drives(0),.drives$offset(0),.index);
  666.         if index = 0 then
  667.           call error(2);
  668.         call setscbbyte(temp$drive$offset,index-1);
  669.       end;
  670.       
  671.       do;    /* order option */
  672.         show$order = true;
  673.         first$sub,paren = false;
  674.         if delimiter <> 3 then    /* = */
  675.           call error(1);
  676.         do while ((next$delim = ' ') or (next$delim = tab)); /* skip spaces */
  677.           buf$ptr = buf$ptr + 1;
  678.         end;
  679.         if next$delim = '(' then do;
  680.           paren = true;
  681.           buf$ptr = buf$ptr + 1;
  682.         end;
  683.         call opt$scanner(.options(0),.options$offset(0),.index);
  684.         if ((index <> 6) and (index <> 7)) then
  685.           call error(3);
  686.         if index = 7 then    /* note that the first entry was SUB */
  687.           first$sub = true;
  688.         order$table(0) = index - 6;
  689.         if (first$sub and ((delimiter = 10) or not paren)) then 
  690.           call error(7); /* (SUB) not allowed */
  691.         if (delimiter <> 10) and paren then do;
  692.           call opt$scanner(.options(0),.options$offset(0),.index);
  693.           if ((index <> 6) and (index <> 7)) then
  694.             call error(3);
  695.           order$table(1) = index - 6;
  696.           if (first$sub and (index = 7)) then    /* can't have SUB,SUB */
  697.             call error(7);
  698.         end;
  699.         ccp$flag2 = getscbbyte(ccp$flag2$offset);
  700.         if order$table(0) = 0 then
  701.           ccp$flag2 = ccp$flag2 and 111$0$1111b;
  702.         else
  703.           ccp$flag2 = ccp$flag2 or 000$1$0000b;
  704.         if order$table(1) = 0 then
  705.           ccp$flag2 = ccp$flag2 and 1111$0$111b;
  706.         else
  707.           ccp$flag2 = ccp$flag2 or 0000$1$000b;
  708.         call setscbbyte(ccp$flag2$offset,ccp$flag2);
  709.         if paren then do;
  710.           if delimiter <> 10 then
  711.             call error(1);
  712.           else
  713.             buf$ptr = buf$ptr + 1;
  714.         end;
  715.         else if delimiter = 10 then 
  716.             call error(1);
  717.         if next$delim = ']' or next$delim = 0 then    /* two delimiters */
  718.           delimiter = 11;    /* eoln, so exit loop */
  719.       end;
  720.  
  721.       /* PAGE Option */
  722.       do;
  723.         show$page = true;
  724.         val = 0;
  725.         if delimiter = 3 then do;  /* = */
  726.           call opt$scanner(.options(0),.options$offset(0),.index);
  727.       if index <> 10 then
  728.             if index = 11 then
  729.               val = 0ffh;
  730.             else
  731.               call error(8);
  732.         end;
  733.         call setscbbyte(pg$mode$offset,val);
  734.         call setscbbyte(pg$def$offset,val);
  735.       end;
  736.    
  737.       /* call error(4);    page option now an error */
  738.           
  739.       do;     /* DISPLAY option */
  740.         show$display,val = true;
  741.         if delimiter = 3 then do;  /* = */
  742.           call opt$scanner(.options(0),.options$offset(0),.index);
  743.       if index <> 10 then
  744.             if index = 11 then
  745.               val = false;
  746.             else
  747.               call error(8);
  748.         end;
  749.         ccp$flag2 = getscbbyte(ccp$flag2$offset);
  750.         if val then
  751.           ccp$flag2 = ccp$flag2 or 00000$0$11b;     /* set bits */
  752.         else
  753.           ccp$flag2 = ccp$flag2 and 11111$1$00b;     /* clear bits */ 
  754.       call setscbbyte(ccp$flag2$offset,ccp$flag2);
  755.       end;
  756.  
  757.       /* call error(4);    Display option now an error */
  758.       
  759.       do;     /* NO keyword */
  760.         call opt$scanner(.options(0),.options$offset(0),.index);
  761.         if (index <> 3) and (index <> 4) then 
  762.           call error(4);
  763.         if index = 3 then do;    /* NO PAGE option */
  764.           show$page = true;
  765.           call setscbbyte(pg$mode$offset,0FFh);
  766.           call setscbbyte(pg$def$offset,0FFh);
  767.         end;  
  768.         else do;             /* NO DISPLAY option */
  769.           show$display = true;
  770.           ccp$flag2 = getscbbyte(ccp$flag2$offset);
  771.           ccp$flag2 = ccp$flag2 and 11111$1$00b;     /* clear bits */ 
  772.           call setscbbyte(ccp$flag2$offset,ccp$flag2);
  773.         end;
  774.       end;
  775.  
  776.       /* call error(4);    NO keyword is now an error */
  777.      
  778.       call error(4);        /* COM is not an option */
  779.  
  780.       call error(4);        /* SUB is not an option */
  781.  
  782.       /* NOPAGE option */
  783.       do;
  784.         show$page = true;
  785.         call setscbbyte(pg$mode$offset,0FFh);
  786.         call setscbbyte(pg$def$offset,0FFh);
  787.       end;  
  788.  
  789.       /* NODISPLAY option */
  790.       do;
  791.         show$display = true;
  792.         ccp$flag2 = getscbbyte(ccp$flag2$offset);
  793.         ccp$flag2 = ccp$flag2 and 11111$1$00b;     /* clear bits */ 
  794.         call setscbbyte(ccp$flag2$offset,ccp$flag2);
  795.       end;
  796.  
  797.       call error(4);        /* ON is not an option */
  798.  
  799.       call error(4);        /* OFF is not an option */
  800.     end;
  801.   end;
  802. end process$options;
  803.  
  804. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  805.  
  806. input$found: procedure (buffer$adr) byte;
  807.   declare buffer$adr address;
  808.   declare char based buffer$adr byte;
  809.   do while (char = ' ') or (char = 9); /* tabs & spaces */
  810.     buffer$adr = buffer$adr + 1;
  811.   end;
  812.   if char = 0 then    /* eoln */
  813.     return false;    /* input not found */
  814.   else
  815.     return true;    /* input found */
  816. end input$found;
  817.  
  818. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  819.  
  820.  /**************************************
  821. *                                     *
  822. *       M A I N   P R O G R A M       *
  823. *                                     *
  824. **************************************/
  825.  
  826. plm:
  827.   do;
  828.     if (low(version) < cpmversion) or (high(version) = 1) then do;
  829.       call print$buf(.('Requires CP/M 3.0$'));
  830.       call mon1(0,0);
  831.     end;
  832.     if not input$found(.tbuff(1)) then do; 
  833.       /* SHOW DEFAULTS */
  834.       call display$path;
  835.       call mon1(0,0);             /* & terminate  */
  836.     end;
  837.  
  838.     /* SET DEFAULTS */
  839.     i = 1;            /* skip over leading spaces */
  840.     do while (tbuff(i) = ' ');
  841.       i = i + 1;
  842.     end;
  843.     show$drive,show$order,show$temp,show$page,show$display 
  844.       = false;
  845.     begin$buffer = .tbuff(1);   /* note beginning of input */
  846.     buf$length = tbuff(0);      /* note length of input */
  847.     buf$ptr = .tbuff(i);        /* set up for scanner */
  848.     if tbuff(i) = '[' then do;  /* options, no drives */
  849.       buf$ptr = buf$ptr + 1;    /* skip over '[' */
  850.       call process$options;
  851.     end;
  852.     else do;            /* drives first, maybe options too */
  853.       call process$drives;
  854.       if delimiter = 1 then    /* options, because we found an '[' */
  855.         call process$options;
  856.     end;
  857.     call display$path;        /* show results */
  858.     call mon1(0,0);             /* & terminate  */
  859.   end;
  860. end setdef;
  861.