home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / DIALATE.ZIP / DIALATE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-02-07  |  7.6 KB  |  288 lines
  1. {@H
  2. $SYSPROG ON$
  3. $UCSD ON$
  4. $RANGE OFF$
  5. $DEBUG OFF$
  6. $PARTIAL_EVAL ON$
  7. $IOCHECK ON$  {@}
  8.  
  9. { *** See QCAD's "Guide to Pascal Porting" for explanation of the
  10.       [@] notation (really they are curly braces) }
  11.  
  12. program DIALATE(input, output);
  13.  
  14.   {Maps machine notations around.
  15.     Also maps 'ELSE' to 'OTHERWISE' or vice versa if requested}
  16.  
  17.   const
  18.     NO_MACHINE= 'N';
  19.     HOST_MACHINE= {@H   'H'  {@}
  20.                   {@T}  'T'  {@}
  21.                   {@V   'V'  {@}
  22.                   {@A   'A'  {@}  ;
  23.     SUFFIX= {@HA  '.TEXT' {@}
  24.             {@T} '.PAS'   {@}
  25.             {@V  '.TXT'   {@};
  26.  
  27.   type   STRING80 = string[80];
  28.          STRING20 = string[20];
  29.          LONGSTRING = string[255];
  30.          INT = -32767..32767;
  31.  
  32.   var    CH: char;
  33.          TO_FILE, FROM_FILE: text;
  34.          TO_HOST, MAP_ELSE, MAP_OTHERWISE, QUIT: boolean;
  35.          MACHINE: char;
  36.          MACH_CHARS: set of char;
  37.          MCHAR: char;  {the one we propose to open}
  38.          LINE: longstring;
  39.          OSTR, ESTR: string20;
  40.          LOSTR, LESTR: int;
  41.  
  42.   {**********************}
  43.   {@HAV
  44.   function UPCASE(CH: char): char;
  45.   begin
  46.     if ch in ['a'..'z'] then upcase:=chr(ord(ch)-32)
  47.     else upcase:=ch;
  48.     end;
  49.   {@}
  50.  
  51.   {*********************}
  52.   function RESP(STR: string80): char;
  53.     var CH: char;
  54.   begin
  55.     write(str);
  56.     {@HAV  read(input, ch);  {@}
  57.     {@T}  read(kbd, ch);  write(ch);  {@}
  58.     resp:=upcase(ch);
  59.     writeln;
  60.     end;
  61.  
  62.   {**********************}
  63.   function YESRESP(STR: string80): boolean;
  64.   begin
  65.     yesresp:=(resp(str) in ['y', 'Y']);
  66.     end;
  67.  
  68.   {***********************}
  69.   function FINDPOS(PAT, STR: longstring; SX: int): int;
  70.     label 99;
  71.     var PX, TSX: int;
  72.   begin
  73.     while sx<length(str)-length(pat) do begin
  74.       px:=1;
  75.       tsx:=sx;
  76.       while (px<=length(pat)) and
  77.             (pat[px]=str[tsx]) do begin
  78.         px:=px+1;
  79.         tsx:=tsx+1;
  80.         end;
  81.       if px>length(pat) then begin
  82.         findpos:=sx;
  83.         goto 99;
  84.         end;
  85.       sx:=sx+1;  {try the next position}
  86.       end;
  87.     findpos:=0;
  88.     99: end;
  89.  
  90.   {*********************}
  91.   procedure MAP(var STR: longstring);
  92.     var PS, FLEN: int;
  93.         CLOSEIT: boolean;
  94.         TSTR: longstring;
  95.   begin
  96.     str:=concat(str, ' ');  {add a guard field}
  97.     if machine<>no_machine then begin
  98.       ps:=pos('{@', str);
  99.       if ps>0 then begin
  100.         while ps>0 do begin
  101.           closeit:=false;
  102.           ps:=ps+2;
  103.           if (str[ps]='}') or (str[ps]=' ') then closeit:=true
  104.           else
  105.           repeat
  106.             if (str[ps] = mchar) then closeit:=true;
  107.             ps:=ps+1;
  108.             until (str[ps]='}') or (str[ps]=' ');
  109.           if closeit then str[ps]:='}' else str[ps]:=' ';
  110.           ps:=ps+1;
  111.           ps:=findpos('{@', str, ps);  {look for another one}
  112.           end
  113.         end
  114.       end;
  115.     if map_else then begin
  116.       ps:=pos(estr, str);
  117.       if ps>0 then begin
  118.         tstr:=concat(copy(str, 1, ps-1), ostr,
  119.                      copy(str, ps+lestr, length(str)-ps-lestr+1));
  120.         str:=tstr;
  121.         end
  122.       end;
  123.     if map_otherwise then begin
  124.       ps:=pos(ostr, str);
  125.       if ps>0 then begin
  126.         tstr:=concat(copy(str, 1, ps-1), estr,
  127.                      copy(str, ps+lostr, length(str)-ps-lostr+1));
  128.         str:=tstr;
  129.         end
  130.       end;
  131.     if str[length(str)]=' ' then str[0]:=pred(str[0]);
  132.     end;
  133.  
  134.   {*************************}
  135.   procedure MAPIT;
  136.   begin
  137.     while not(eof(from_file)) do begin
  138.       readln(from_file, line);
  139.       map(line);
  140.       writeln(to_file, line);
  141.       end
  142.     end;
  143.  
  144.   {@H   $IOCHECK OFF$  {@}
  145.   {$I-}
  146.   {*****************************}
  147.   function OPENFILES: boolean;
  148.     label 1, 2, 99;
  149.     var FNAME: string80;
  150.   begin
  151.     openfiles:=false;
  152.     2:
  153.     write('FROM file name? ');
  154.     readln(fname);
  155.     if length(fname)=0 then goto 99;
  156.     if not(fname[length(fname)] in [':', '.']) then
  157.       fname:=fname+suffix;
  158.     {@T}  assign(from_file, fname);  {@}
  159.     reset(from_file  {@HA  , fname {@} );
  160.     if ioresult<>0 then begin
  161.       writeln('Unable to open ', fname);
  162.       goto 2;
  163.       end;
  164.     1:
  165.     write('TO file name? ');
  166.     readln(fname);
  167.     if length(fname)=0 then goto 99;
  168.     if not(fname[length(fname)] in [':', '.']) then
  169.       fname:=fname+suffix;
  170.     {@T}  assign(to_file, fname);  {@}
  171.     rewrite(to_file  {@HA  , fname {@} );
  172.     if ioresult<>0 then begin
  173.       writeln('Unable to open ', fname);
  174.       goto 1;
  175.       end;
  176.     openfiles:=true;
  177.     99:
  178.     end;
  179.    
  180.   {************************}
  181.   procedure CLOSEFILES;
  182.   begin
  183.     close(from_file);
  184.     close(to_file  {@H  ,'LOCK' {@}
  185.                    {@A  , LOCK {@});
  186.     if ioresult<>0 then writeln('Unable to close TO_FILE');
  187.     end;
  188.   {@H   $IOCHECK ON$  {@}
  189.   {$I+}
  190.  
  191.   {*********************}
  192.   procedure CHECK(var M: char);
  193.   begin
  194.     m:=upcase(m);
  195.     if not(m in mach_chars) then begin
  196.       writeln('machine ', m, ' unrecognized');
  197.       m:= no_machine;
  198.       end
  199.     end;
  200.  
  201.   {**********************}
  202.   procedure SET_ELSE;
  203.   begin   {Turbo is the only machine that requires 'ELSE' in a
  204.                case statement.  All others require 'OTHERWISE'}
  205.     if machine=no_machine then begin
  206.       map_else:=false;
  207.       map_otherwise:=false;
  208.       end
  209.     else begin
  210.       map_otherwise:=(to_host and (host_machine='T')) or
  211.                       (not(to_host) and (machine='T'));
  212.            {otherwise --> else}
  213.       map_else:=not(map_otherwise);
  214.       end
  215.     end;
  216.  
  217.   {******************}
  218.   procedure OPTIONS;
  219.     var MORE: boolean;
  220.  
  221.     procedure SHOW_HELP;
  222.     begin
  223.       writeln;
  224.       writeln('DIALATE is used to translate Pascals on different machines,');
  225.       writeln('currently: Turbo/MS-DOS, VAX/VMS, Apple Macintosh, HP Pascal.');
  226.       writeln;
  227.       writeln('TO:       sets translation path     host => target machine');
  228.       writeln('FROM:     sets translation path     target machine => host');
  229.       writeln('MACHINE:  sets target machine to one listed above');
  230.       writeln('CONTINUE: finishes setup');
  231.       writeln;
  232.       writeln('After selecting CONTINUE, you will then be asked for the');
  233.       writeln('input and output file names.  Pressing <ENTER> for the input');
  234.       writeln('name will bring you back to the menu.');
  235.       writeln;
  236.     end;
  237.  
  238.   begin   { options }
  239.     more:=true;
  240.     writeln;
  241.     while (more and (not quit)) do
  242.     begin
  243.       if to_host then write(machine) else write('Host');
  244.       write(' --> ');
  245.       if to_host then writeln('host') else writeln(machine);
  246.       case upcase(resp(
  247.         'T(o/F(rom, M(achine, C(ontinue, H(elp, Q(uit ? ')) of
  248.       'C': more:=false;
  249.       'T': to_host:=true;
  250.       'F': to_host:=false;
  251.       'M': machine:=resp('T(urbo, V(ax, A(pple, H(P, N(none? ');
  252.       'H': show_help;
  253.       'Q': quit := true;
  254.       ELSE  ;
  255.       end;
  256.       check(machine);
  257.       set_else;
  258.       if not(more) and
  259.          not(machine in mach_chars) then more:=true;
  260.     end;
  261.     if to_host then mchar:=host_machine
  262.     else mchar:=machine;
  263.   end;
  264.  
  265.   procedure INIT_VARS;
  266.   begin
  267.     map_else:=false;
  268.     map_otherwise:=false;
  269.     to_host := true;
  270.     machine:= no_machine;
  271.     quit := false;
  272.   end;
  273.  
  274. begin
  275.   writeln('DIALATE Pascal program mapper: host machine ', host_machine);
  276.   mach_chars:=['T', 'V', 'A', 'H', no_machine];
  277.   estr:=concat(' ELSE', ' ');
  278.   lestr:=length(estr);
  279.   ostr:=concat(' OTHERWISE', ' ');
  280.   lostr:=length(ostr);
  281.   init_vars;
  282.   repeat
  283.     options;
  284.     if (not quit) then
  285.       while openfiles do begin mapit; closefiles; end;
  286.     until quit;
  287.   end.
  288.