[code lang=pascal]Program Stek;
uses
crt; {Для использования readkey и clrscr}
type
Tinf=integer; {тип данных, который будет храниться в элементе стека}
List=^TList; {Указатель на элемент типа TList}
TList=record {А это наименование нашего типа "запись" обычно динамические структуры описываются через запись}
data:TInf; {данные, хранимые в элементе}
next:List; {указатель на следующий элемент}
end;


{Процедура добавляющая элемент в стек}
procedure AddElem(var stek1:List;znach1:TInf);
var
tmp:List;
begin
GetMem(tmp,sizeof(TList)); {выделяем в памяти место для нового элемента}
tmp^.next:=stek1; {указатель на следующий элемент "направляем" на вершину стека}
tmp^.data:=znach1; {добавляем к элементу данные}
stek1:=tmp; {вершина стека изменилась, надо перенести и указатели на неё}
end;

{Процедура вывода стека}
procedure Print(stek1:List);
begin
if stek1=nil then {проверка на пустоту стека}
begin
writeln('‘⥪ Їгбв.');
exit;
end;
while stek1<>nil do {пока указатель stek1 не станет указывать в пустоту}
begin {а это произойдёт как только он перейдёт по ссылке последнего элемента}
Write(stek1^.data, ' '); {выводить данне}
stek1:=stek1^.next {и переносить указатель вглубь по стеку}
end;
end;

procedure change(var yk:List);
var
tmp,tmp1:List;
begin
if yk=nil then
exit;
tmp:=yk;
while tmp^.next<>nil do
tmp:=tmp^.next; {ставим tmp на последний элемент}
tmp1:=yk;
while tmp1^.next<>tmp do {tmp1 ставим на предпоследний элемент}
tmp1:=tmp1^.next;
if tmp1=yk then {в стеке два элемента}
begin
yk^.next:=nil;
tmp^.next:=yk;
yk:=tmp;
end
else
begin
tmp1^.next:=yk;
tmp^.next:=yk^.next;
yk^.next:=nil;
yk:=tmp;
end;
end;

{Процедура освобождения памяти занятой стеком}
Procedure FreeStek(stek1:List);
var
tmp:List;
begin
while stek1<>nil do {пока stek1 не станет указывать в "пустоту" делать}
begin
tmp:=stek1; {указатель tmp направим на вершину стека}
stek1:=stek1^.next; {вершину стека перенесём на следующий за данной вершиной элемент}
FreeMem(tmp,SizeOf(Tlist)); {освободим память занятую под старую вершину}
end;
end;

var
yk:List; {Указатель на "начало" стека}
n:integer;
znach:Tinf;
begin
randomize;
repeat
clrscr;
Writeln('Vvedute kolu4ectvo elementov v steke');
Write('N= ');
readln(n);
until n>0;
while n>0 do
begin
znach:=random(1000);
AddElem(yk,znach);
dec(n);
end;
clrscr;
Writeln('Ctek do u3menenui');
Print(yk);
change(yk);
Writeln;
Writeln('Ctek pocle u3menenui');
Print(yk);
readln;
FreeStek(yk);
end.[/code]

Приложение:
на сборку программы ушло 7 минут: