строки на слова Опции

[arhimag]

program WordsToArray;
uses crt;
type TArray=array[1..128]of string;

var s:string;
mas:TArray;i:integer;

procedure GetWords(s:string; var mas:TArray);
var i,j:shortint;
begin
while pos('  ',s)<>0 do delete(s,pos('  ',s),1);
if s[1]=' ' then delete(s,1,1);
if s[length(s)]=' ' then delete(s,length(s),1);
i:=1;
for j:=1 to length(s) do
if s[j]<>' ' then mas[i]:=mas[i]+s[j] else if i<>high(mas) then inc(i);
end;

procedure EnterElement(s:string; i:integer; arr:TArray);
var j: integer;
begin
for j:= 255 downto i do Arr[j+1]:=Arr[j];
Arr[i]:=s;
end;

procedure Filter(arr:TArray);
var i:integer;
    s: string;
begin
for I:= 1 to 128 do
    case Arr[i,length(Arr[i])] of
    ',': begin s:=','; delete(Arr[i],length(Arr[i]),1); if length(arr[i])<>1 then enterelement(s,i+1,mas) end;
    '.': begin s:='.'; delete(Arr[i],length(Arr[i]),1); if length(arr[i])<>1 then enterelement(s,i+1,mas)end;
    '"': begin s:='"'; delete(Arr[i],length(Arr[i]),1); if length(arr[i])<>1 then enterelement(s,i+1,mas)end;
    '!': begin s:='!'; delete(Arr[i],length(Arr[i]),1); if length(arr[i])<>1 then enterelement(s,i+1,mas)end;
    '(': begin s:='('; delete(Arr[i],length(Arr[i]),1); if length(arr[i])<>1 then enterelement(s,i+1,mas)end;
    ')': begin s:=')'; delete(Arr[i],length(Arr[i]),1); if length(arr[i])<>1 then enterelement(s,i+1,mas)end;
    ':': begin s:=':'; delete(Arr[i],length(Arr[i]),1); if length(arr[i])<>1 then enterelement(s,i+1,mas)end;
    ';': begin s:=';'; delete(Arr[i],length(Arr[i]),1); if length(arr[i])<>1 then enterelement(s,i+1,mas)end;
    '?': begin s:='?'; delete(Arr[i],length(Arr[i]),1); if length(arr[i])<>1 then enterelement(s,i+1,mas)end;
    end;
end;

begin
clrscr;
write('> ');
readln(s);
GetWords(s,mas);
filter(mas);
for i:=1 to high(mas) do if mas[i]<>'' then writeln(i,' - ',mas[i]);
end. 

пачему выводит стек оверфло?

[klem4]

Так пойдет ?

uses crt;

type

   TWords = array [1..128] of string;


function GetWords(s : string; var w : TWords) : byte;
const
   limits = [#0..#32, '.', ',', '!', '?', ':', ';', '"'];
var
   i, back, c : byte;
begin
   i := 1;
   c := 0;
   while (i <= length(s)) do begin
      while (i <= length(s)) and (s[i] in limits) do begin
         if not(s[i] in [#0..#32]) then begin
            inc©;
            w[c] := s[i];
         end;
         inc(i);
      end;
      if i <= length(s) then begin
         back := i;
         while (i <= length(s)) and not(s[i] in limits) do inc(i);
         inc©;
         w[c] := copy(s, back, i - back);
      end;
   end;
end;

procedure Print(w : TWords; n : byte);
var
   i : byte;
begin
   writeln;
   for i := 1 to n do writeln(w[i]);
end;

var

  s : string;
  w  : TWords;
begin
   clrscr;
   readln(s);
   Print(w, GetWords(s, w));
   readln;
end.