убрать комментарии, работа с текстом Опции

[Лена]

Помогите, очень нужно.
В файле находится текст программы на языке Турбо Паскаль с комментариями. Создать выходной файл, в которых переписать содержимое исходного файла, убрав комментарии из текста программы.

Сообщение отредактировано: мисс_граффити - 13.06.2007 14:07

[volvo]

Лена

Вроде проверил - багов не нашел. Программа работает с вложенными комментариями. Проверь на реальной программе (но чтобы в той папке не было файла с тем же именем, что и в константе 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.

будут вопросы - ответим (баги - исправим).

Сообщение отредактировано: volvo - 20.10.2004 2:54

[zx1024]

Директивы компилятора учти.

[volvo]

zx1024

:o

Спасибо за напоминание. Забыл совершенно. Исправлено...