Заполнить очередь и стек и поменять их содержимое местами через дополнительный стек.

uses crt;
type plist=^tlist;
tlist=record
    zn:integer;
    next:pList;
end;
 
procedure PushS(var first:plist;a:integer);
var p:plist;
begin
  new(p);
  p^.zn:=a;
  p^.next:=nil;
  if (first=nil) then
   first:=p
  else
   begin
    p^.next:=first;
    first:=p;
   end;
end;
 
procedure BufPush(var first:plist; a:integer);
var p:plist;
begin
  new(p);
  p^.zn:=a;
  p^.next:=nil;
  if (first=nil) then
   first:=p
  else
   begin
    p^.next:=first;
    first:=p;
   end;
end;
 
function BufPop(var first:pList;var a:integer):boolean;
var
 p:pList;
begin
  if (first=nil) then
  begin
    writeln(' ');
    Bufpop:=false;
  end
  else
   begin
    p:=first;
    first:=first^.next;
    a:=p^.zn;
    dispose(p);
    Bufpop:=true;
   end;
end;
 
function PopS(var first:pList;var a:integer):boolean;
var
 p:pList;
begin
  if (first=nil) then
  begin
    writeln(' ');
    popS:=false;
  end
  else
   begin
    p:=first;
    first:=first^.next;
    a:=p^.zn;
    dispose(p);
    popS:=true;
   end;
end;
 
procedure PushQ(var first:plist;a:integer);
var p:plist;
begin
  new(p);
  p^.zn:=a;
  p^.next:=nil;
  if (first=nil) then
     first:=p
  else
  begin
    p^.next:=first;
    first:=p;
  end;
end;
 
function PopQ(var first:pList;var a:integer):boolean;
var
 p:pList;
begin
  if (first=nil) then
  begin
    writeln(' ');
    popQ:=false;
  end
  else
   begin
    p:=first;
    first:=first^.next;
    a:=p^.zn;
    dispose(p);
    popQ:=true;
   end;
end;
 
var  firstS,firstQ,lastQ,BufFirst:plist;
     a,a1,i:integer;
begin
  clrscr;
  firstS:=nil;
  firstQ:=nil;
  BufFirst:=nil;
  for i:=1 to  10 do
   begin
    pushS(firstS, i);
    pushQ(firstQ, i*i);
   end;
  writeln('Стек до:');
  while (popS(firstS,a)=true) do
   begin
    write(a,' ');
    Bufpush(BufFirst, a);
   end;
  writeln('Очередь до:');
  while (popQ(firstQ,a)=true) do
   begin
    write(a,' ');
    pushS(firstS,a);
   end;
  while (Bufpop(BufFirst,a)=true) do
   begin
    pushQ(firstQ,a);
   end;
  writeln('Стек после:');
  while (popS(firstS,a)=true) do
    write(a,' ');
  writeln('Очередь после:');
  while (popQ(firstQ,a)=true) do
    write(a,' ');
end.