home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / ZCPR33 / Z3-33 / Z3KEY14.LBR / Z3KEY.IQC / Z3KEY.INC
Text File  |  2000-06-30  |  4KB  |  151 lines
  1. {$V-}
  2.  
  3. type Str80=string[80];
  4.  
  5. procedure CtrlStr(var S:Str80);
  6.  
  7.   var I:integer;
  8.  
  9.   begin
  10.   I:=1;
  11.   repeat
  12.     case S[I] of
  13.       ^^ : begin
  14.            S[I]:='^';
  15.            I:=I+1;
  16.            end;
  17.       '^': begin
  18.            delete(S,I,1);
  19.            if upcase(S[I]) in ['@'..'_'] then S[I]:=chr(ord(upcase(S[I]))-ord('@'));
  20.            I:=I+1;
  21.            end;
  22.       else I:=I+1;
  23.     end;
  24.   until I>length(S);
  25.   end;
  26.  
  27. procedure KeyCompile;
  28.  
  29.   var InFile:text;
  30.       InFileName:string[20];
  31.       InStr:string[255];
  32.       Cmd,Key,Def:string[80];
  33.       Done,Quit:boolean;
  34.       Response:char;
  35.       I,J,TblPtr:integer;
  36.       Table:array[1..1000] of char;
  37.  
  38.  
  39.   begin
  40.   repeat
  41.     writeln;
  42.     write('Enter name of file to compile: ');
  43.     readln(InFileName);
  44.     assign(InFile,InFileName);
  45.     {$I-} reset(InFile); {$I+}
  46.     if ioresult <> 0  then
  47.       begin
  48.       write('File not found. Re-enter (Y/N)-> ');
  49.       repeat
  50.         read(kbd,Response);
  51.       until upcase(Response) in ['Y','N'];
  52.       if upcase(Response)='Y' then Quit:=false
  53.       else Quit:=true;
  54.       Done:=false;
  55.       end
  56.     else Done:=true;
  57.   until Done or Quit;
  58.   if Done then
  59.     begin
  60.     fillchar(Table,sizeof(Table),#0);
  61.     TblPtr:=1;
  62.     while not eof(InFile) do
  63.       begin
  64.       readln(InFile,InStr);
  65.       Done:=false;
  66.       while InStr[1]=' ' do delete(InStr,1,1);
  67.       Cmd:=copy(InStr,1,pos('=',InStr)-1);
  68.       Key:=Cmd;
  69.       Def:=copy(InStr,pos('=',InStr)+1,255);
  70.       while Cmd[length(Cmd)]=' ' do delete(Cmd,length(Cmd),1);
  71.       for I:=1 to length(Cmd) do Cmd[I]:=upcase(Cmd[I]);
  72.       while Def[1]=' ' do delete(Def,1,1);
  73.       while Def[length(Def)]=' ' do delete(Def,length(Def),1);
  74.       if pos('FILE',Cmd)<>0 then
  75.         begin
  76.         Done:=true;
  77.         for I:=1 to length(Def) do Def[I]:=upcase(Def[I]);
  78.         if length(Def)<=8 then
  79.           begin
  80.           for I:=1 to 8 do KeyHdr^.Name[I]:=' ';
  81.           for I:=1 to length(Def) do KeyHdr^.Name[I]:=Def[I];
  82.           writeln('File name set to ',Def);
  83.           end
  84.         else writeln('File name more than 8 characters');
  85.         end;
  86.       if  pos('ATTENTION',Cmd)<>0 then
  87.         begin
  88.         Done:=true;
  89.         CtrlStr(Def);
  90.         KeyHdr^.Attn:=Def[1];
  91.         end;
  92.       if pos('LEADIN',Cmd)<>0 then
  93.         begin
  94.         CtrlStr(Def);
  95.         KeyHdr^.Leadin:=Def[1];
  96.         KeyHdr^.LeadDef:=chr(ord(Def[1])+128);
  97.         Done:=true;
  98.         end;
  99.       if pos('DELAY',Cmd)<>0 then
  100.         begin
  101.         Done:=true;
  102.         val(Def,I,J);
  103.         if J=0 then KeyHdr^.Delay:=I
  104.         else writeln('Delay definition in error');
  105.         end;
  106.       if pos('EXPANSION',Cmd)<>0 then
  107.         begin
  108.         Done:=true;
  109.         val(Def,I,J);
  110.         if J=0 then KeyHdr^.ExpRate:=I
  111.         else writeln('Expansion Rate definition in error');
  112.         end;
  113.       if pos('CASE',Cmd)<>0 then
  114.         begin
  115.         Done:=true;
  116.         for I:=1 to length(Def) do Def[I]:=upcase(Def[I]);
  117.         if pos('ON',Def)<>0 then KeyHdr^.CaseFlag:=true;
  118.         if pos('OFF',Def)<>0 then KeyHdr^.CaseFlag:=false;
  119.         end;
  120.       if Cmd[1]=';' then Done:=true; {It's a comment}
  121.       if not Done then
  122.         begin
  123.         if pos('=',InStr)<>0 then
  124.           begin
  125.           Def:=copy(InStr,pos('=',InStr)+1,255);
  126.           if KeyHdr^.CaseFlag then
  127.             for I:=1 to length(Key) do Key[I]:=upcase(Key[I]);
  128.           CtrlStr(Def);CtrlStr(Key);
  129.           if (Key[1]=KeyHdr^.LeadIn) and (KeyHdr^.Delay=0) then
  130.             Key:=copy(Key,1,2); {if delay zero then only one char follows leadin}
  131.           for I:=1 to length(Key) do
  132.             begin
  133.             Table[TblPtr]:=Key[I];
  134.             TblPtr:=TblPtr+1;
  135.             end;
  136.           for I:=1 to length(Def) do
  137.             begin
  138.             Table[TblPtr]:=chr(ord(Def[I])+128);
  139.             TblPtr:=TblPtr+1;
  140.             end;
  141.           TblPtr:=TblPtr+1;
  142.           end;
  143.         end;
  144.       end;
  145.     KeyHdr^.Null1:=0;KeyHdr^.Null2:=0;
  146.     move(Table,KeyHdr^.Table,KeyHdr^.TableSize-1);
  147.     writeln('Done');
  148.     delay(1000);
  149.     end;
  150.   end;
  151.