aritme_pilpre.pas

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
{ COMIENZO DE DESCRIPCION

Evalua expresiones aritm\'eticas en notaci\'on prefija
utilizando una pila. keywords: pila

FIN DE DESCRIPCION }
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
program aritme;

{ Pilas de pares (real-char) por punteros. }

type
  tipo_elemento	= record
		     op	 : char;
		     num : real
		  end;	 
		
  p_tipo_celda = ^tipo_celda;

  tipo_celda = record
    elemento: tipo_elemento;
    sig:      p_tipo_celda
  end;

  pila = object
  private
    top : p_tipo_celda;
    procedure ERROR (s: string);
  public
    procedure ANULA;
    procedure METE (x:tipo_elemento);
    procedure SACA;
    function  VACIA : boolean;
    function  TOPE  : tipo_elemento;
    procedure IMPRIME (s : string) ;
  end;			    

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
procedure pila.ERROR (s: string);
begin
  write ('error: ');
  writeln (s);
  halt;
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure pila.ANULA;
var
   p,q : p_tipo_celda;
begin
   if top=nil then new(top);
   q := top^.sig;
   while q <> nil do
   begin
      p:=q^.sig;
      dispose(q);
      q:=p;
   end;
   top^.sig := nil;
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
procedure pila.METE (x: tipo_elemento);
var
  aux: p_tipo_celda;
begin
   new(aux);
   aux^.elemento := x;
   aux^.sig := top^.sig;
   top^.sig := aux;
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
procedure pila.SACA;
var
   q : p_tipo_celda;
begin
   if (VACIA) then ERROR ('la pila esta vacia');
   q := top^.sig;
   top^.sig  := top^.sig^.sig ;
   dispose(q);
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
function  pila.VACIA : boolean;
begin
  VACIA := ( top^.sig = nil );
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
function  pila.TOPE : tipo_elemento;
begin
  if ( VACIA ) then ERROR (' la pila esta vacia');
  TOPE := top^.sig^.elemento ;
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
procedure pila.IMPRIME (s: string) ;
var
   q : p_tipo_celda;
begin
   if length (s) > 0 then
      write (s)
   else
      write ('pila: ');
   q := top^.sig;
   while q<>nil do
   begin
      if q^.elemento.op<>'0' then
	 write (q^.elemento.op,' ')
      else
	 write (q^.elemento.num:3:3,' ');
      q := q^.sig;
   end ; {while}
   writeln ;
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}
const
  max_elem = 20;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
procedure ERROR (s: string);
begin
   write ('error: ');
   writeln (s);
   halt;
end;

procedure METE_OP (par : tipo_elemento; P:pila);
var
   op1,op2 : real;
   op  : char;
begin
   if P.vacia or (P.tope.op <> '0') then
      P.mete(par)
   else
   begin
      op2 := par.num;
      op1 := P.tope.num;
      P.saca;
      op := P.tope.op;
      P.saca;
      par.op := '0';
      case op of
	'*' : par.num :=  (op1*op2);
	'+' : par.num :=  (op1+op2);
	'-' : par.num :=  (op1-op2);
	'/' : par.num :=  (op1/op2);
      end; { case }
      mete_op(par,P); { Llamada recursiva }
   end;
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
procedure METE_PUEDE_SER (var s: string; var P: pila);
var
   code	: integer;
   r	: real;
   par	: tipo_elemento;
begin 
   if (length (s) > 0) then begin
      val (s,r,code);
      par.op := '0';
      par.num := r;
      mete_op (par,P);
      s := '';
   end;
end;

{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----} 
var
   P	     : pila;
   c	     : char;
   s	     : string;
   par	     : tipo_elemento;
begin
   {inicializa la pila}
   P.anula;
   s := '';

   while (true) do begin
      write ('> ');
      while (true) do begin
        read (c);
        case c of '*', '-', '+', '/':
	begin
	   par.op := c;
	   P.mete(par);
	end;
	  
       #10 : begin
	  METE_PUEDE_SER (s,P);
	  writeln('resultado: ',P.tope.num);
	  P.saca;
	  break ;
       end; { case }
	  
       '0' .. '9','.':
	begin
           s := s + c;
       end;

       ' ': begin
          METE_PUEDE_SER(s,P);
       end;
	   
      else
	 error('Not valid character.');
	   
	 end; { case }
      end;
   end;
end.
{-----+-----+-----+-----+-----+-----+-----+-----+-----+-----}