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 / SOPT.INC < prev    next >
Text File  |  1982-12-31  |  11KB  |  287 lines
  1. $eject
  2. check$choice: procedure(index,mindex) byte;
  3.                                         /* does this modifier go with this
  4.                                            option? */
  5.         declare
  6.                 index   byte,
  7.                 mindex  byte;
  8.  
  9.         return(opt$mod(index).modifier(mindex));
  10.  
  11. end check$choice;
  12.  
  13. /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  14.  
  15.  
  16.                     * * *  Option scanner  * * *
  17.  
  18.  
  19.  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
  20.  
  21.  
  22. separator: procedure(character) byte;
  23.  
  24.                                         /* determines if character is a 
  25.                                            delimiter and which one */
  26.         declare k       byte,
  27.                 character       byte;
  28.  
  29.         k = 1;
  30. loop:   if delimiters(k) = end$list then return(0);
  31.         if delimiters(k) = character then return(k);    /* null = 25 */
  32.                 k = k + 1;
  33.                 go to loop;
  34.  
  35. end separator;
  36.  
  37. opt$scanner:    procedure(list$ptr,off$ptr) byte;
  38.  
  39.              /* list$ptr        -       pointer to list of known strings
  40.                 off$ptr         -       pointer to offsets into known string
  41.                                         list
  42.                 buf$ptr         -       pointer to input string
  43.  
  44.                 Scans the known string list for an occurrance of the input
  45.                 string.  If the input string is not found in the known list
  46.                 then return(0). Otherwise, return the index of the known string
  47.                 that matches the input.
  48.  
  49.                 1. Find the known string that matches the input string on the 
  50.                    first letter.
  51.  
  52.                         do i = 1 to #known_strings
  53.                                 if Known_string(i,1) = input(1) then do
  54.  
  55.                                    if length(Known_string(i)) < end_of_input
  56.                                        then return(0)
  57.  
  58.                                    do j = 2 to end_of_input
  59.  
  60.                                         if Known_string(i,j) ~= input(j) then
  61.                                                 go to again
  62.                                    end
  63.  
  64.                                    go to 2
  65.                                 end
  66.                  again: end
  67.  
  68.                         return (0)              !no matchs
  69.  
  70.                 2. Test to see if the input string does not match another Known
  71.                    string.  This may happen if the input string is not a
  72.                    unique sub-string of the Known string, ie., DI is a 
  73.                    sub-string of DIRECTORY and DISK.
  74.  
  75.                         index = i
  76.  
  77.                         do i = index+1 to #known_strings
  78.                                 do j = 1 to end of input
  79.  
  80.                                         if Known_string(i,j) ~= input(j) then
  81.                                                 go to next
  82.                                 end
  83.  
  84.                                 return(0)       !not unique
  85.                 next:   end;
  86.  
  87.                         return(index)           !unique substring 
  88.  
  89.                                 P.Balma   10/82  */
  90.  
  91.         declare
  92.                 buff            based buf$ptr (1) byte,
  93.                 off$ptr         address,
  94.                 list$ptr        address;
  95.  
  96.         declare
  97.                 i               byte,
  98.                 j               byte,
  99.                 list            based list$ptr (1) byte,
  100.                 offsets         based off$ptr (1) byte,
  101.                 wrd$pos         byte,
  102.                 character       byte,
  103.                 letter$in$word  byte,
  104.                 found$first     byte,
  105.                 start           byte,
  106.                 index           byte,
  107.                 save$index      byte,
  108.                 (len$new,len$found)     byte,
  109.                 valid           byte;
  110.  
  111. /*****************************************************************************/
  112. /*                      internal subroutines                                 */
  113. /*****************************************************************************/
  114.  
  115. check$in$list: procedure;
  116.                                 /* find known string that has a match with 
  117.                                    input on the first character.  Set index
  118.                                    = invalid if none found.   */
  119.                         
  120.         declare i       byte;
  121.  
  122.         i = start;
  123.         wrd$pos = offsets(i);
  124.         do while list(wrd$pos) <> end$list;
  125.                 i = i + 1;
  126.                 index = i;
  127.                 if list(wrd$pos) = character then return;
  128.                 wrd$pos = offsets(i);
  129.         end;
  130.                         /* could not find character */
  131.         index = 0;
  132.         return;
  133. end check$in$list;
  134.  
  135. setup:  procedure;
  136.         character = buff(0);
  137.         call check$in$list;
  138.         letter$in$word = wrd$pos;
  139.                         /* even though no match may have occurred, position
  140.                            to next input character.  */
  141.         i = 1;
  142.         character = buff(1);
  143. end setup;
  144.  
  145. test$letter:    procedure;
  146.                         /* test each letter in input and known string */
  147.  
  148.         letter$in$word = letter$in$word + 1;
  149.  
  150.                                         /* too many chars input? 0 means
  151.                                            past end of known string */
  152.         if list(letter$in$word) = end$of$string then valid = false;
  153.         else
  154.         if list(letter$in$word) <> character then valid = false;
  155.  
  156.         i = i + 1;
  157.         character = buff(i);
  158.  
  159. end test$letter;
  160.  
  161. skip:   procedure;
  162.                                         /* scan past the offending string;
  163.                                            position buf$ptr to next string...
  164.                                            skip entire offending string;
  165.                                            ie., falseopt=mod, [note: comma or
  166.                                            space is considered to be group 
  167.                                            delimiter] */
  168.         character = buff(i);
  169.         delimiter = separator(character);
  170.         do while ((delimiter <> 2) and (delimiter <> 4) and (delimiter <> 5)
  171.                    and (delimiter <> 25));
  172.                 i = i + 1;
  173.                 character = buff(i);
  174.                 delimiter = separator(character);
  175.         end;
  176.         endbuf = i;
  177.         buf$ptr = buf$ptr + endbuf + 1;
  178.         return;
  179. end skip;
  180.  
  181. eat$blanks: procedure;
  182.  
  183.         declare charac  based buf$ptr byte;
  184.  
  185.         do while(delimiter := separator(charac)) = SPACE;
  186.                 buf$ptr = buf$ptr + 1;
  187.         end;
  188.  
  189. end eat$blanks;
  190.  
  191. /*****************************************************************************/
  192. /*                      end of internals                                     */
  193. /*****************************************************************************/
  194.  
  195.  
  196.                                         /* start of procedure */
  197.         call eat$blanks;
  198.         start = 0;
  199.         call setup;
  200.  
  201.                                         /* match each character with the option
  202.                                            for as many chars as input 
  203.                                            Please note that due to the array
  204.                                            indices being relative to 0 and the
  205.                                            use of index both as a validity flag
  206.                                            and as a index into the option/mods
  207.                                            list, index is forced to be +1 as an
  208.                                            index into array and 0 as a flag*/
  209.  
  210.         do while index <> 0;
  211.                 start = index;
  212.                 delimiter = separator(character);
  213.  
  214.                                         /* check up to input delimiter */
  215.  
  216.                 valid = true;           /* test$letter resets this */
  217.                 do while delimiter = 0;
  218.                         call test$letter;
  219.                         if not valid then go to exit1;
  220.                         delimiter = separator(character);
  221.                 end;
  222.  
  223.                 go to good;
  224.  
  225.                                         /* input ~= this known string;
  226.                                            get next known string that 
  227.                                            matches */
  228. exit1:          call setup;
  229.         end;
  230.                                         /* fell through from above, did
  231.                                            not find a good match*/
  232.         endbuf = i;                     /* skip over string & return*/
  233.         call skip;
  234.         return(0);
  235.  
  236.                                         /* is it a unique match in options
  237.                                            list? */
  238. good:   endbuf = i;
  239.         len$found = endbuf;
  240.         save$index = index;
  241.         valid = false;
  242. next$opt:
  243.                 start = index;
  244.                 call setup;
  245.                 if index = 0 then go to finished;
  246.  
  247.                                         /* look at other options and check
  248.                                            uniqueness */
  249.  
  250.                 len$new = offsets(index + 1) - offsets(index) - 1;
  251.                 if len$new = len$found then do;
  252.                         valid = true;
  253.                         do j = 1 to len$found;
  254.                                 call test$letter;
  255.                                 if not valid then go to next$opt;
  256.                         end;
  257.                 end;
  258.                 else go to nextopt;
  259.                                         /* fell through...found another valid
  260.                                            match --> ambiguous reference */
  261.         call skip;              /* skip input field to next delimiter*/
  262.         return(0);
  263.  
  264. finished:                       /* unambiguous reference */
  265.         buf$ptr = buf$ptr + endbuf;
  266.         call eat$blanks;
  267.         if delimiter <> 0 then buf$ptr = buf$ptr + 1;
  268.         else delimiter = SPACE;
  269.  
  270.         return(save$index);
  271.  
  272. end opt$scanner;
  273.  
  274. error$prt:      procedure;
  275.         declare i       byte,
  276.                 t       address,
  277.                 char    based t byte;
  278.  
  279.         t = buf$ptr - endbuf - 1;
  280.         do i = 1 to endbuf;
  281.                 call printchar(char);
  282.                 t = t + 1;
  283.         end;
  284.  
  285. end error$prt;
  286.  
  287.