Версия для печати темы
Нажмите сюда для просмотра этой темы в обычном формате
Форум «Всё о Паскале» _ Задачи _ Программа удаления комментариев
Автор: klem4 1.02.2006 21:30
Выслушаю вашу критику и соображения
Вот так сказать что на данный момент получается :
Исходный код
program Comments;
{$R-}
uses crt;
const
op : array [1..3] of string[2] = ('//','{','(*');
cl : array [1..3] of string[2] = ('','}','*)');
type
TType = string;
PArray = record
P : ^TArray;
size : word;
end;
TArray = array [1..1] of TType;
TFile = text;
function OpenFile(var f : TFile; path : TType) : boolean;
begin
assign(f, path);
{$I-}
reset(f);
{$I+}
OpenFile := (IOResult = 0);
end;
procedure SaveChanges(var f : text; arr : PArray);
var
i : word;
begin
rewrite(f);
for i := 1 to arr.size do writeln(f,arr.p^[i]);
close(f);
end;
procedure InitArray(var arr : PArray);
begin
arr.size := 0;
GetMem(arr.p, arr.size * sizeof(TType));
end;
procedure FillArray(var arr : PArray; var f : TFile);
var
temp : TType;
newArr : ^Tarray;
i : word;
begin
i := 0;
while not(eof(f)) do begin
readln(f, temp);
inc(i);
GetMem(newArr, arr.size * sizeof(TType) + sizeof(TType));
move(arr.p^[1], newArr^[1], arr.size * sizeof(TType));
FreeMem(arr.p, arr.size * sizeof(TType));
arr.p := newArr;
inc(arr.size);
arr.p^[i] := temp;
end;
end;
procedure ClearArray(var arr : PArray);
begin
FreeMem(arr.p, arr.size * sizeof(TType));
end;
procedure Check(var arr : PArray);
var
s : TType;
i,j,k : word;
begin
i := 1;
while (i <= arr.size) do begin
s := arr.p^[i];
for k := 1 to 3 do
if (pos(op[k],s) <> 0) then begin
j := 1;
while (j <= length(s)) do begin
if s[j] = '''' then repeat
inc(j);
if j = length(s) then begin
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
end;
until s[j] = '''';
if s[j] = '''' then inc(j);
if op[k] = copy(s,j,length(op[k])) then
if k = 1 then delete(s,j,255)
else
while (copy(s,j,length(cl[k])) <> cl[k]) do begin
if j = length(s) then begin
delete(s,j,1);
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
j := 1;
end;
delete(s,j,1);
end else inc(j);
if copy(s,j,length(cl[k])) = cl[k] then delete(s,j,length(cl[k]));
end;
end;
arr.p^[i] := s;
inc(i);
end;
end;
var
filePath : TType;
checkFile : TFile;
temp : PArray;
begin
clrscr;
filePath := 'c:\input.txt';
if OpenFile (checkFile, filePath) then begin
InitArray(temp);
FillArray(temp, checkFile);
Check(temp);
SaveChanges(checkFile, temp);
ClearArray(temp);
end
else writeln('Can"t open file : ' + filePath);
writeln('Done !');
readln;
end.
{$R-}
uses crt;
const
op : array [1..3] of string[2] = ('//','{','(*');
cl : array [1..3] of string[2] = ('','}','*)');
type
TType = string;
PArray = record
P : ^TArray;
size : word;
end;
TArray = array [1..1] of TType;
TFile = text;
function OpenFile(var f : TFile; path : TType) : boolean;
begin
assign(f, path);
{$I-}
reset(f);
{$I+}
OpenFile := (IOResult = 0);
end;
procedure SaveChanges(var f : text; arr : PArray);
var
i : word;
begin
rewrite(f);
for i := 1 to arr.size do writeln(f,arr.p^[i]);
close(f);
end;
procedure InitArray(var arr : PArray);
begin
arr.size := 0;
GetMem(arr.p, arr.size * sizeof(TType));
end;
procedure FillArray(var arr : PArray; var f : TFile);
var
temp : TType;
newArr : ^Tarray;
i : word;
begin
i := 0;
while not(eof(f)) do begin
readln(f, temp);
inc(i);
GetMem(newArr, arr.size * sizeof(TType) + sizeof(TType));
move(arr.p^[1], newArr^[1], arr.size * sizeof(TType));
FreeMem(arr.p, arr.size * sizeof(TType));
arr.p := newArr;
inc(arr.size);
arr.p^[i] := temp;
end;
end;
procedure ClearArray(var arr : PArray);
begin
FreeMem(arr.p, arr.size * sizeof(TType));
end;
procedure Check(var arr : PArray);
var
s : TType;
i,j,k : word;
begin
i := 1;
while (i <= arr.size) do begin
s := arr.p^[i];
for k := 1 to 3 do
if (pos(op[k],s) <> 0) then begin
j := 1;
while (j <= length(s)) do begin
if s[j] = '''' then repeat
inc(j);
if j = length(s) then begin
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
end;
until s[j] = '''';
if s[j] = '''' then inc(j);
if op[k] = copy(s,j,length(op[k])) then
if k = 1 then delete(s,j,255)
else
while (copy(s,j,length(cl[k])) <> cl[k]) do begin
if j = length(s) then begin
delete(s,j,1);
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
j := 1;
end;
delete(s,j,1);
end else inc(j);
if copy(s,j,length(cl[k])) = cl[k] then delete(s,j,length(cl[k]));
end;
end;
arr.p^[i] := s;
inc(i);
end;
end;
var
filePath : TType;
checkFile : TFile;
temp : PArray;
begin
clrscr;
filePath := 'c:\input.txt';
if OpenFile (checkFile, filePath) then begin
InitArray(temp);
FillArray(temp, checkFile);
Check(temp);
SaveChanges(checkFile, temp);
ClearArray(temp);
end
else writeln('Can"t open file : ' + filePath);
writeln('Done !');
readln;
end.
Цитата
in :
//comment1
{comment2} no comment2 // comment3
no comment3 {comment3}
{comment4} no comment4 {comment5}
{connent6} writeln('{no comment5}'); {comment7}
(*comment8*) no com{COMMENT}ment6
no comment7 (*comment9*)
(*comment10*) writeln('(*no comment8*)') (*comment11*)
type
TSet = set of char = ['{','}'];
out :
no comment2
no comment3
no comment4
writeln('{no comment5}');
no comment6
no comment7
writeln('(*no comment8*)')
type
TSet = set of char = ['{','}'];
Автор: Altair 2.02.2006 0:38
гы гы.... вход:
Цитата
writeln('
//nokom1
" "
//nokom2
');
выход
Цитата
writeln('
" "
');
" "
');
гы-гы
Автор: klem4 2.02.2006 0:43
Ах-ты .. молодец 
) Щас исправлю
Автор: volvo 2.02.2006 0:48
Олег, по-моему так и в Паскале не пройдет... Насколько я понял, нужно удалять комментарии из РАБОТАЮЩЕЙ Паскаль-программы? Я не прав?
Автор: klem4 2.02.2006 0:54
Хм действительно ... а я исправил уже, но это ладно, есть еще более плохая ситуация
writeln(' bababa '''' { no comment }');
тут программа выдает не вырный результат
Чувствую буду переделывать все
Автор: Altair 2.02.2006 0:55
Цитата
Олег, по-моему так и в Паскале не пройдет...
пардом ми....
ну все равно, вот такое компилер пропускает (повторение '' - вывод ' на экран)
Цитата
begin
writeln('//nokom1 '' //nokom2');
readln;
end .
writeln('//nokom1 '' //nokom2');
readln;
end .
а после выхода...
Цитата
begin
writeln('//nokom1 ''
readln;
end .
writeln('//nokom1 ''
readln;
end .
так, что, клем, гы
зы
блин сам нашел.... я в это время пост писал...
Автор: klem4 2.02.2006 1:02
Исходный код
program Comments;
{$R-}
uses crt;
const
op : array [1..3] of string[2] = ('//','{','(*');
cl : array [1..3] of string[2] = ('','}','*)');
type
TType = string;
PArray = record
P : ^TArray;
size : word;
end;
TArray = array [1..1] of TType;
TFile = text;
function OpenFile(var f : TFile; path : TType) : boolean;
begin
assign(f, path);
{$I-}
reset(f);
{$I+}
OpenFile := (IOResult = 0);
end;
procedure SaveChanges(var f : text; arr : PArray);
var
i : word;
begin
rewrite(f);
for i := 1 to arr.size do writeln(f,arr.p^[i]);
close(f);
end;
procedure InitArray(var arr : PArray);
begin
arr.size := 0;
GetMem(arr.p, arr.size * sizeof(TType));
end;
procedure FillArray(var arr : PArray; var f : TFile);
var
temp : TType;
newArr : ^Tarray;
i : word;
begin
i := 0;
while not(eof(f)) do begin
readln(f, temp);
inc(i);
GetMem(newArr, arr.size * sizeof(TType) + sizeof(TType));
move(arr.p^[1], newArr^[1], arr.size * sizeof(TType));
FreeMem(arr.p, arr.size * sizeof(TType));
arr.p := newArr;
inc(arr.size);
arr.p^[i] := temp;
end;
end;
procedure ClearArray(var arr : PArray);
begin
FreeMem(arr.p, arr.size * sizeof(TType));
end;
procedure Check(var arr : PArray);
var
s : TType;
i,j,k : word;
begin
i := 1;
while (i <= arr.size) do begin
s := arr.p^[i];
for k := 1 to 3 do
if (pos(op[k],s) <> 0) then begin
j := 1;
while (j <= length(s)) do begin
if s[j] = '''' then repeat
inc(j);
until (s[j] = '''') and (s[pred(j)] <> '''');
if s[j] = '''' then inc(j);
if op[k] = copy(s,j,length(op[k])) then
if k = 1 then delete(s,j,255)
else
while (copy(s,j,length(cl[k])) <> cl[k]) do begin
if j = length(s) then begin
delete(s,j,1);
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
j := 1;
end;
delete(s,j,1);
end else inc(j);
if copy(s,j,length(cl[k])) = cl[k] then delete(s,j,length(cl[k]));
end;
end;
arr.p^[i] := s;
inc(i);
end;
end;
var
filePath : TType;
checkFile : TFile;
temp : PArray;
begin
clrscr;
filePath := 'c:\input.txt';
if OpenFile (checkFile, filePath) then begin
InitArray(temp);
FillArray(temp, checkFile);
Check(temp);
SaveChanges(checkFile, temp);
ClearArray(temp);
end
else writeln('Can"t open file : ' + filePath);
writeln('Done !');
readln;
end.
{$R-}
uses crt;
const
op : array [1..3] of string[2] = ('//','{','(*');
cl : array [1..3] of string[2] = ('','}','*)');
type
TType = string;
PArray = record
P : ^TArray;
size : word;
end;
TArray = array [1..1] of TType;
TFile = text;
function OpenFile(var f : TFile; path : TType) : boolean;
begin
assign(f, path);
{$I-}
reset(f);
{$I+}
OpenFile := (IOResult = 0);
end;
procedure SaveChanges(var f : text; arr : PArray);
var
i : word;
begin
rewrite(f);
for i := 1 to arr.size do writeln(f,arr.p^[i]);
close(f);
end;
procedure InitArray(var arr : PArray);
begin
arr.size := 0;
GetMem(arr.p, arr.size * sizeof(TType));
end;
procedure FillArray(var arr : PArray; var f : TFile);
var
temp : TType;
newArr : ^Tarray;
i : word;
begin
i := 0;
while not(eof(f)) do begin
readln(f, temp);
inc(i);
GetMem(newArr, arr.size * sizeof(TType) + sizeof(TType));
move(arr.p^[1], newArr^[1], arr.size * sizeof(TType));
FreeMem(arr.p, arr.size * sizeof(TType));
arr.p := newArr;
inc(arr.size);
arr.p^[i] := temp;
end;
end;
procedure ClearArray(var arr : PArray);
begin
FreeMem(arr.p, arr.size * sizeof(TType));
end;
procedure Check(var arr : PArray);
var
s : TType;
i,j,k : word;
begin
i := 1;
while (i <= arr.size) do begin
s := arr.p^[i];
for k := 1 to 3 do
if (pos(op[k],s) <> 0) then begin
j := 1;
while (j <= length(s)) do begin
if s[j] = '''' then repeat
inc(j);
until (s[j] = '''') and (s[pred(j)] <> '''');
if s[j] = '''' then inc(j);
if op[k] = copy(s,j,length(op[k])) then
if k = 1 then delete(s,j,255)
else
while (copy(s,j,length(cl[k])) <> cl[k]) do begin
if j = length(s) then begin
delete(s,j,1);
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
j := 1;
end;
delete(s,j,1);
end else inc(j);
if copy(s,j,length(cl[k])) = cl[k] then delete(s,j,length(cl[k]));
end;
end;
arr.p^[i] := s;
inc(i);
end;
end;
var
filePath : TType;
checkFile : TFile;
temp : PArray;
begin
clrscr;
filePath := 'c:\input.txt';
if OpenFile (checkFile, filePath) then begin
InitArray(temp);
FillArray(temp, checkFile);
Check(temp);
SaveChanges(checkFile, temp);
ClearArray(temp);
end
else writeln('Can"t open file : ' + filePath);
writeln('Done !');
readln;
end.
Автор: volvo 2.02.2006 1:10
klem4, рано радуемся
Цитата
(*
begin
*)
begin
writeln(' test ');
end.
Просто вешает программу...
begin
*)
begin
writeln(' test ');
end.
Автор: klem4 2.02.2006 1:12
А вот так
1
(* begin
end*)
2
нормально ... гмм щас поправлю ... 
Автор: Altair 2.02.2006 1:14
Цитата
1
(* begin
end*)
2
(* begin
end*)
2
не.. не нормально... потому что я тоже
Цитата
Насколько я понял, нужно удалять комментарии из РАБОТАЮЩЕЙ Паскаль-программы
Автор: klem4 2.02.2006 1:29
Кажись пофиксил 
Исходный код
program Comments;
{$R-}
uses crt;
const
op : array [1..3] of string[2] = ('//','{','(*');
cl : array [1..3] of string[2] = ('','}','*)');
type
TType = string;
PArray = record
P : ^TArray;
size : word;
end;
TArray = array [1..1] of TType;
TFile = text;
function OpenFile(var f : TFile; path : TType) : boolean;
begin
assign(f, path);
{$I-}
reset(f);
{$I+}
OpenFile := (IOResult = 0);
end;
procedure SaveChanges(var f : text; arr : PArray);
var
i : word;
begin
rewrite(f);
for i := 1 to arr.size do writeln(f,arr.p^[i]);
close(f);
end;
procedure InitArray(var arr : PArray);
begin
arr.size := 0;
GetMem(arr.p, arr.size * sizeof(TType));
end;
procedure FillArray(var arr : PArray; var f : TFile);
var
temp : TType;
newArr : ^Tarray;
i : word;
begin
i := 0;
while not(eof(f)) do begin
readln(f, temp);
inc(i);
GetMem(newArr, arr.size * sizeof(TType) + sizeof(TType));
move(arr.p^[1], newArr^[1], arr.size * sizeof(TType));
FreeMem(arr.p, arr.size * sizeof(TType));
arr.p := newArr;
inc(arr.size);
arr.p^[i] := temp;
end;
end;
procedure ClearArray(var arr : PArray);
begin
FreeMem(arr.p, arr.size * sizeof(TType));
end;
procedure Check(var arr : PArray);
var
s : TType;
i,j,k : word;
begin
i := 1;
while (i <= arr.size) do begin
s := arr.p^[i];
for k := 1 to 3 do
if (pos(op[k],s) <> 0) then begin
j := 1;
while (j <= length(s)) do begin
if s[j] = '''' then repeat
inc(j);
until (s[j] = '''') and (s[pred(j)] <> '''');
if s[j] = '''' then inc(j);
if op[k] = copy(s,j,length(op[k])) then
if k = 1 then delete(s,j,255)
else
while (copy(s,j,length(cl[k])) <> cl[k]) do begin
if j = length(s) then begin
delete(s,j,1);
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
j := 1;
end
else delete(s,j,1);
end else inc(j);
if copy(s,j,length(cl[k])) = cl[k] then delete(s,j,length(cl[k]));
end;
end;
arr.p^[i] := s;
inc(i);
end;
end;
var
filePath : TType;
checkFile : TFile;
temp : PArray;
begin
clrscr;
filePath := 'c:\input.txt';
if OpenFile (checkFile, filePath) then begin
InitArray(temp);
FillArray(temp, checkFile);
Check(temp);
SaveChanges(checkFile, temp);
ClearArray(temp);
end
else writeln('Can"t open file : ' + filePath);
writeln('Done !');
readln;
end.
{$R-}
uses crt;
const
op : array [1..3] of string[2] = ('//','{','(*');
cl : array [1..3] of string[2] = ('','}','*)');
type
TType = string;
PArray = record
P : ^TArray;
size : word;
end;
TArray = array [1..1] of TType;
TFile = text;
function OpenFile(var f : TFile; path : TType) : boolean;
begin
assign(f, path);
{$I-}
reset(f);
{$I+}
OpenFile := (IOResult = 0);
end;
procedure SaveChanges(var f : text; arr : PArray);
var
i : word;
begin
rewrite(f);
for i := 1 to arr.size do writeln(f,arr.p^[i]);
close(f);
end;
procedure InitArray(var arr : PArray);
begin
arr.size := 0;
GetMem(arr.p, arr.size * sizeof(TType));
end;
procedure FillArray(var arr : PArray; var f : TFile);
var
temp : TType;
newArr : ^Tarray;
i : word;
begin
i := 0;
while not(eof(f)) do begin
readln(f, temp);
inc(i);
GetMem(newArr, arr.size * sizeof(TType) + sizeof(TType));
move(arr.p^[1], newArr^[1], arr.size * sizeof(TType));
FreeMem(arr.p, arr.size * sizeof(TType));
arr.p := newArr;
inc(arr.size);
arr.p^[i] := temp;
end;
end;
procedure ClearArray(var arr : PArray);
begin
FreeMem(arr.p, arr.size * sizeof(TType));
end;
procedure Check(var arr : PArray);
var
s : TType;
i,j,k : word;
begin
i := 1;
while (i <= arr.size) do begin
s := arr.p^[i];
for k := 1 to 3 do
if (pos(op[k],s) <> 0) then begin
j := 1;
while (j <= length(s)) do begin
if s[j] = '''' then repeat
inc(j);
until (s[j] = '''') and (s[pred(j)] <> '''');
if s[j] = '''' then inc(j);
if op[k] = copy(s,j,length(op[k])) then
if k = 1 then delete(s,j,255)
else
while (copy(s,j,length(cl[k])) <> cl[k]) do begin
if j = length(s) then begin
delete(s,j,1);
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
j := 1;
end
else delete(s,j,1);
end else inc(j);
if copy(s,j,length(cl[k])) = cl[k] then delete(s,j,length(cl[k]));
end;
end;
arr.p^[i] := s;
inc(i);
end;
end;
var
filePath : TType;
checkFile : TFile;
temp : PArray;
begin
clrscr;
filePath := 'c:\input.txt';
if OpenFile (checkFile, filePath) then begin
InitArray(temp);
FillArray(temp, checkFile);
Check(temp);
SaveChanges(checkFile, temp);
ClearArray(temp);
end
else writeln('Can"t open file : ' + filePath);
writeln('Done !');
readln;
end.
Автор: volvo 2.02.2006 1:39
klem4, не совсем
Смотри:
Цитата
{$I something.pas}
begin
// This is from something.pas
PrintIt;
end.
begin
// This is from something.pas
PrintIt;
end.
Вполне рабочая программа... А после прогона твоей утилитки?
Про директивы забыл?
Автор: klem4 2.02.2006 1:42
Да. И я еще баг нашел один, вобщем пока лавочку прикрою, как доделаю полностью, возобновим дебаты
Надо тестировщика нанять.
Автор: Altair 2.02.2006 1:43
klem, ты это... не стесняйся, приходи еще...
Ага, классный у вас форум, наверное на неделе загляну еще ... :D
p.s. 
Автор: klem4 2.02.2006 1:51
Закрываю временно тему, потому что если кто-то найдет за меня мои баги и напишет о них тут, я расстроюсь ;))
Автор: klem4 2.02.2006 17:59
Вот значит очередной ласт вершн
Исходный код
program Comments;
{$R-}
uses crt;
const
op : array [1..3] of string[2] = ('//','{','(*');
cl : array [1..3] of string[2] = ('','}','*)');
type
TType = string;
PArray = record
P : ^TArray;
size : word;
end;
TArray = array [1..1] of TType;
TFile = text;
function OpenFile(var f : TFile; path : TType) : boolean;
begin
assign(f, path);
{$I-}
reset(f);
{$I+}
OpenFile := (IOResult = 0);
end;
procedure SaveChanges(var f : text; arr : PArray);
var
i : word;
begin
rewrite(f);
for i := 1 to arr.size do writeln(f,arr.p^[i]);
close(f);
end;
procedure InitArray(var arr : PArray);
begin
arr.size := 0;
GetMem(arr.p, arr.size * sizeof(TType));
end;
procedure FillArray(var arr : PArray; var f : TFile);
var
temp : TType;
newArr : ^Tarray;
i : word;
begin
i := 0;
while not(eof(f)) do begin
readln(f, temp);
inc(i);
GetMem(newArr, arr.size * sizeof(TType) + sizeof(TType));
move(arr.p^[1], newArr^[1], arr.size * sizeof(TType));
FreeMem(arr.p, arr.size * sizeof(TType));
arr.p := newArr;
inc(arr.size);
arr.p^[i] := temp;
end;
end;
procedure ClearArray(var arr : PArray);
begin
FreeMem(arr.p, arr.size * sizeof(TType));
end;
procedure Check(var arr : PArray);
var
s : TType;
i,j,k : word;
begin
i := 1;
while (i <= arr.size) do begin
s := arr.p^[i];
for k := 1 to 3 do
if (pos(op[k],s) <> 0) then begin
j := 1;
while (j <= length(s)) do begin
if s[j] = '''' then repeat
inc(j);
until (s[j] = '''') and (s[pred(j)] <> '''') and (s[succ(j)] <> '''');
if s[j] = '''' then inc(j);
if op[k] = copy(s,j,length(op[k])) then
if (k = 2) and (s[succ(j)] = '$') then j := length(s) + 1
else
if k = 1 then delete(s,j,255)
else
while (copy(s,j,length(cl[k])) <> cl[k]) do begin
if (j = length(s)) or (s='') then begin
delete(s,j,1);
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
j := 1;
end
else delete(s,j,1);
end else inc(j);
if copy(s,j,length(cl[k])) = cl[k] then delete(s,j,length(cl[k]));
end;
end;
arr.p^[i] := s;
inc(i);
end;
end;
var
filePath : TType;
checkFile : TFile;
temp : PArray;
begin
clrscr;
filePath := 'c:\input.txt';
if OpenFile (checkFile, filePath) then begin
InitArray(temp);
FillArray(temp, checkFile);
Check(temp);
SaveChanges(checkFile, temp);
ClearArray(temp);
end
else writeln('Can"t open file : ' + filePath);
writeln('Done !');
readln;
end.
{$R-}
uses crt;
const
op : array [1..3] of string[2] = ('//','{','(*');
cl : array [1..3] of string[2] = ('','}','*)');
type
TType = string;
PArray = record
P : ^TArray;
size : word;
end;
TArray = array [1..1] of TType;
TFile = text;
function OpenFile(var f : TFile; path : TType) : boolean;
begin
assign(f, path);
{$I-}
reset(f);
{$I+}
OpenFile := (IOResult = 0);
end;
procedure SaveChanges(var f : text; arr : PArray);
var
i : word;
begin
rewrite(f);
for i := 1 to arr.size do writeln(f,arr.p^[i]);
close(f);
end;
procedure InitArray(var arr : PArray);
begin
arr.size := 0;
GetMem(arr.p, arr.size * sizeof(TType));
end;
procedure FillArray(var arr : PArray; var f : TFile);
var
temp : TType;
newArr : ^Tarray;
i : word;
begin
i := 0;
while not(eof(f)) do begin
readln(f, temp);
inc(i);
GetMem(newArr, arr.size * sizeof(TType) + sizeof(TType));
move(arr.p^[1], newArr^[1], arr.size * sizeof(TType));
FreeMem(arr.p, arr.size * sizeof(TType));
arr.p := newArr;
inc(arr.size);
arr.p^[i] := temp;
end;
end;
procedure ClearArray(var arr : PArray);
begin
FreeMem(arr.p, arr.size * sizeof(TType));
end;
procedure Check(var arr : PArray);
var
s : TType;
i,j,k : word;
begin
i := 1;
while (i <= arr.size) do begin
s := arr.p^[i];
for k := 1 to 3 do
if (pos(op[k],s) <> 0) then begin
j := 1;
while (j <= length(s)) do begin
if s[j] = '''' then repeat
inc(j);
until (s[j] = '''') and (s[pred(j)] <> '''') and (s[succ(j)] <> '''');
if s[j] = '''' then inc(j);
if op[k] = copy(s,j,length(op[k])) then
if (k = 2) and (s[succ(j)] = '$') then j := length(s) + 1
else
if k = 1 then delete(s,j,255)
else
while (copy(s,j,length(cl[k])) <> cl[k]) do begin
if (j = length(s)) or (s='') then begin
delete(s,j,1);
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
j := 1;
end
else delete(s,j,1);
end else inc(j);
if copy(s,j,length(cl[k])) = cl[k] then delete(s,j,length(cl[k]));
end;
end;
arr.p^[i] := s;
inc(i);
end;
end;
var
filePath : TType;
checkFile : TFile;
temp : PArray;
begin
clrscr;
filePath := 'c:\input.txt';
if OpenFile (checkFile, filePath) then begin
InitArray(temp);
FillArray(temp, checkFile);
Check(temp);
SaveChanges(checkFile, temp);
ClearArray(temp);
end
else writeln('Can"t open file : ' + filePath);
writeln('Done !');
readln;
end.
Цитата
Пройден тест файл :
{$I something.pas}
begin
// This is from something.pas
PrintIt;
end.
begin
writeln('//nokom1 '' //nokom2');
readln;
end .
//comment1
{comment2} no comment2 // comment3
no comment3 {comment3}
{comment4} no comment4 {comment5}
{connent6} writeln('{no comment5}'); {comment7}
(*comment8*) no com{COMMENT}ment6
no comment7 (*comment9*)
(*comment10*) writeln('(*no comment8*)') (*comment11*)
type
TSet = set of char = ['{','}'];
(*
begin
*)
begin
writeln(' test ');
end.
1
(* begin
end*)
2
4{ begin1
end1
}
5
6{
begin2
end2
}7
8
{
comme
en
t
}
9
Автор: volvo 2.02.2006 18:20
НЕ пройден файл:
Цитата
(*$define test*)
{$ifdef test}
begin
end
{$endif}
.
{$ifdef test}
begin
end
{$endif}
.
Автор: klem4 2.02.2006 18:23
Почему нет ?
Оставляет
Цитата
{$ifdef test}
begin
end
{$endif}
... первая строка - это ведь коммент ?!
Автор: volvo 2.02.2006 18:25
Кто тебе сказал? Попробуй откомпилировать эту программу без "коммента", как ты выразился, и с ним
Автор: klem4 2.02.2006 18:27
Ага, это опятьже к той теме, зачем сделали (* кроме {
:D
Добавил еще проверку ...
program Comments;
{$R-}
uses crt;
const
op : array [1..3] of string[2] = ('//','{','(*');
cl : array [1..3] of string[2] = ('','}','*)');
type
TType = string;
PArray = record
P : ^TArray;
size : word;
end;
TArray = array [1..1] of TType;
TFile = text;
function OpenFile(var f : TFile; path : TType) : boolean;
begin
assign(f, path);
{$I-}
reset(f);
{$I+}
OpenFile := (IOResult = 0);
end;
procedure SaveChanges(var f : text; arr : PArray);
var
i : word;
begin
rewrite(f);
for i := 1 to arr.size do writeln(f,arr.p^[i]);
close(f);
end;
procedure InitArray(var arr : PArray);
begin
arr.size := 0;
GetMem(arr.p, arr.size * sizeof(TType));
end;
procedure FillArray(var arr : PArray; var f : TFile);
var
temp : TType;
newArr : ^Tarray;
i : word;
begin
i := 0;
while not(eof(f)) do begin
readln(f, temp);
inc(i);
GetMem(newArr, arr.size * sizeof(TType) + sizeof(TType));
move(arr.p^[1], newArr^[1], arr.size * sizeof(TType));
FreeMem(arr.p, arr.size * sizeof(TType));
arr.p := newArr;
inc(arr.size);
arr.p^[i] := temp;
end;
end;
procedure ClearArray(var arr : PArray);
begin
FreeMem(arr.p, arr.size * sizeof(TType));
end;
procedure Check(var arr : PArray);
var
s : TType;
i,j,k : word;
begin
i := 1;
while (i <= arr.size) do begin
s := arr.p^[i];
for k := 1 to 3 do
if (pos(op[k],s) <> 0) then begin
j := 1;
while (j <= length(s)) do begin
if s[j] = '''' then repeat
inc(j);
until (s[j] = '''') and (s[pred(j)] <> '''') and (s[succ(j)] <> '''');
if s[j] = '''' then inc(j);
if op[k] = copy(s,j,length(op[k])) then
if ((k = 2) or (k = 3)) and (s[j + length(op[k])] = '$') then j := length(s) + 1
else
if k = 1 then delete(s,j,255)
else
while (copy(s,j,length(cl[k])) <> cl[k]) do begin
if (j = length(s)) or (s='') then begin
delete(s,j,1);
arr.p^[i] := s;
inc(i);
s := arr.p^[i];
j := 1;
end
else delete(s,j,1);
end else inc(j);
if copy(s,j,length(cl[k])) = cl[k] then delete(s,j,length(cl[k]));
end;
end;
arr.p^[i] := s;
inc(i);
end;
end;
var
filePath : TType;
checkFile : TFile;
temp : PArray;
begin
clrscr;
filePath := 'c:\input.txt';
if OpenFile (checkFile, filePath) then begin
InitArray(temp);
FillArray(temp, checkFile);
Check(temp);
SaveChanges(checkFile, temp);
ClearArray(temp);
end
else writeln('Can"t open file : ' + filePath);
writeln('Done !');
readln
end.