Калькулятор. Вычисление арифметических выражений - Free Pascal

program Calc;
 Uses ListWork,crt;
 type cptr = ^char;
      iptr = ^ integer;
 const
      digits : set of char = ['0'..'9'];
      prty : set of char = ['*','/'];
 var s : string;
     n : integer;
Function Creat_Lst : lpt;
 var lll : lpt;
     s1 : char;
     st : string;
 
   Procedure NewInt;
   var ip : iptr; cc : integer;
     begin
     if Length(st) > 0 then begin
       New(ip); Val(st,ip^,cc);
       lll:=Append(NewAtom(ip,'I'),lll);
       st:='';
      end;  end;
   Procedure NewChar;
   var cp : cptr;
     begin
     New(cp); cp^:=s1;
     lll:=Append(NewAtom(cp,'C'),lll);
   end;
   begin
   lll:=nil;  st:='';
   while n <= length(s) do begin
     s1:=s[n]; n:=n+1;
     case s1 of
       '(' :
         lll:=Append(NewNode(Creat_Lst),lll);
       ')' :
          begin
            NewInt; Creat_Lst:=lll; Exit;
            end;
       else
          if s1 in Digits then
            st:=st+s1
          else begin
            NewInt;
            NewChar;
        end;      end;   end;
   NewInt;
   Creat_Lst:=lll;
 end;
 Function FormPrty(l : lpt) : lpt;
  var op1, op, op2 : lpt;
      l2,l3 : lpt;
      cp: ^char;
    begin
    l2:=nil;
    op1:=car(l);  l:=cdr(l);
    if not atom(op1) then op1:=FormPrty(op1);
    while l<>nil do begin
      op:=car(l);  l:=cdr(l);
      op2:=car(l); l:=cdr(l);
      if not atom(op2) then op2:=FormPrty(op2);
      if cptr(op^.down)^ in prty then
 
        op1:=cons(op1,cons(op,cons(op2,nil)))
      else begin
        l2:=Append(op,Append(op1,l2));
        op1:=op2;
     end;  end;
    FormPrty:=Append(op1,l2);
 end;
 Function Eval(l : lpt) : integer;
 var op1, op, op2 : lpt;
  begin
    op1:=car(l);  l:=cdr(l);
    if not atom(op1) then iptr(op1^.down)^:=Eval(op1);
    while l <> nil do begin
      op:=car(l);  l:=cdr(l);
      op2:=car(l); l:=cdr(l);
      if not atom(op2) then iptr(op2^.down)^:=Eval(op2);
      case cptr(op^.down)^ of
        '+' : iptr(op1^.down)^:=iptr(op1^.down)^+iptr(op2^.down)^;
        '-' : iptr(op1^.down)^:=iptr(op1^.down)^-iptr(op2^.down)^;
        '*' : iptr(op1^.down)^:=iptr(op1^.down)^*iptr(op2^.down)^;
        '/' : iptr(op1^.down)^:=iptr(op1^.down)^ div iptr(op2^.down)^;
        end;
      end;
    Eval:=iptr(op1^.down)^;
 end;
 var l : lpt;
   begin
   clrscr;
   write('Input vuraz?->'); readln(s);
   n:=1; 
   l:=Creat_Lst;
    l:=FormPrty(l);
    writeln(s,'=',Eval(l));
   readkey;
 END.

Unit ListWork;
 Interface
 type lpt = ^litem; 
   litem = record
       typeflg : char; 
       down : pointer; 
       next: lpt; 
       end;
 Function NewAtom(d: pointer; t : char) : lpt;
 Function NewNode(d: lpt) : lpt;
 Function Atom(l : lpt) : boolean;
 Function Cdr(l : lpt) : lpt;
 Function Car(l : lpt) : lpt;
 Function Cons(l1, l : lpt) : lpt;
 Function Append(l1,l : lpt) : lpt;
 Implementation
 Function NewAtom(d: pointer; t : char) : lpt;
  var l : lpt;
   begin   New(l);
    l^.typeflg:=t; 
    l^.down:=d;    
    l^.next:=nil;   NewAtom:=l;
   end;
 Function NewNode(d: lpt) : lpt;
  var l : lpt;
    begin
    New(l);
    l^.typeflg:=Chr(0); 
    l^.down:=d;    
    l^.next:=nil;
    NewNode:=l;
    end;
 
 Function Atom(l : lpt) : boolean;
   begin   
   if l^.typeflg=Chr(0) then Atom:=false
   else Atom:=true;
   end;
 Function Car(l : lpt) : lpt;  
   begin  Car:=l^.down;     end;
 Function Cdr(l : lpt) : lpt;
   begin   Cdr:=l^.next;    end;
   
 Function Cons(l1,l : lpt) : lpt;
  var l2 : lpt;
   begin  l2:=NewNode(l1); 
   l2^.next:=l;           
   Cons:=l2;              
   end;
 
 Function Append(l1,l : lpt) : lpt;
  var l2, l3 : lpt;
   begin
   l2:=NewNode(l1);  
 
   if l=nil then Append:=l2
   else begin   
     l3:=l; while l3^.next <> nil do l3:=l3^.next;
     l3^.next:=l2;    
     Append:=l;      
     end;  end;
 END.