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 / GETDEF.PLM < prev    next >
Text File  |  1982-12-31  |  9KB  |  339 lines
  1. $title('GENCPM Token File parser')
  2. get$sys$defaults:
  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.     Revised:
  14.       20 Sept 82  by Bruce Skidmore
  15. */
  16.  
  17.   declare true literally '0FFH';
  18.   declare false literally '0';
  19.   declare forever literally 'while true';
  20.   declare boolean literally 'byte';
  21.   declare cr literally '0dh';
  22.   declare lf literally '0ah';
  23.   declare tab literally '09h';
  24.  
  25. /*
  26.     D a t a    S t r u c t u r e s
  27. */
  28.  
  29.   declare data$fcb (36) byte external;
  30.  
  31.   declare quest (156) boolean external;
  32.  
  33.   declare display boolean external;
  34.  
  35.   declare symbol (8) byte;
  36.   
  37.   declare lnbfr (14) byte external;
  38.  
  39.   declare buffer (128) byte at (.memory);
  40.  
  41.   declare symtbl (20) structure(
  42.     token(8) byte,
  43.     len      byte,
  44.     flags    byte,
  45.     qptr     byte,
  46.     ptr      address) external;
  47.  
  48.   mon1:
  49.     procedure (func,info) external;
  50.       declare func byte;
  51.       declare info address;
  52.     end mon1;
  53.  
  54.   mon2:
  55.     procedure (func,info) byte external;
  56.       declare func byte;
  57.       declare info address;
  58.     end mon2;
  59.  
  60. /*
  61.      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
  62. */
  63.  
  64.   system$reset:
  65.     procedure external;
  66.     end system$reset;
  67.  
  68.   write$console:
  69.     procedure (char) external;
  70.       declare char byte;
  71.     end write$console;
  72.  
  73.   print$console$buffer:
  74.     procedure (buffer$address) external;
  75.       declare buffer$address address;
  76.     end print$console$buffer;
  77.  
  78.   open$file:
  79.     procedure (fcb$address) byte external;
  80.       declare fcb$address address;
  81.       declare fcb based fcb$address (1) byte;
  82.     end open$file;
  83.  
  84.   close$file:
  85.     procedure (fcb$address) external;
  86.       declare fcb$address address;
  87.     end close$file;
  88.  
  89.   set$DMA$address:
  90.     procedure (DMA$address) external;
  91.       declare DMA$address address;
  92.     end set$DMA$address;
  93.  
  94.   crlf:
  95.     procedure external;
  96.     end crlf;
  97.  
  98.   dsply$dec$adr:
  99.     procedure (val) external;
  100.       declare val address;
  101.     end dsply$dec$adr;
  102.     
  103. /*
  104.      M a i n   G E T D E F   P r o c e d u r e
  105. */
  106.  getdef: 
  107.   procedure public;
  108.  
  109.   declare buffer$index byte;
  110.   declare index byte;
  111.   declare end$of$file byte;
  112.   declare line$count address;
  113.  
  114.   err:
  115.     procedure(term$code,msg$adr);
  116.       declare (term$code,save$display) byte;
  117.       declare msg$adr address;
  118.  
  119.       save$display = display;
  120.       display = true;
  121.       call print$console$buffer(.('ERROR:  $'));
  122.       call print$console$buffer(msg$adr);
  123.       call print$console$buffer(.(' at line $'));
  124.       call dsply$dec$adr(line$count);
  125.       if term$code then
  126.         call system$reset;
  127.       call crlf;
  128.       display = save$display;
  129.     end err;
  130.  
  131.   inc$ptr:
  132.     procedure;
  133.  
  134.       if buffer$index = 127 then
  135.         do;
  136.           buffer$index = 0;
  137.           if mon2(20,.data$fcb) <> 0 then
  138.             end$of$file = true;
  139.         end;
  140.       else
  141.         buffer$index = buffer$index + 1;
  142.     end inc$ptr;
  143.  
  144.   get$char:
  145.     procedure byte;
  146.      declare char byte;
  147.  
  148.      call inc$ptr;
  149.      char = buffer(buffer$index);
  150.      do while (char = ' ') or (char = tab) or (char = lf);
  151.        if char = lf then
  152.          line$count = line$count + 1;
  153.        call inc$ptr;
  154.        char = buffer(buffer$index);
  155.      end;
  156.      if (char >= 'a') and (char <= 'z') then
  157.        char = char and 0101$1111b;  /* force upper case */
  158.      if char = 1ah then
  159.        end$of$file = true;
  160.      return char;
  161.    end get$char;
  162.  
  163.  get$sym:
  164.    procedure;
  165.      declare (i,sym$char) byte;
  166.      declare got$sym boolean;
  167.  
  168.      got$sym = false;
  169.      do while (not got$sym) and (not end$of$file);
  170.        do i = 0 to 7;
  171.          symbol(i) = ' ';
  172.        end;
  173.        sym$char = get$char;
  174.        i = 0;
  175.        do while (i < 8) and (sym$char <> '=') and 
  176.                 (sym$char <> cr) and (not end$of$file);
  177.          symbol(i) = sym$char;
  178.          sym$char = get$char;
  179.          i = i + 1;
  180.        end;
  181.        do while (sym$char <> '=') and (sym$char <> cr) and (not end$of$file);
  182.          sym$char = get$char;
  183.        end;
  184.        if not end$of$file then
  185.          do;
  186.            if (sym$char = '=') and (i > 0) then
  187.              got$sym = true;
  188.            else
  189.              do;
  190.                if (sym$char = '=') then
  191.                  call err(false,.('Missing parameter variable$'));
  192.                else
  193.                  if i <> 0 then
  194.                    call err(false,.('Equals (=) delimiter missing$'));
  195.                do while (sym$char <> cr) and (not end$of$file);
  196.                  sym$char = get$char;
  197.                end;
  198.              end;
  199.          end;
  200.      end;
  201.    end get$sym;
  202.  
  203.  get$val:
  204.    procedure;
  205.      declare (flags,i,val$char) byte;
  206.      declare val$adr address;
  207.      declare val based val$adr byte;
  208.      declare (base,inc,lnbfr$index) byte;
  209.  
  210.      val$char = get$char;
  211.      i = 0;
  212.      do while (i < lnbfr(0)) and (val$char <> cr) and (not end$of$file);
  213.        lnbfr(i+2) = val$char;
  214.        i = i + 1;
  215.        lnbfr(1) = i;
  216.        val$char = get$char;
  217.      end;
  218.      do while (val$char <> cr) and (not end$of$file);
  219.        val$char = get$char;
  220.      end;
  221.      inc = 0;
  222.      lnbfr$index = 2;
  223.      if i > 0 then
  224.        do;
  225.          val$adr = symtbl(index).ptr;
  226.          flags = symtbl(index).flags;
  227.          if (flags and 8) <> 0 then
  228.            do;
  229.              if (flags and 10h) <> 0 then
  230.                inc = symbol(7) - 'A';
  231.              else
  232.                if (symbol(7) >= '0') and (symbol(7) <= '9') then
  233.                  inc = symbol(7) - '0';
  234.                else
  235.                  inc = 10 + (symbol(7) - 'A');
  236.              val$adr = val$adr + (inc * symtbl(index).len);
  237.            end;
  238.          if lnbfr(lnbfr$index) = '?' then
  239.            do;
  240.              quest(inc+symtbl(index).qptr) = true;
  241.              display = true;
  242.              lnbfr$index = lnbfr$index + 1;
  243.              lnbfr(1) = lnbfr(1) - 1;
  244.            end;
  245.          if lnbfr(1) > 0 then
  246.            do;
  247.              if (flags and 1) <> 0 then
  248.                do;
  249.                   if (lnbfr(lnbfr$index) >= 'A') and 
  250.                      (lnbfr(lnbfr$index) <= 'P') then
  251.                     val = lnbfr(lnbfr$index) - 'A';
  252.                   else
  253.                     call err(false,.('Invalid drive ignored$'));
  254.                end;
  255.              else
  256.                if (flags and 2) <> 0 then
  257.                  do;
  258.                    val = (lnbfr(lnbfr$index) = 'Y');
  259.                  end;
  260.                else
  261.                  do;
  262.                    base = 16;
  263.                    val = 0;
  264.                    do i = 0 to lnbfr(1) - 1;
  265.                      val$char = lnbfr(i+lnbfr$index);
  266.                      if val$char = ',' then
  267.                        do;
  268.                          val$adr = val$adr + 1;
  269.                          val = 0;
  270.                          base = 16;
  271.                        end;
  272.                      else
  273.                        do;
  274.                          if val$char = '#' then
  275.                            base = 10;
  276.                          else
  277.                            do;
  278.                              val$char = val$char - '0';
  279.                              if (base = 16) and (val$char > 9) then
  280.                                do;
  281.                                  if val$char > 16 then
  282.                                    val$char = val$char - 7;
  283.                                  else
  284.                                    val$char = 0ffh;
  285.                                end;
  286.                              if val$char < base then
  287.                                val = val * base + val$char;
  288.                              else
  289.                                call err(false,.('Invalid character$'));
  290.                            end;
  291.                        end;
  292.                    end;
  293.                  end;
  294.            end;
  295.       end;
  296.     end get$val;
  297.  
  298.  compare$sym:
  299.   procedure byte;
  300.     declare (i,j) byte;
  301.     declare found boolean;
  302.  
  303.     found = false;
  304.     i = 0;
  305.     do while ((i < 22) and (not found));
  306.       j = 0;
  307.       do while ((j < 7) and (symtbl(i).token(j) = symbol(j)));
  308.         j = j + 1;
  309.       end;
  310.       if j = 7 then
  311.         found = true;
  312.       else
  313.         i = i + 1;
  314.     end;
  315.     if not found then
  316.       return 0ffh;
  317.     else
  318.       return i;
  319.   end compare$sym;
  320.     
  321.     line$count = 1;
  322.     call set$dma$address(.buffer);
  323.     buffer$index = 127;
  324.     end$of$file = false;
  325.     do while (not end$of$file);
  326.       call get$sym;
  327.       if not end$of$file then
  328.         do;
  329.           index = compare$sym;
  330.           if index <> 0ffh then
  331.             call get$val;
  332.           else
  333.             call err(false,.('Invalid parameter variable$'));
  334.         end;
  335.     end;
  336.  
  337.   end getdef;
  338. end get$sys$defaults;
  339.