Здравствуйте, rail!
Ну, типо...
[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('Введите количество элементов в стеке ');
Write('N= ');
readln(n);
until n > 0;
while n > 0 do
begin
znach := random(1000);
AddElem(yk, znach);
dec(n);
end;
clrscr;
Writeln('Стек до уменьшения ');
Print(yk);
change(yk);
Writeln;
Writeln('Стек после уменьшения ');
Print(yk);
readln;
FreeStek(yk);
end.[/code]