ЛенаВроде проверил - багов не нашел. Программа работает с вложенными комментариями. Проверь на реальной программе (но чтобы в той папке не было файла с тем же именем, что и в константе name_new - он будет перезаписан !!! )
Код
const
name = 'test.pas'; { имя исходного файла (с комментариями) }
name_new = 'test_res.pas'; { имя обработанного файла }
var
f, f_new: text;
s: string;
b: boolean;
p_st, p_fn: byte;
open_comment: boolean;
curr_pos: byte;
function pos_after(min: byte; substr, s: string): byte;
var p: byte;
begin
pos_after := 0;
p := pos(substr, copy(s, succ(min), length(s)-min + 1));
if p >= min then pos_after := p + min
end;
procedure check_comments(st_st, st_fn: string);
begin
repeat
if open_comment then
begin
p_fn := pos_after( curr_pos, st_fn, s );
if p_fn = 0 then
begin
readln(f, s);
continue
end
else
begin
delete(s, 1, p_fn+pred(length(st_fn)));
open_comment := false;
end;
end;
p_st := pos_after( curr_pos, st_st, s );
if p_st <> 0 then
begin
p_fn := pos_after( curr_pos, st_fn, s );
if p_fn = 0 then
begin
delete(s, p_st, length(s)-p_st+1);
open_comment := true;
writeln(f_new, s);
p_st := 0
end
else
begin
if s[p_st+length(st_st)] = '$' then
curr_pos := p_fn + length(st_st)
else
delete(s, p_st, p_fn-p_st+length(st_fn));
end;
end;
until p_st = 0;
end;
begin
assign(f, name);
{$I-}
reset(f);
{$I+}
if ioresult <> 0 then
begin
writeln('cannot open source file'); halt(100);
end;
assign(f_new, name_new);
{$I-}
rewrite(f_new);
{$I+}
if ioresult <> 0 then
begin
writeln('cannot create destination file'); halt(101);
end;
open_comment := false;
while not seekeof(f) do
begin
repeat
readln(f, s); curr_pos := 0;
check_comments('{', '}');
until open_comment = false;
repeat
check_comments('(*', '*)');
until open_comment = false;
if s <> '' then
writeln(f_new, s);
end;
close(f_new);
close(f);
end.
будут вопросы - ответим (баги - исправим).