{c2pas.pas -- quick'n'dirty c to pascal translator} program c2pas; {$R-} { Turn off range checking } {$I-} { Turn off I/O error checking } {,$U-} { Turn off auto link to runtime units } {,$T APPLdog*} { Set application ID } {,$U c2pas.lib}USES {, MemTypes, QuickDraw, OSIntf, ToolIntf, PackIntf, PasInOut, PasConsole, } {$U c2pstd } {. ibm} standard; const OUTSIZE = 32000; {output text buffer size} INSIZE = 32000; {input " } type wordtype = ( {1 symbol words} iquo, iasn, iat, iquest, icolon, imod, iptr, iscol, ixor, ibeg, iend, inot1, inot2, ior1, ipond, ilpar, irpar, igtr, ilth, iand1, {2 symbol words} iequ, icom1, icom2, ishr, ishl, iptag, iinc, idec, iproc, ior2, ineq, igte , ilte, iand2, {alpha words} iasm, iauto, ibrk, iitem, icdecl, ichar, icons, icont, iother, ido, idbl, ienum, iextn, ifar, ireal, ifor, igoto, ihuge, iif, iint, iintr, ilong, inear, ipasc, ireg, iret, ishrt, isign, isize, istat, irec, icase, itype, iunn, iuns, ivoid, ivol, iwhil, iwrite, idef, iread, inil, endword); wordstr = string[20];var cw, pw : array [wordtype] of wordstr; lastc : char; charcount: integer; endin : boolean; inp : ^tpFileRec; {^stdin} first : boolean; {.} procedure abort(msg: string80); begin write('ABORT: ',msg); readln; halt; end;procedure openFiles; var name: string80; abuf: pointer; outp: ^tpFileRec; k : integer; begin {, mac open write('Input file: '); readln(name); if name = '' then sfGet(false, name); reset( stdin, name, INSIZE); if ioresult <> 0 then abort('Can''t open source'); write('Output file: '); readln(name); if name = '' then sfGet(true, name); rewrite( stdout, name, OUTSIZE); if ioresult <> 0 then abort('Can''t create output'); } {. pc open } if (paramCount < 1) or not first then begin write('C source file: '); readln(name); if name='' then halt; end else name:= paramStr(1); first:= false; inp:= @stdin; assign( stdin, name); getMem(abuf, INSIZE); with inp^ do begin fBuffer:= abuf; fBufSize:= INSIZE; end; reset( stdin); if ioresult<>0 then begin assign(stdin, name+'.c'); with inp^ do begin fBuffer:= abuf; fBufSize:= INSIZE; end; reset(stdin); end; if ioresult <> 0 then abort('Can''t open source'); if paramcount = 1 then begin k:= pos('.',name); if k > 0 then delete(name, k, length(name)-k+1); end else name:= paramStr(2); if pos('.',name)=0 then name:= name + '.pas'; outp:= @stdout; assign( stdout, name); getMem(abuf, OUTSIZE); with outp^ do begin fBuffer:= abuf; fBufSize:= OUTSIZE; end; rewrite( stdout); if ioresult <> 0 then abort('Can''t create output'); inp:= @stdin; endin:= eof(stdin); end; {openFiles} procedure putc(c: char); begin write(stdout, c); end;procedure putword( s:string); begin write(stdout, s); end; function getc: char; begin endin:= eof(stdin); read(stdin, lastc); getc:= lastc; end;procedure ungetc(n:integer); begin {can't unget before start of buffer...} with inp^ do fBufPos:= max(0,fBufPos-n); endin:= eof(stdin); end;procedure skipc(n:integer); {skip n input chars} var k: longint; c:char; begin with inp^ do begin n:= n-1; {for 1 getc} k:= fBufPos; k:= k+n - fBufEnd; fBufPos:= min(fBufEnd,fBufPos+n); end; c:= getc; while (k > 0) and not endin do c:= getc; end;{skipc}procedure skipspace; begin while (getc <= ' ') and not endin do if lastc = #13 then putc(lastc) else if lastc = #10 then putc(lastc) {. ibm} else putc(' '); if not endin then ungetc(1); end;function isword(var s:string; trans: boolean): wordType; var w1,w2, w:wordType; s1 : string; lens: integer; begin isword:= endword; s1 := upperStr(s); if issymbol(s[1]) then if length(s)<2 then begin w1:= wordtype(0); w2:=iand1; end else begin w1:= succ(iand1); w2:= iand2; end else begin w1:= succ(iand2); w2:= endword; end; for w:= w1 to w2 do if (s1 = cw[w]) then begin if trans then s := pw[w]; isword:= w; exit; end; end; {isword}
procedure getword(var word: string); var i: integer; function done: boolean; begin done:= (getc <= ' ') or (endin) or (i > 254); end;begin skipspace; i:= 0; if not done then repeat i:= i+1; word[i]:= lastc; if issymbol(lastc) then begin if (i>1) and not issymbol(word[i-1]) then begin {halt word} i:= i-1; ungetc(1); end else if (i<2) then begin if issymbol(getc) then begin word[2]:= lastc; word[0]:= #2; if isword(word,false) = endword then ungetc(1) else i:= 2; end else ungetc(1); end; word[0]:= chr(i); exit; {always exit on 1/2 symbol word?!} end; until done; word[0]:= chr(i); if (lastc <= ' ') then ungetc(1); end; {getword} procedure translate; label gotword; var typename, lastname: string80; s, s1: string; w1,w: wordType; gottype, inwhile, infor, needthen: boolean; inpar: integer;begin needthen:= false; infor:= false; inwhile:= false; gottype:= false; inpar:= 0; while not endin do begin getword(s);gotword: w:= isword(s,true); case w of ipond: begin {compiler directives #define, #if...} getword(s); upcaseStr(s); if s = 'DEFINE' then begin putword('CONST '); getword(s); putword(s+' = '); getword(s); if issymbol(s[1]) then goto gotword; {can be "} putword(s+' ;'); end else if s = 'INCLUDE' then begin readln( stdin, s); {<< get whole line here} writeln( stdout, '{$I ',s,'}'); end else begin write(stdout, '{, ',s); readln(stdin, s); writeln(stdout, s,'}'); end; end; iquo : begin { "quotes" } putword(s); while (getc <> cw[iquo]) and not endin do putc(lastc); putword(pw[iquo]); end; icom1: begin { /* comments */ } putword(s); repeat getword(s); w:= isword(s,false); if w = icom2 then putword(pw[icom2]) else putword(s); until endin or (w = icom2); end; iptr: begin {*ptr -> ptr^ } {!! this is bad, "*" is also multiply} getword(s1); putword(s1+s); end; iinc, idec: { v++, v--, ++v, and --v } {! can't do this one reliably} if isalpha(lastname[1]) then putword(':= '+lastname+s) else begin {pre inc/dec} putword(s+':= '); end; iif : begin { IF () ...} putword(s); needthen:= true; inpar:= 0; end; ifor: begin { FOR (...;...;...) ... } putword(s); infor:= true; end; iwhil: begin { WHILE (...) } putword(s); inwhile:= true; end; ilpar:begin { ( } inpar:= inpar+1; if not (infor and (inpar=1)) then putword(s); end; irpar: begin { ) } inpar:= inpar-1; if (infor or inwhile) and (inpar<1) then begin if inwhile then putc(')'); putword(' DO '); infor:= false; inwhile:= false; end else putword(s); if needthen and (inpar<1) then begin putword(' THEN '); needthen:= false; end; end;
program c2pas;
{$R-} { Turn off range checking }
{$I-} { Turn off I/O error checking }
{,$U-} { Turn off auto link to runtime units }
{,$T APPLdog*} { Set application ID }
{,$U c2pas.lib}USES
{, MemTypes, QuickDraw, OSIntf, ToolIntf, PackIntf,
PasInOut, PasConsole, }
{$U c2pstd } {. ibm}
standard;
const
OUTSIZE = 32000; {output text buffer size}
INSIZE = 32000; {input " }
type
wordtype = (
{1 symbol words}
iquo, iasn, iat, iquest, icolon, imod, iptr,
iscol, ixor, ibeg, iend, inot1, inot2, ior1,
ipond, ilpar, irpar, igtr, ilth,
iand1,
{2 symbol words}
iequ, icom1, icom2,
ishr, ishl, iptag, iinc, idec,
iproc, ior2, ineq,
igte , ilte,
iand2, {alpha words}
iasm, iauto, ibrk, iitem, icdecl, ichar,
icons, icont, iother, ido, idbl, ienum,
iextn, ifar, ireal, ifor, igoto, ihuge,
iif, iint, iintr, ilong, inear, ipasc,
ireg, iret, ishrt, isign, isize, istat,
irec, icase, itype, iunn, iuns, ivoid,
ivol, iwhil, iwrite, idef,
iread, inil, endword); wordstr = string[20];var
cw, pw : array [wordtype] of wordstr;
lastc : char;
charcount: integer;
endin : boolean;
inp : ^tpFileRec; {^stdin}
first : boolean; {.}
procedure abort(msg: string80);
begin
write('ABORT: ',msg); readln;
halt;
end;procedure openFiles;
var name: string80;
abuf: pointer;
outp: ^tpFileRec;
k : integer;
begin
{, mac open
write('Input file: '); readln(name);
if name = '' then sfGet(false, name);
reset( stdin, name, INSIZE);
if ioresult <> 0 then abort('Can''t open source'); write('Output file: '); readln(name);
if name = '' then sfGet(true, name);
rewrite( stdout, name, OUTSIZE);
if ioresult <> 0 then abort('Can''t create output');
} {. pc open }
if (paramCount < 1) or not first then begin
write('C source file: '); readln(name);
if name='' then halt;
end
else name:= paramStr(1);
first:= false;
inp:= @stdin;
assign( stdin, name);
getMem(abuf, INSIZE);
with inp^ do begin fBuffer:= abuf; fBufSize:= INSIZE; end;
reset( stdin);
if ioresult<>0 then begin
assign(stdin, name+'.c');
with inp^ do begin fBuffer:= abuf; fBufSize:= INSIZE; end;
reset(stdin);
end;
if ioresult <> 0 then abort('Can''t open source'); if paramcount = 1 then begin
k:= pos('.',name);
if k > 0 then delete(name, k, length(name)-k+1);
end
else name:= paramStr(2);
if pos('.',name)=0 then name:= name + '.pas';
outp:= @stdout;
assign( stdout, name);
getMem(abuf, OUTSIZE);
with outp^ do begin fBuffer:= abuf; fBufSize:= OUTSIZE; end;
rewrite( stdout);
if ioresult <> 0 then abort('Can''t create output'); inp:= @stdin;
endin:= eof(stdin);
end; {openFiles}
procedure putc(c: char);
begin write(stdout, c);
end;procedure putword( s:string);
begin write(stdout, s);
end;
function getc: char;
begin
endin:= eof(stdin);
read(stdin, lastc); getc:= lastc;
end;procedure ungetc(n:integer);
begin {can't unget before start of buffer...}
with inp^ do fBufPos:= max(0,fBufPos-n);
endin:= eof(stdin);
end;procedure skipc(n:integer);
{skip n input chars}
var k: longint;
c:char;
begin
with inp^ do begin
n:= n-1; {for 1 getc}
k:= fBufPos;
k:= k+n - fBufEnd;
fBufPos:= min(fBufEnd,fBufPos+n);
end;
c:= getc;
while (k > 0) and not endin do c:= getc;
end;{skipc}procedure skipspace;
begin
while (getc <= ' ') and not endin do
if lastc = #13 then putc(lastc)
else if lastc = #10 then putc(lastc) {. ibm}
else putc(' ');
if not endin then ungetc(1);
end;function isword(var s:string; trans: boolean): wordType;
var
w1,w2, w:wordType;
s1 : string;
lens: integer;
begin
isword:= endword;
s1 := upperStr(s); if issymbol(s[1]) then
if length(s)<2 then begin
w1:= wordtype(0); w2:=iand1;
end
else begin
w1:= succ(iand1); w2:= iand2;
end
else begin
w1:= succ(iand2); w2:= endword;
end; for w:= w1 to w2 do
if (s1 = cw[w]) then begin
if trans then s := pw[w];
isword:= w;
exit;
end;
end; {isword}
procedure getword(var word: string);
var i: integer; function done: boolean;
begin done:= (getc <= ' ') or (endin) or (i > 254);
end;begin
skipspace;
i:= 0;
if not done then repeat i:= i+1; word[i]:= lastc; if issymbol(lastc) then begin
if (i>1) and not issymbol(word[i-1]) then begin {halt word}
i:= i-1; ungetc(1);
end
else if (i<2) then begin
if issymbol(getc) then begin
word[2]:= lastc;
word[0]:= #2;
if isword(word,false) = endword then ungetc(1)
else i:= 2;
end
else ungetc(1);
end;
word[0]:= chr(i);
exit; {always exit on 1/2 symbol word?!}
end; until done;
word[0]:= chr(i);
if (lastc <= ' ') then ungetc(1);
end; {getword}
procedure translate;
label gotword;
var
typename, lastname: string80;
s, s1: string;
w1,w: wordType;
gottype, inwhile, infor, needthen: boolean;
inpar: integer;begin
needthen:= false; infor:= false; inwhile:= false;
gottype:= false;
inpar:= 0;
while not endin do begin
getword(s);gotword:
w:= isword(s,true);
case w of ipond: begin {compiler directives #define, #if...}
getword(s); upcaseStr(s);
if s = 'DEFINE' then begin
putword('CONST ');
getword(s); putword(s+' = ');
getword(s);
if issymbol(s[1]) then goto gotword; {can be "}
putword(s+' ;');
end
else if s = 'INCLUDE' then begin
readln( stdin, s); {<< get whole line here}
writeln( stdout, '{$I ',s,'}');
end
else begin
write(stdout, '{, ',s);
readln(stdin, s);
writeln(stdout, s,'}');
end;
end; iquo : begin { "quotes" }
putword(s);
while (getc <> cw[iquo]) and not endin do
putc(lastc);
putword(pw[iquo]);
end; icom1: begin { /* comments */ }
putword(s);
repeat
getword(s);
w:= isword(s,false);
if w = icom2 then putword(pw[icom2])
else putword(s);
until endin or (w = icom2);
end; iptr: begin {*ptr -> ptr^ }
{!! this is bad, "*" is also multiply}
getword(s1); putword(s1+s);
end; iinc, idec: { v++, v--, ++v, and --v }
{! can't do this one reliably}
if isalpha(lastname[1]) then
putword(':= '+lastname+s)
else begin {pre inc/dec}
putword(s+':= ');
end; iif : begin { IF () ...}
putword(s);
needthen:= true; inpar:= 0;
end; ifor: begin { FOR (...;...;...) ... }
putword(s); infor:= true;
end;
iwhil: begin { WHILE (...) }
putword(s); inwhile:= true;
end; ilpar:begin { ( }
inpar:= inpar+1;
if not (infor and (inpar=1)) then putword(s);
end; irpar: begin { ) }
inpar:= inpar-1;
if (infor or inwhile) and (inpar<1) then begin
if inwhile then putc(')');
putword(' DO ');
infor:= false; inwhile:= false;
end
else
putword(s);
if needthen and (inpar<1) then begin
putword(' THEN '); needthen:= false;
end;
end;
ibeg, iscol: begin { "{" and ";" }
if gottype then begin
putword(typename); gottype:= false;
end;
putword(s);
end; iint, ilong, ichar, idbl, ireal :
begin { simple types }
typename:= ': '+s+' ';
gottype:= true;
end;
{------
cw[i]:= '?*='; pw[i]:= '? := ? * ';
cw[i]:= '?/='; pw[i]:= '? := ? / ';
cw[i]:= '?-='; pw[i]:= '? := ? - ';
cw[i]:= '?+='; pw[i]:= '? := ? + ';
----} else {,otherwise} begin
putword(s);
end;
end;{case} lastname:= s;
end;{while}
end; {translate}
procedure initials;
begin cw[iquo]:= '"'; pw[iquo]:='''';
cw[ilpar]:= '('; pw[ilpar]:= '(';
cw[irpar]:= ')'; pw[irpar]:= ')';
cw[ipond]:= '#'; pw[ipond]:= '{$'; {<< cmplr dir}
cw[iscol]:= ';'; pw[iscol]:= ';';
cw[iasn]:= '='; pw[iasn]:= ':=';
cw[iat]:= '&'; pw[iat]:='@';
cw[iquest]:= '?'; pw[iquest]:='THEN ';
cw[icolon]:= ':'; pw[icolon]:=':'; {<< needs fix for ?: form}
cw[imod]:= '%'; pw[imod]:= 'MOD ';
cw[ixor]:= '^'; pw[ixor]:= 'XOR ';
cw[ibeg]:= '{'; pw[ibeg]:='BEGIN ';
cw[iend]:= '}'; pw[iend]:='END; ';
cw[inot1]:= '!'; pw[inot1]:='NOT ';
cw[inot2]:= '~'; pw[inot2]:= 'NOT ';
cw[ior1]:= '|'; pw[ior1]:='OR ';
cw[iand1]:= '&'; pw[iand1]:='AND ';
cw[iptr]:= '*'; pw[iptr]:= '^'; {<< THIS IS BAD, "*" is valid for multiply in p}
cw[igtr]:= '>'; pw[igtr]:= '>';
cw[ilth]:= '<'; pw[ilth]:= '<'; cw[iequ]:= '=='; pw[iequ]:= '=';
cw[icom1]:= '/*'; pw[icom1]:='{';
cw[icom2]:= '*/'; pw[icom2]:='}';
cw[ishr]:= '>>'; pw[ishr]:='SHR ';
cw[ishl]:= '<<'; pw[ishl]:='SHL ';
cw[iptag]:= '->'; pw[iptag]:='^.';
cw[iinc]:= '++'; pw[iinc]:='+1';
cw[idec]:= '--'; pw[idec]:='-1';
cw[ior2]:= '||'; pw[ior2]:='OR ';
cw[iand2]:= '&&'; pw[iand2]:='AND ';
cw[ineq]:= '!='; pw[ineq]:='<>';
cw[iproc]:= '()'; pw[iproc]:='';
cw[igte]:= '>='; pw[igte]:= '>=';
cw[ilte]:= '<='; pw[ilte]:= '<=';
cw[iasm] := 'ASM'; pw[iasm]:= '{,ASM}';
cw[iauto]:= 'AUTO'; pw[iauto]:= '{,AUTO}';
cw[ibrk] := 'BREAK'; pw[ibrk]:= 'END{,brk}'; {<< usually in case statement}
cw[iitem]:= 'CASE'; pw[iitem]:=' ';
cw[icdecl]:= 'CDECL'; pw[icdecl]:= '{,CDECL}';
cw[ichar]:= 'CHAR'; pw[ichar]:= 'char';
cw[icons]:= 'CONST'; pw[icons]:= '{,CONST}';
cw[icont]:= 'CONTINUE'; pw[icont]:= '{,CONTINUE}';
cw[iother]:= 'DEFAULT'; pw[iother]:= 'OTHERWISE';
cw[ido] := 'DO'; pw[ido]:= 'DO';
cw[idbl] := 'DOUBLE'; pw[idbl]:= 'DOUBLE';
cw[ienum]:= 'ENUM'; pw[ienum]:= '';
cw[iextn]:= 'EXTERN'; pw[iextn]:= 'EXTERN';
cw[ifar] := 'FAR'; pw[ifar]:= '{,FAR}';
cw[ireal]:= 'FLOAT'; pw[ireal]:= 'REAL';
cw[ifor] := 'FOR'; pw[ifor]:= 'FOR';
cw[igoto]:= 'GOTO'; pw[igoto]:= 'GOTO{,}';
cw[ihuge]:= 'HUGE'; pw[ihuge]:= '{,HUGE}';
cw[iif] := 'IF'; pw[iif]:= 'IF';
cw[iint] := 'INT'; pw[iint]:= 'integer';
cw[iintr]:= 'INTERRUPT'; pw[iintr]:= '{,INTERRUPT}';
cw[ilong]:= 'LONG'; pw[ilong]:= 'longint';
cw[inear]:= 'NEAR'; pw[inear]:= '{,NEAR}';
cw[ipasc]:= 'PASCAL'; pw[ipasc]:= '';
cw[ireg] := 'REGISTER'; pw[ireg]:= '{,REGISTER}';
cw[iret] := 'RETURN'; pw[iret]:= '{,return}:= ';
cw[ishrt]:= 'SHORT'; pw[ishrt]:= '{,short}';
cw[isign]:= 'SIGNED'; pw[isign]:= '{,SIGNED}';
cw[isize]:= 'SIZEOF'; pw[isize]:= 'sizeof';
cw[istat]:= 'STATIC'; pw[istat]:= '{,STATIC}';
cw[irec] := 'STRUCT'; pw[irec]:= 'RECORD';
cw[icase]:= 'SWITCH'; pw[icase]:= 'CASE';
cw[itype]:= 'TYPEDEF'; pw[itype]:= 'TYPE';
cw[iunn] := 'UNION'; pw[iunn]:= 'CASE {,} OF';
cw[iuns] := 'UNSIGNED'; pw[iuns]:= '{,UNSIGNED}';
cw[ivoid]:= 'VOID'; pw[ivoid]:= '';
cw[ivol] := 'VOLATILE'; pw[ivol]:= '{,VOLATILE}';
cw[iwhil]:= 'WHILE'; pw[iwhil]:= 'WHILE';
cw[iwrite]:= 'PRINTF'; pw[iwrite]:='write';
cw[iread]:= 'SCANF'; pw[iread]:= 'read';
cw[inil]:= 'NULL'; pw[inil]:= 'NIL'; cw[endword]:= '(#@^#'; pw[endword]:= '(#@^#';
end; {inits}
begin
writeln;
writeln('C2Pas -- quick''n''dirty language translator');
writeln(' by d.g.gilbert, Dec87');
writeln(' dogstar software');
writeln(' po box 302, bloomington, in 47402');
writeln;
initials;
first:= true;
repeat
openFiles;
translate;
close(stdout);
close(stdin);
until false;
end.
不知道管不管用!
进来的送分，今天下班时结贴。
哦，忘了，反正是老外写的，我这技巧大家共享吧。
转换完成后，因为上面的文本框可以复制粘贴的，而且下面的文本框可以选中后移动选中内容。还可以移到上面的框中。你将下面的全部选中，再将其移到上面的框中，之前将上面的框清掉，这下不久可以了吗。^_^！