$title('GENCPM Token File parser')
get$sys$defaults:
do;

/*
  Copyright (C) 1982
  Digital Research
  P.O. Box 579
  Pacific Grove, CA 93950
*/

/*
    Revised:
      20 Sept 82  by Bruce Skidmore
*/

  declare true literally '0FFH';
  declare false literally '0';
  declare forever literally 'while true';
  declare boolean literally 'byte';
  declare cr literally '0dh';
  declare lf literally '0ah';
  declare tab literally '09h';

/*
    D a t a    S t r u c t u r e s
*/

  declare data$fcb (36) byte external;

  declare quest (156) boolean external;

  declare display boolean external;

  declare symbol (8) byte;
  
  declare lnbfr (14) byte external;

  declare buffer (128) byte at (.memory);
 
  declare symtbl (20) structure(
    token(8) byte,
    len      byte,
    flags    byte,
    qptr     byte,
    ptr      address) external;

  mon1:
    procedure (func,info) external;
      declare func byte;
      declare info address;
    end mon1;

  mon2:
    procedure (func,info) byte external;
      declare func byte;
      declare info address;
    end mon2;

/*
     B D O S    P r o c e d u r e   &   F u n c t i o n    C a l l s
*/

  system$reset:
    procedure external;
    end system$reset;

  write$console:
    procedure (char) external;
      declare char byte;
    end write$console;

  print$console$buffer:
    procedure (buffer$address) external;
      declare buffer$address address;
    end print$console$buffer;

  open$file:
    procedure (fcb$address) byte external;
      declare fcb$address address;
      declare fcb based fcb$address (1) byte;
    end open$file;

  close$file:
    procedure (fcb$address) external;
      declare fcb$address address;
    end close$file;

  set$DMA$address:
    procedure (DMA$address) external;
      declare DMA$address address;
    end set$DMA$address;

  crlf:
    procedure external;
    end crlf;

  dsply$dec$adr:
    procedure (val) external;
      declare val address;
    end dsply$dec$adr;
    
/*
     M a i n   G E T D E F   P r o c e d u r e
*/
 getdef: 
  procedure public;

  declare buffer$index byte;
  declare index byte;
  declare end$of$file byte;
  declare line$count address;

  err:
    procedure(term$code,msg$adr);
      declare (term$code,save$display) byte;
      declare msg$adr address;

      save$display = display;
      display = true;
      call print$console$buffer(.('ERROR:  $'));
      call print$console$buffer(msg$adr);
      call print$console$buffer(.(' at line $'));
      call dsply$dec$adr(line$count);
      if term$code then
        call system$reset;
      call crlf;
      display = save$display;
    end err;

  inc$ptr:
    procedure;

      if buffer$index = 127 then
        do;
          buffer$index = 0;
          if mon2(20,.data$fcb) <> 0 then
            end$of$file = true;
        end;
      else
        buffer$index = buffer$index + 1;
    end inc$ptr;

  get$char:
    procedure byte;
     declare char byte;

     call inc$ptr;
     char = buffer(buffer$index);
     do while (char = ' ') or (char = tab) or (char = lf);
       if char = lf then
         line$count = line$count + 1;
       call inc$ptr;
       char = buffer(buffer$index);
     end;
     if (char >= 'a') and (char <= 'z') then
       char = char and 0101$1111b;  /* force upper case */
     if char = 1ah then
       end$of$file = true;
     return char;
   end get$char;

 get$sym:
   procedure;
     declare (i,sym$char) byte;
     declare got$sym boolean;

     got$sym = false;
     do while (not got$sym) and (not end$of$file);
       do i = 0 to 7;
         symbol(i) = ' ';
       end;
       sym$char = get$char;
       i = 0;
       do while (i < 8) and (sym$char <> '=') and 
                (sym$char <> cr) and (not end$of$file);
         symbol(i) = sym$char;
         sym$char = get$char;
         i = i + 1;
       end;
       do while (sym$char <> '=') and (sym$char <> cr) and (not end$of$file);
         sym$char = get$char;
       end;
       if not end$of$file then
         do;
           if (sym$char = '=') and (i > 0) then
             got$sym = true;
           else
             do;
               if (sym$char = '=') then
                 call err(false,.('Missing parameter variable$'));
               else
                 if i <> 0 then
                   call err(false,.('Equals (=) delimiter missing$'));
               do while (sym$char <> cr) and (not end$of$file);
                 sym$char = get$char;
               end;
             end;
         end;
     end;
   end get$sym;

 get$val:
   procedure;
     declare (flags,i,val$char) byte;
     declare val$adr address;
     declare val based val$adr byte;
     declare (base,inc,lnbfr$index) byte;

     val$char = get$char;
     i = 0;
     do while (i < lnbfr(0)) and (val$char <> cr) and (not end$of$file);
       lnbfr(i+2) = val$char;
       i = i + 1;
       lnbfr(1) = i;
       val$char = get$char;
     end;
     do while (val$char <> cr) and (not end$of$file);
       val$char = get$char;
     end;
     inc = 0;
     lnbfr$index = 2;
     if i > 0 then
       do;
         val$adr = symtbl(index).ptr;
         flags = symtbl(index).flags;
         if (flags and 8) <> 0 then
           do;
             if (flags and 10h) <> 0 then
               inc = symbol(7) - 'A';
             else
               if (symbol(7) >= '0') and (symbol(7) <= '9') then
                 inc = symbol(7) - '0';
               else
                 inc = 10 + (symbol(7) - 'A');
             val$adr = val$adr + (inc * symtbl(index).len);
           end;
         if lnbfr(lnbfr$index) = '?' then
           do;
             quest(inc+symtbl(index).qptr) = true;
             display = true;
             lnbfr$index = lnbfr$index + 1;
             lnbfr(1) = lnbfr(1) - 1;
           end;
         if lnbfr(1) > 0 then
           do;
             if (flags and 1) <> 0 then
               do;
                  if (lnbfr(lnbfr$index) >= 'A') and 
                     (lnbfr(lnbfr$index) <= 'P') then
                    val = lnbfr(lnbfr$index) - 'A';
                  else
                    call err(false,.('Invalid drive ignored$'));
               end;
             else
               if (flags and 2) <> 0 then
                 do;
                   val = (lnbfr(lnbfr$index) = 'Y');
                 end;
               else
                 do;
                   base = 16;
                   val = 0;
                   do i = 0 to lnbfr(1) - 1;
                     val$char = lnbfr(i+lnbfr$index);
                     if val$char = ',' then
                       do;
                         val$adr = val$adr + 1;
                         val = 0;
                         base = 16;
                       end;
                     else
                       do;
                         if val$char = '#' then
                           base = 10;
                         else
                           do;
                             val$char = val$char - '0';
                             if (base = 16) and (val$char > 9) then
                               do;
                                 if val$char > 16 then
                                   val$char = val$char - 7;
                                 else
                                   val$char = 0ffh;
                               end;
                             if val$char < base then
                               val = val * base + val$char;
                             else
                               call err(false,.('Invalid character$'));
                           end;
                       end;
                   end;
                 end;
           end;
      end;
    end get$val;

 compare$sym:
  procedure byte;
    declare (i,j) byte;
    declare found boolean;

    found = false;
    i = 0;
    do while ((i < 22) and (not found));
      j = 0;
      do while ((j < 7) and (symtbl(i).token(j) = symbol(j)));
        j = j + 1;
      end;
      if j = 7 then
        found = true;
      else
        i = i + 1;
    end;
    if not found then
      return 0ffh;
    else
      return i;
  end compare$sym;
    
    line$count = 1;
    call set$dma$address(.buffer);
    buffer$index = 127;
    end$of$file = false;
    do while (not end$of$file);
      call get$sym;
      if not end$of$file then
        do;
          index = compare$sym;
          if index <> 0ffh then
            call get$val;
          else
            call err(false,.('Invalid parameter variable$'));
        end;
    end;

  end getdef;
end get$sys$defaults;
