{Based on PascalPro and P4}

program kompilator_snosse;

uses crt; {<-Temporary}

const
 temp='test.pas'; {<- temporary}
 temp2='test.asm';
 temp3='test.inc';
 nrRw=38;
 observ=false;
 intsize=2;
 ptrsize=1;
 realsize=1;
 boolsize=1;
 charsize=1;
 parmsize=1;
 setsize=1;
 strsize=256;

 intal=2;
 adral=1;
 realal=1;
 boolal=1;
 charal=1;
 parmal=1;
 setal=1;
 fileal=1;
 recal=1;

 setlow=0;
 sethigh=47;

 displev=20;

type
  ctType=(ctLetter,ctNumber,ctSpcl,ctIllegal,
          ctApostr,ctCol,ctDot,ctLS,ctGT,ctBrack,ctSpace,ctClam);
  stType=(ident,intconst,realconst,stringconst,notsy,mulop,addop,relop,
          lparent,rparent,lbrack,rbrack,comma,semicolon,dot,arrow,
	  colon,ddot,becomes,labelsy,constsy,typesy,varsy,funcsy,progsy,
	  procsy,setsy,packedsy,arraysy,recordsy,filesy,forwardsy,
          beginsy,ifsy,casesy,repeatsy,whilesy,forsy,withsy,
	  gotosy,endsy,elsesy,untilsy,ofsy,dosy,tosy,downtosy,
	  thensy,othersy,lclam,rclam,atop);
  otType=(noop,mul,rdiv,andop,idiv,imod,plus,minus,orop,ltop,leop,geop,gtop,
          neop,eqop,inop,shlop,shrop,xorop);


  {_____________________________________________}

  setty = set of 0..47;
  cstclass = (reel,pset,strg);
  csp = ^ constant;
  constant = record case cclass: cstclass of
			 reel: (rval: packed array [0..255] of char);
			 pset: (pval: setty);
			 strg: (sval: packed array [0..255] of char)
  end;

  levrange = 0..10; addrrange = 0..32676;
  structform = (scalar,subrange,pointer,power,arrays,records,files,
		   tagfld,variant);
  declkind = (standard,declared);
  stp = ^ structure; ctp = ^ identifier;

  valu = record case intval: boolean of  
		     true:  (ival: integer);
		     false: (valp: csp)
  end;

  structure = record
		   marked: boolean;   
		   size: addrrange;
		   case form: structform of
		     scalar:   (case scalkind: declkind of
				  declared: (fconst: ctp); standard: ());
		     subrange: (rangetype: stp; min,max: valu);
		     pointer:  (eltype: stp);
		     power:    (elset: stp);
		     arrays:   (aeltype,inxtype: stp);
		     records:  (fstfld: ctp; recvar: stp);
		     files:    (filtype: stp);
		     tagfld:   (tagfieldp: ctp; fstvar: stp);
		     variant:  (nxtvar,subvar: stp; varval: valu)
  end;


     idclass = (types,konst,vars,field,proc,func);
     setofids = set of idclass;
     idkind = (actual,formal);


     identifier = record
		   name: string; llink, rlink: ctp;
		   idtype: stp; next: ctp;
		   case klass: idclass of
		     types: ();
		     konst: (values: valu);
		     vars:  (vkind: idkind; vlev: levrange; vaddr: addrrange);
		     field: (fldaddr: addrrange);
		     proc, func:  (case pfdeckind: declkind of
			      standard: (key: 1..15);
			      declared: (pflev: levrange; pfname: integer;
					  case pfkind: idkind of
					   actual: (forwdecl, extern: boolean);
					   formal: ()))
		   end;

     lbp = ^ labl;
     labl = record next: lbp; defined,already: boolean;
		   labval, labname: integer
	    end;

     where = (blck,crec,vrec,rec);

     testp = ^ testpointer;
     testpointer = record
		     elt1,elt2 : stp;
		     lasttestp : testp
		   end;


     extfilep = ^filerec;
     filerec = record filename:string; nextfile:extfilep end;

     attrkind = (cst,varbl,expr);
     vaccess = (drct,indrct,inxd);

     ttyp=(none,intt,realt,strt);

     attr = record typtr: stp;
                   typ:ttyp;
            case kind: attrkind of
		 cst:   (cval: valu);
		 varbl: (case access: vaccess of
			  drct: (vlevel: levrange; dplmt: addrrange);
			  indrct: (idplmt: addrrange))
	      end;


     tsign=(plussign,minussign);

type
  alpha=packed array[0..255] of char;

var
 progname:string;

 input,output,output2:text;
 lncount,chcount:longint;

 ctArray:array[char] of ctType;
 rwArray:array[1..nrRw] of string;
 na:array[1..35] of string;
 rsy:array[1..nrRw] of stType;
 rop:array[1..nrRw] of otType;
 ssy:array[char] of stType;
 sop:array[char] of otType;
 err:array[1..255] of string[45];

    display:
      array [0..22] of
	record
	  fname: ctp; flabel: lbp;
	  case occur: where of
	    crec: (clev: levrange;  
		  cdspl: addrrange);
	    vrec: (vdspl: addrrange)
	  end;
     disx, top: 0..22;

     level:levrange;

     parmptr,
     intptr,realptr,charptr,
     boolptr,nilptr,textptr,strptr,wordptr,
     shortintptr,byteptr,longintptr,int64ptr: stp;
     utypptr,ucstptr,uvarptr,
     ufldptr,uprcptr,ufctptr,
     fwptr: ctp;
     fextfilep: extfilep;
     globtestp: testp;

 number:string; {Last real}
 ch:char;
 lsIdn:string;     {Last idn}
 lsSym:stType;    {Last symbol}
 lsOp:otType;     {Last operator}
 lsInt:integer;   {Last integer}
 lsAttr:attr;
 lsVal:valu;
 i,j:integer;
 ends:boolean;
 error:boolean;
 lsLabel,lsTextNum:word;


 {Procedure - Forward}
 procedure wrerror(num:word); forward;
 procedure donefile; forward;
 procedure call(fcp:ctp); forward;

procedure GetSymbol;
var
 temp,i:integer;

label
 start,3;
{Lexical analizer - read next symbol of source program}

   procedure NextChar;
     {Read next char from file}
     begin
       if not eof(input) then begin
          if eoln(input) then begin
             lncount:=lncount+1;
             chcount:=0;
             readln(input);
             ch:=' ';
             exit;
             if observ then begin writeln; end;
          end;
          read(input,ch);
          if observ then begin write(ch); end;
             chcount:=chcount+1;
       end else begin
          if not ends then
             wrerror(10);
       end;
   end;{NextChar}

   procedure options;
     begin

   end;{Option}

  begin
    start:

    while (ch=' ') or (ch=' ') do
          nextchar;



    case ctArray[ch] of
         ctLetter:
             begin
               lsIdn[0]:=chr(0);
               repeat
                 lsIdn[0]:=chr((ord(lsIdn[0])+1));
                 lsIdn[ord(lsIdn[0])]:=ch;
                 nextchar;
               until not (ctArray[ch] in [ctLetter,ctNumber]);
               lsSym:=ident;
               lsOp:=noop;
               for i:=1 to nrRw do begin
                   if rwArray[i]=lsIdn then begin
                      writeln(lsIdn+':'+rwArray[i]+'<',ch,'<');
                      lsSym:=rsy[i];
                      lsOp:=rop[i];
                      break;
                   end;
               end;
             end;

        ctNumber:
             begin
               lsIdn:='';
               lsOp:=noop;
               number[0]:=chr(1);
               number[1]:='+';
               repeat
                 number[0]:=chr(ord(number[0])+1);
                 number[ord(number[0])]:=ch;
                 nextchar;
               until ctArray[ch]<>ctNumber;
               lsSym:=IntConst;
               if ch='.' then begin
                  nextchar;
                  if ctArray[ch]<>ctNumber then begin
                     if ctArray[ch]<>ctDot then begin
                        wrerror(201);
                     end else begin
                        ch:=':';
                        goto 3;
                     end;
                  end;

                  number[0]:=chr(ord(number[0])+1);
                  number[ord(number[0])]:='.';

                  repeat
                    number[0]:=chr(ord(number[0])+1);
                    number[ord(number[0])]:=ch;
                    nextchar;
                  until ctArray[ch]<>ctNumber;

                  lsSym:=RealConst;

               end;
               if ch='e' then begin
                  nextchar;

                  number[0]:=chr(ord(number[0])+1);
                  number[ord(number[0])]:='e';

                  if (ch='-') or (ch='+') then begin
                     number[0]:=chr(ord(number[0])+1);
                     number[ord(number[0])]:=ch;
                     nextchar;
                  end;
                  if ctArray[ch]<>ctNumber then
                     wrerror(201);
                  repeat
                    number[0]:=chr(ord(number[0])+1);
                    number[ord(number[0])]:=ch;
                    nextchar;
                  until ctArray[ch]<>ctNumber;

                  lsSym:=RealConst;

               end;
               3:
               if lsSym=IntConst then begin
                  lsInt:=0;
                  for i:=ord(number[0]) downto 2 do begin
                      temp:=ord(number[i])-ord('0');
                      for j:=1 to ord(number[0])-i do begin
                          temp:=temp*10;
                      end;
                      lsInt:=lsInt+temp;
                  end;
                  lsVal.ival:=lsInt;
               end else begin
                  lsVal.valp^.cclass:=reel;
                  for i:=0 to ord(number[0])+1 do
                      lsVal.valp^.rval[i]:=number[i];
               end;

             end;

        ctApostr:
             begin
               new(lsVal.valp);
               lsVal.valp^.sval[0]:=chr(0);
               lsVal.valp^.cclass:=strg;
               lsSym:=StringConst;
               lsOp:=NoOp;
               repeat
                 if eoln(input) then
                    wrerror(202);
                 nextchar;
                 if ch<>'''' then begin
                    lsVal.valp^.sval[0]:=chr(ord(lsVal.valp^.sval[0])+1);
                    lsVal.valp^.sval[ord(lsVal.valp^.sval[0])]:=ch;
                 end;
               until ch='''';
               nextchar;
             end;

        ctCol:
             begin
               lsOp:=NoOp;
               NextChar;
               if ch='=' then begin
                  lsSym:=becomes;
                  nextchar;
               end else
                  lsSym:=colon;
             end;

        ctDot:
             begin
               lsOp:=NoOp;
               nextchar;
               if ch='.' then begin
                  lsSym:=colon;
                  nextchar;
               end else
                  lsSym:=Dot;
             end;

        ctLs:
             begin
               nextchar;
               if ch='=' then begin
                  lsOp:=leop;
                  nextchar;
               end else begin
                  if ch='>' then begin
                     lsOp:=neop;
                     nextchar;
                  end else
                     lsOp:=ltop;
               end;
               lsSym:=RelOp;
             end;

        ctGt:
             begin
               nextchar;
               if ch='=' then begin
                  lsOp:=geop;
                  nextchar;
               end else
                  lsOp:=gtop;
               lsSym:=RelOp;
             end;

        ctBrack:
             begin
               nextchar;
               if ch='*' then begin
                  repeat
                    repeat
                      nextchar;
                    until ch='*';
                    nextchar;
                  until ch=')';
                  nextchar;
                  goto start;
               end;
               lsSym:=lparent;
               lsOp:=noop;
             end;

        ctClam: begin
                  repeat
                    nextchar;
                  until ch='}';
                  nextchar;
                  goto start;
                end;

        ctSpcl:
             begin
               lsSym:=ssy[ch];
               lsOp:=sop[ch];
               nextchar;
               if (lsSym=mulop) and (ch='/') then begin
                  repeat
                    nextchar;
                  until eoln(input);
                  nextchar;
               end;
             end;

        ctSpace: lsSym:=othersy;

    end;
    writeln('>'+lsIdn+'<',ch,'<');
   { writeln(ord(lsSym),'-',lsStr);
    writeln('[',ord(lsOp),']');}
    writeln('+',number,'+',lsInt);


end;{GetSymbol}


function putlabel:longint;
  begin
    lsLabel:=lsLabel+1;
    putlabel:=lsLabel;
end;



procedure createlabel(str:string;num:longint);
  begin
     writeln(output,progname,'_',level,'_',num,str,':');
end;

procedure createjmp(typ,str:string;num:longint);
  begin
     writeln(output,typ,' ',progname,'_',level,'_',num,str);
end;

procedure enterid(fcp: ctp);
    var nam: string; lcp, lcp1: ctp; lleft: boolean;
  begin nam := fcp^.name;
    lcp := display[top].fname;
    if lcp = nil then
      display[top].fname := fcp
    else
      begin
	repeat lcp1 := lcp;
	  if lcp^.name = nam then begin
             lsIdn:=nam;
	     wrerror(4) {}
	  end else
	    if lcp^.name < nam then
	      begin lcp := lcp^.rlink; lleft := false end
	    else begin lcp := lcp^.llink; lleft := true end
	until lcp = nil;
	if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp
      end;
    fcp^.llink := nil; fcp^.rlink := nil;
  end (*enterid*) ;

  procedure searchsection(fcp: ctp; var fcp1: ctp);
     label 1;
  begin
    while fcp <> nil do
      if fcp^.name = lsIdn then goto 1
      else if fcp^.name < lsIdn then fcp := fcp^.rlink
	else fcp := fcp^.llink;
1:  fcp1 := fcp
  end (*searchsection*) ;

  procedure searchid(fidcls: setofids; var fcp: ctp);
    label 1;
    var lcp: ctp;
        disx : integer;
  begin

    for disx := top downto 0 do
      begin lcp := display[disx].fname;
	while lcp <> nil do
	  if lcp^.name = lsIdn then begin
	    if lcp^.klass in fidcls then goto 1
	    else
                if error then
                   wrerror(103);
	  end else
	    if lcp^.name < lsIdn then
	      lcp := lcp^.rlink
	    else lcp := lcp^.llink
      end;
      if error then
         wrerror(3);{}
1:  fcp := lcp;
  end;{searchid}


  procedure searchlbl;
    var
      llp:lbp;
    begin
      llp:=display[top].flabel;
      if llp=nil then
         exit;
      while (llp<>nil) and (llp^.labval<>lsVal.ival) do
            llp:=llp^.next;
      if llp^.labval=lsVal.ival then
         wrerror(232);
  end;{searchlbl}

  procedure getbounds(fsp: stp; var fmin,fmax: integer);
  begin
    fmin:=0; fmax:=0;
    if fsp<>nil then
    if fsp^.form=subrange then begin
       fmin:=fsp^.min.ival;
       fmax:=fsp^.max.ival;
    end else begin
       if fsp =charptr then begin
          fmin:=ord(fsp^.min.valp^.sval[1]);
          fmax:=ord(fsp^.max.valp^.sval[1]);
       end else
          if fsp^.fconst<>nil then
	     fmax:=fsp^.fconst^.values.ival;
    end;
  end; {getbounds}

  function alignquot(fsp: stp): integer;
  begin
    alignquot:=1;
    if fsp<>nil then
      with fsp^ do
	case form of
	  scalar:   if (fsp=intptr) or (fsp=wordptr) then alignquot:=intal
		    else if fsp=boolptr then alignquot:=boolal
		    else if scalkind=declared then alignquot:=intal
		    else if fsp=charptr then alignquot:=charal
		    else if fsp=realptr then alignquot:=realal
		    else (*parmptr*) alignquot:=parmal;
	  subrange: alignquot:=alignquot(rangetype);
	  pointer:  alignquot:=adral;
	  power:    alignquot:=setal;
	  files:    alignquot:=fileal;
	  arrays:   alignquot:=alignquot(aeltype);
	  records:  alignquot:=recal;
	  variant,tagfld: wrerror(101);
	end;
  end; {AlignQuot}

  procedure align(fsp: stp; var flc: addrrange);
    var k,l: integer;
  begin
    k:=alignquot(fsp);
    l:=flc-1;
    flc:=l+k-(k+l) mod k;
  end; {Align}

  function equalbounds(fsp1,fsp2:stp):boolean;
    var
      lmin1,lmin2,lmax1,lmax2:integer;
    begin
      equalbounds:=true;
      if (fsp1<>nil) and (fsp2<>nil) then begin
         getbounds(fsp1,lmin1,lmax1);
         getbounds(fsp2,lmin2,lmax2);
         equalbounds:=(lmin1=lmin2) and (lmax1=lmax2);
      end;
  end;

  function comptypes(fsp1,fsp2: stp) : boolean;
      (*decide whether structures pointed at by fsp1 and fsp2 are compatible*)
      var nxt1,nxt2: ctp; comp: boolean;
	ltestp1,ltestp2 : testp;
    begin
      if fsp1 = fsp2 then comptypes := true
      else
	if (fsp1 <> nil) and (fsp2 <> nil) then
	  if fsp1^.form = fsp2^.form then
	    case fsp1^.form of
	      scalar:
		comptypes := false;
		(* identical scalars declared on different levels are
		 not recognized to be compatible*)
	      subrange:
		comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype);
	      pointer:
		  begin
		    comp := false; ltestp1 := globtestp;
		    ltestp2 := globtestp;
		    while ltestp1 <> nil do
		      with ltestp1^ do
			begin
			  if (elt1 = fsp1^.eltype) and
			     (elt2 = fsp2^.eltype) then comp := true;
			  ltestp1 := lasttestp
			end;
		    if not comp then
		      begin new(ltestp1);
			with ltestp1^ do
			  begin elt1 := fsp1^.eltype;
			    elt2 := fsp2^.eltype;
			    lasttestp := globtestp
			  end;
			globtestp := ltestp1;
			comp := comptypes(fsp1^.eltype,fsp2^.eltype)
		      end;
		    comptypes := comp; globtestp := ltestp2
		  end;
	      power:
		comptypes := comptypes(fsp1^.elset,fsp2^.elset);
	      arrays:
		begin
		  comp := comptypes(fsp1^.aeltype,fsp2^.aeltype)
		      and comptypes(fsp1^.inxtype,fsp2^.inxtype);
		  comptypes := comp and (fsp1^.size = fsp2^.size) and
		      equalbounds(fsp1^.inxtype,fsp2^.inxtype)
		end;
	      records:
		begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true;
		  while (nxt1 <> nil) and (nxt2 <> nil) do
		    begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype);
		      nxt1 := nxt1^.next; nxt2 := nxt2^.next
		    end;
		  comptypes := comp and (nxt1 = nil) and (nxt2 = nil)
			      and(fsp1^.recvar = nil)and(fsp2^.recvar = nil)
		end;
		(*identical records are recognized to be compatible
		 iff no variants occur*)
	      files:
		comptypes := comptypes(fsp1^.filtype,fsp2^.filtype)
	    end (*case*)
	  else (*fsp1^.form <> fsp2^.form*)
	    if fsp1^.form = subrange then
	      comptypes := comptypes(fsp1^.rangetype,fsp2)
	    else
	      if fsp2^.form = subrange then
		comptypes := comptypes(fsp1,fsp2^.rangetype)
	      else comptypes := false
	else comptypes := true
    end (*comptypes*) ;

    function isstring(fsp: stp) : boolean;
    begin isstring := false;
      if fsp <> nil then
	if fsp^.form = arrays then
	  if comptypes(fsp^.aeltype,charptr) then isstring := true
    end (*string*) ;





procedure testident;
  begin
    if lsSym<>ident then
       wrerror(2);
end;

procedure testsemicolon;
   begin
     if lsSym<>semicolon then
        wrerror(85);{}
end;

procedure varfield(fcp:ctp);
  begin
    lsAttr.typtr:=fcp^.idtype;
    lsAttr.kind:=varbl;

    {Okreslanie poziomu!!!!!!!!}

    if (lsAttr.typtr=intptr) or (lsAttr.typtr=wordptr) or
       (lsAttr.typtr=shortintptr) or (lsAttr.typtr=longintptr) or
       (lsAttr.typtr=byteptr) then begin
       lsAttr.typ:=intt;
       writeln(output,'xor ax,ax');
       if (lsAttr.typtr=byteptr) or (lsAttr.typtr=shortintptr) then
          writeln(output,'mov al,',progname,'_',level,'v_',fcp^.name)
       else
          writeln(output,'mov ax,',progname,'_',level,'v_',fcp^.name);

    end else begin
        if (lsAttr.typtr=realptr) then begin
           lsAttr.typ:=realt;
        end else begin
            lsAttr.typ:=none;
        end;
    end;




    while lsSym in [arrow,dot,lbrack] do
      begin
        case lsSym of
             lbrack: begin
                       if (lsAttr.typtr<>nil) and (lsAttr.typtr^.form<>arrays) then
                          wrerror(135);

                     end;
             dot:   begin
                    end;
             arrow: begin
                    end;
        end;
    end
end;


{Name of procedures from P4 ISO standard}
procedure expression;
  var
    sign:tsign; lsp:stp; lcp:ctp; lattr:attr; lop:otType;

    function ntest(a,b:attr):boolean;
      begin
        ntest:=false;
        if ((a.typ = intt) and (b.typ=intt)) or
           ((a.typ = intt) and (b.typ=realt)) or
           ((a.typ = realt) and (b.typ=intt)) or
           ((a.typ = realt) and (b.typ=realt)) then begin
           ntest:=true;
        end;
    end;

    procedure simpleexp;
      var
         lattr: attr; lop: otType;
      procedure term;
        var lattr: attr; lop: otType;  test:boolean;

        procedure factor;
          var lcp: ctp; lvp: csp; lsp: stp;
          begin
            writeln('Factor');
            if not (lsSym in [intconst,realconst,stringconst,ident,lparent,lbrack,notsy]) then
               wrerror(234);
            lsAttr.typ:=none;
            while lsSym in [intconst,realconst,stringconst,ident,lparent,lbrack,notsy] do
             begin
              case lsSym of
                   intconst: begin
                               lsAttr.typtr:=intptr; lsattr.kind:=cst;
                               lsattr.cval:=lsVal;   lsAttr.typ:=intt;
                               writeln(output,'mov ax, ',lsVal.ival);
                               getsymbol;
                             end;
                   realconst: begin
                                lsAttr.typtr:=realptr; lsAttr.kind:=cst;
                                lsAttr.cval:=lsVal; lsAttr.typ:=realt;
                                getsymbol;
                              end;
                   stringconst: begin
                                  if ord(lsVal.valp^.sval[0])=1 then
                                     lsAttr.typtr:=charptr
                                  else begin
                                     new(lsp);
                                     lsp:=strptr;
                                     lsAttr.typtr:=lsp;
                                  end;

                                  lsTextNum:=lsTextNum+1;
                                  write(output2,progname,'_',level,'str_',lsTextNum,' db ');
                                  write(output2,ord(lsVal.valp^.sval[0]),',''');
                                  for i:=1 to ord(lsVal.valp^.sval[0]) do
                                      write(output2,lsVal.valp^.sval[i]);
                                  writeln(output2,'''');

                                  lsAttr.typ:=strt;
                                  lsAttr.kind:=cst;
                                  lsAttr.cval:=lsVal;
                                  getsymbol;
                                end;
                   lbrack: begin

                           end;

                   atop: begin
                           getsymbol;
                           if lsSym<>ident then
                              wrerror(3);
                           getsymbol;
                         end;

                   lparent: begin
                              getsymbol;
                              expression;
                              if lsSym<>rparent then
                                 wrerror(243);
                              getsymbol;
                            end;
                   ident: begin
                            searchid([konst,vars,field,func],lcp);
			    getsymbol;
			    if lcp^.klass=func then begin
                               call(lcp);
			       with lsAttr do begin
                                    kind := expr;
				    if typtr <> nil then
				       if typtr^.form=subrange then
				          typtr := typtr^.rangetype
			       end;
			    end else
			        if lcp^.klass = konst then begin
			           with lsAttr, lcp^ do begin
                                        typtr := idtype; kind := cst;
				        cval := values;
                                   end;
				end else begin
                                   varfield(lcp);
                                   writeln('Hoop!');
				   if lsAttr.typtr<>nil then begin
				      with lsAttr,typtr^ do begin
				           if form = subrange then
				              typtr := rangetype
                                      end;
                                   end;
			        end;
                            end;
                   notsy: begin
                            getsymbol;
                            factor;
                            {Tutaj oczywiscie wszystkie typy}
        		    if lsAttr.typtr <> nil then
			       if lsAttr.typtr <> boolptr then
                                  wrerror(135);
                          end;

              end;
        end;

        end;
        begin{Term}
          writeln('Factor');

          factor;

          while lsSym=mulop do
            begin
              lattr:=lsAttr;
              lop:=lsOp;
              getsymbol;

              writeln(output,'push ax');
              factor;
              writeln(output,'pop bx');

              if (lattr.typtr<>nil) and (lsAttr.typtr<>nil) then begin
                 case lop of
                      mul:  if ntest(lattr,lsattr) then begin
                               writeln(output,'imul bx');
                            end else
                               wrerror(26);
                      rDiv: if ntest(lattr,lsattr){} then begin

                            end else
                               wrerror(26);
                      iDiv: if ntest(lattr,lsattr) then begin
                               writeln(output,'idiv bx');
		             end else
                              wrerror(41);
                      imod: if ntest(lattr,lsattr) then begin
                               writeln(output,'and ax,bx');
		             end else
                              wrerror(41);
                      andop: if ntest(lattr,lsattr) or (lattr.typtr = boolptr) and (lsAttr.typtr = boolptr) then begin
                              writeln(output,'and ax,bx');
		             end else
                              wrerror(41);
                      shlop: if ntest(lattr,lsattr) then begin
                              writeln(output,'shl ax,bx');
		             end else
                              wrerror(41);
                      shrop: if ntest(lattr,lsattr) then begin
                              writeln(output,'shr ax,bx');
		             end else
                              wrerror(41);
                 end;
              end else begin
                 lsAttr.typtr:=nil;
              end;
          end;
      end;

      begin{SimpleExp}
        writeln('SimpleExp');
        sign:=plussign;
        if (lsSym=addop) and (lsOp=minus) then begin
           sign:=minussign;
           getsymbol;
        end;

        term;
        {Zmiana znaku}
        while lsSym=addop do
          begin
            lattr:=lsAttr;
            lop:=lsOp;

            getsymbol;

            writeln(output,'push ax');
            term;
            writeln(output,'pop bx');

            if (lattr.typtr<>nil) and (lsAttr.typtr<>nil) then begin
               case lop of
                    plus:  if ntest(lattr,lsattr) or
                              ((lattr.typtr=charptr) and (lsAttr.typtr=charptr)) or
                              ((lattr.typtr=strptr) and (lsAttr.typtr=charptr)) or
                              ((lattr.typtr=charptr) and (lsAttr.typtr=strptr)) or
                              ((lattr.typtr=strptr) and (lsAttr.typtr=strptr)) then begin
                              if ntest(lattr,lsattr) then begin
                                 writeln(output,'add ax,bx');
                              end else begin

                              end;
                           end else
                              wrerror(41);
                    minus: if ntest(lattr,lsattr) then begin
                              writeln(output,'sub bx,ax');
                              writeln(output,'mov ax,bx');
                           end else
                               wrerror(41);
                    orop:  if ntest(lattr,lsattr) or
                              ((lattr.typtr=boolptr) and (lsAttr.typtr=boolptr)) then begin
                              writeln(output,'or ax,bx');
                           end else
                               wrerror(41);
                    xorop: if ntest(lattr,lsattr) or
                              ((lattr.typtr=boolptr) and (lsAttr.typtr=boolptr)) then begin
                              writeln(output,'xor ax,bx');
                           end else
                               wrerror(41);
               end;
            end else begin
               lsAttr.typtr:=nil;
            end;

        end;
      end;

  begin{Expression}
    writeln('Expression');
    simpleexp;
    if lsSym=relop then begin
       lattr:=lsAttr;
       lop:=lsOp;
       getsymbol;

       writeln(output,'push ax');
       simpleexp;
       writeln(output,'pop bx');

       {Real -> Integer}
       if (lattr.typtr=realptr) or (lsAttr.typtr=realptr) then begin
          if (lsattr.typtr=intptr) or (lsattr.typtr=longintptr) or
             (lsattr.typtr=shortintptr) or (lsattr.typtr=byteptr) or
             (lsattr.typtr=wordptr) then begin
	     lattr.typtr:=realptr; lsAttr.typtr:=realptr;
          end else begin
             if (lattr.typtr=intptr) or (lattr.typtr=longintptr) or
                (lattr.typtr=shortintptr) or (lattr.typtr=byteptr) or
                (lattr.typtr=wordptr) then begin
	        lattr.typtr:=realptr; lsAttr.typtr:=realptr;
             end;
          end;
       end;

       {Integer -> Longint}
       if (lattr.typtr=intptr) or (lattr.typtr=longintptr) or
          (lattr.typtr=shortintptr) or (lattr.typtr=byteptr) or
          (lattr.typtr=wordptr) then begin
	  lattr.typtr:=longintptr;
       end;
       if (lsattr.typtr=intptr) or (lsattr.typtr=longintptr) or
          (lsattr.typtr=shortintptr) or (lsattr.typtr=byteptr) or
          (lsattr.typtr=wordptr) then begin
	  lsAttr.typtr:=longintptr;
       end;

       if comptypes(lattr.typtr,lsAttr.typtr) then begin
       end else
           wrerror(27);

       {Bledne operatory}
       case lattr.typtr^.form of
            pointer: if lop in [ltop,leop,gtop,geop] then
                        wrerror(131);
            power:   if lop in [ltop,gtop] then
                        wrerror(132);
	    arrays:  if not isstring(lattr.typtr) then
                        wrerror(134);
            records: wrerror(134);
	    files:   wrerror(133);
       end;


       writeln(output,'xor cx,cx');

       if lsAttr.typ<>strt then begin
          writeln(output,'cmp ax,bx');
       end else begin
       end;

       case lop of
            eqop: createjmp('jne','',lsLabel+1);
       end;
       writeln(output,'mov cx,0001h');
       createlabel('',putlabel);
       writeln(output,'mov ax,cx');

       lsAttr.typtr := boolptr; lsAttr.kind := expr;
    end;
    lsOp:=lop;
end;

procedure call(fcp:ctp);

  procedure calldiff;
    begin
  end;

  begin
    if fcp^.pfdeckind = standard then begin
       if fcp^.klass = proc then begin
          case fcp^.key of
               1,2,3,4:  ; {getputresetrewrite;}
	       5:        ; {read(fcp^.key);}
	       6:        ; {write(fcp^.key);}
	       7:        ; {pack;}
	       8:        ; {unpack;}
	       9:        ; {new;}
	       10:       ; {release;}
               11:       ; {read(fcp^.key);}
               12:       ; {write(fcp^.key);}
          end;
       end else begin
          case fcp^.key of
               1:    ; {abs;}
	       2:    ; {sqr;}
	       3:    ; {trunc;}
	       4:    ; {odd;}
	       5:    ; {ord;}
	       6:    ; {chr;}
	       7,8:  ; {predsucc(fcp^.key);}
	       9,10: ; {eofeoln(fcp^.key);}
	  end;
       end;
    end else
       calldiff;
end;

procedure consttype(var fsp: stp; var fvalu: valu);
  var
     lkp:ctp; lsp:stp; sign:char; lvp:csp;
  begin
                        if not (lsSym in [ident,stringconst,realconst,intconst,addop]) then
                           wrerror(106);
                        if lsSym=stringconst then begin
                           if ord(lsVal.valp^.sval[0])=1 then
                              lsp:=charptr
                           else begin
                              new(lsp);
                              lsp:=strptr;
                           end;
                           fvalu:=lsVal;
                           getsymbol;
                        end else begin
                            sign:=' ';
                            if lsSym=addop then begin
                               if lsOp=plus then begin
                                  sign:='+'
                               end else begin
                                  sign:='-';
                               end;
                               getsymbol;
                            end;
                            case lsSym of
                                 ident: begin
                                          searchid([konst],lkp);
                                          lsp:=lkp^.idtype;
                                          fvalu:=lkp^.values;
                                          if not ((sign=' ') or (sign='+')) then begin
                                             if lsp=intptr then
                                                fvalu.ival:=-fvalu.ival
                                             else
                                                if lsp=realptr then begin
                                                   new(lvp);
                                                   if fvalu.valp^.rval[1]='-' then
                                                      lvp^.rval[1]:='+'
                                                   else
                                                      lvp^.rval[1]:='-';
                                                   for i:=2 to ord(fvalu.valp^.rval[0]) do
                                                       lvp^.rval[i]:=fvalu.valp^.rval[i];
                                                   fvalu.valp:=lvp;
                                                end else
                                                   wrerror(87);
                                          end;
                                          getsymbol;
                                        end;
                                 intconst: begin
                                             if sign='-' then
                                                lsVal.ival:=-lsVal.ival;
                                             lsp:=intptr;
                                             fvalu:=lsVal;
                                             getsymbol;
                                           end;
                                 realconst: begin
                                              if sign='-' then
                                                 lsVal.Valp^.rval[1]:='-';
                                              lsp:=realptr;
                                              fvalu:=lsVal;
                                              getsymbol;
                                            end;
                                 else begin
                                        wrerror(202);
                                 end;
                            end;
                        end;
          fsp:=lsp;
end;


procedure gettype(var fsp: stp; var fsize: addrrange);
  var
    lsp,lsp1,lsp2:stp; lcp:ctp; displ,lsize:addrrange; test:boolean;
    lmin,lmax:integer;  oldtop:0..22;

    procedure simpletype(var fsp:stp; var fsize:addrrange);
       var
         ttop:0..22; lsp,lsp1:stp; lcp,lcp1,lcp2:ctp; lcnt:integer; lvalu:valu;
       begin
         fsize:=1;
         case lsSym of
              lparent: begin
                         ttop:=top;
                         while display[top].occur <> blck do
                               top:=top-1;
                         new(lsp);
                         lsp^.size:=intsize;
                         lsp^.form:=scalar;
		         lsp^.scalkind:=declared;
                         lcp1:=nil; lcnt:=0;
                         repeat
                           getsymbol;
                           if lsSym=ident then begin
                              new(lcp);
                              lcp^.name:=lsIdn;   lcp^.idtype:=lsp;
                              lcp^.next:=lcp1;    lcp^.values.ival:=lcnt;
                              lcp^.klass:=konst;
                              enterid(lcp);
                              writeln('Type ',lcp^.name); readkey;
                              lcnt:=lcnt+1;
                              lcp1:=lcp;
                              getsymbol;
                           end else
                               wrerror(24);
                         until (lsSym<>comma) and (lsSym<>ident);
                         if lsSym<>rparent then
                            wrerror(4);
                         lsp^.fconst := lcp1; top := ttop;
                         getsymbol;
                         fsp:=lsp;
                         exit;
                       end;
              ident:   begin
                         searchid([types,konst],lcp);
                         getsymbol;
                         if lcp^.klass=konst then begin
                            new(lsp);
                            lsp^.rangetype:=lcp^.idtype;
                            lsp^.form:=subrange;
                            lsp^.min:=lcp^.values;
                            lsp^.size:=intsize;
			    if isstring(lsp^.rangetype) then
			       wrerror(148);
                            if lsSym<>colon then
                               wrerror(236);
                            getsymbol;
                            consttype(lsp1,lvalu);
                            lsp^.max:=lvalu;
                            if lsp^.rangetype<>lsp1 then
                               wrerror(26); {}


                            writeln(lsp^.min.ival,' az do ',lsp^.max.ival);
                            writeln(lsp^.min.valp^.sval,' ',lsp^.max.valp^.sval); readkey;

                         end else begin
                             lsp:=lcp^.idtype;
                             fsize:=lsp^.size;
                             if lsp=strptr then begin
                                writeln('String'); readkey;
                                if lsSym=lbrack then begin
                                   getsymbol;
                                   if (lsSym<>intconst) and (lsSym<>ident) then
                                      wrerror(54);
                                   if lsSym=ident then begin
                                      searchid([konst],lcp2);
                                      fsize:=lcp2^.values.ival;
                                   end else begin
                                      fsize:=lsVal.ival;
                                   end;
                                   getsymbol;
                                   if lsSym<>rbrack then
                                      wrerror(34);
                                   getsymbol;
                                end;
                             end;

                             writeln('FSize ',fsize);
                             writeln(lsp^.min.ival,' do ',lsp^.max.ival);
                             writeln(lsp^.min.valp^.sval,' ',lsp^.max.valp^.sval);
                             if lsp=intptr then writeln('Typu integer');
                             if lsp=boolptr then writeln('Typu boolean');
                             if lsp=textptr then writeln('Typu text');
                             if lsp=realptr then writeln('Typu real');
                             if lsp=strptr then writeln('Typu string');

                             readkey;



                         end;
                       end;
              else begin
                     new(lsp);
                     lsp^.form:=subrange;
                     consttype(lsp1,lvalu);
         	     if isstring(lsp1) then
			wrerror(148);
                     lsp^.rangetype:=lsp1; lsp^.min:=lvalu; lsp^.size:=intsize;
                     writeln(lsIdn);
		     if lsSym<>colon then
                        wrerror(5);
                     getsymbol;
		     consttype(lsp1,lvalu);
		     lsp^.max:=lvalu;
		     if lsp^.rangetype<>lsp1 then
                        wrerror(26); {}

                     writeln(lsp^.min.ival,' ',lsp^.max.ival);
                     writeln(lsp^.min.valp^.sval,' ',lsp^.max.valp^.sval); readkey;

                   end;
         end;
         if lsp <> nil then begin
	    if lsp^.form=subrange then begin
	       if lsp^.rangetype<>nil then begin
	          if lsp^.rangetype=realptr then
                     wrerror(201)
		  else
		     if (lsp^.min.ival>lsp^.max.ival) or
                        ((lsp^.rangetype=charptr) and (lsp^.min.valp^.sval[1]>lsp^.max.valp^.sval[1])) then
                        wrerror(28); {}
               end;
            end;
         end;
         fsp:=lsp;
    end; {SimpleType}

    procedure fieldlist(var frecvar: stp);
	var lcp,lcp1,nxt,nxt1: ctp; lsp,lsp1,lsp2,lsp3,lsp4: stp;
	    minsize,maxsize,lsize: addrrange; lvalu: valu;
      begin nxt1 := nil; lsp := nil;
	while lsSym = ident do
	  begin nxt := nxt1;
	    repeat
	      if lsSym = ident then
		begin new(lcp);
		  with lcp^ do
		    begin name := lsIdn; idtype := nil; next := nxt;
		      klass := field
		    end;
		  nxt := lcp;
		  enterid(lcp);
		  getsymbol
		end
	      else wrerror(2);
	      if not (lsSym in [comma,colon]) then
		begin wrerror(6);
		end;
	      test := lsSym <> comma;
	      if not test  then getsymbol
	    until test;
	    if lsSym = colon then getsymbol else wrerror(5);
	    gettype(lsp,lsize);
	    while nxt <> nxt1 do
	      with nxt^ do
		begin align(lsp,displ);
		  idtype := lsp; fldaddr := displ;
		  nxt := next; displ := displ + lsize
		end;
	    nxt1 := lcp;
	    while lsSym = semicolon do
	      begin getsymbol;
		if not (lsSym in [ident,casesy,semicolon,endsy]) then
		  begin wrerror(19); end     
	      end
	  end (*while*);
	nxt := nil;
	while nxt1 <> nil do
	  with nxt1^ do
	    begin lcp := next; next := nxt; nxt := nxt1; nxt1 := lcp end;
	if lsSym = casesy then
	  begin new(lsp);
	    with lsp^ do
	      begin tagfieldp := nil; fstvar := nil; form:=tagfld end;
	    frecvar := lsp;
	    getsymbol;
	    if lsSym = ident then
	      begin new(lcp);
		with lcp^ do
		  begin name := lsIdn; idtype := nil; klass:=field;
		    next := nil; fldaddr := displ
		  end;
		enterid(lcp);
		getsymbol;
		if lsSym = colon then getsymbol else wrerror(5);
		if lsSym = ident then
		  begin searchid([types],lcp1);
		    lsp1 := lcp1^.idtype;
		    if lsp1 <> nil then
		      begin align(lsp1,displ);
			lcp^.fldaddr := displ;
			displ := displ+lsp1^.size;
			if (lsp1^.form <= subrange) or isstring(lsp1) then
			  begin if comptypes(realptr,lsp1) then wrerror(109)
			    else if isstring(lsp1) then wrerror(399);
			    lcp^.idtype := lsp1; lsp^.tagfieldp := lcp;
			  end
			else wrerror(110);
		      end;
		    getsymbol;
		  end
		else begin wrerror(2);  end
	      end
	    else begin wrerror(2); end;
	    lsp^.size := displ;
	    if lsSym = ofsy then getsymbol else wrerror(8);
	    lsp1 := nil; minsize := displ; maxsize := displ;
	    repeat lsp2 := nil;
	      if not (lsSym in [semicolon]) then
	      begin
		repeat consttype(lsp3,lvalu);
		  if lsp^.tagfieldp <> nil then
		   if not comptypes(lsp^.tagfieldp^.idtype,lsp3)then wrerror(111);
		  new(lsp3);
		  with lsp3^ do
		    begin nxtvar := lsp1; subvar := lsp2; varval := lvalu;
		      form := variant
		    end;
		  lsp4 := lsp1;
		  while lsp4 <> nil do
		    with lsp4^ do
		      begin
			if varval.ival = lvalu.ival then wrerror(178);
			lsp4 := nxtvar
		      end;
		  lsp1 := lsp3; lsp2 := lsp3;
		  test := lsSym <> comma;
		  if not test then getsymbol
		until test;
		if lsSym = colon then getsymbol else wrerror(5);
		if lsSym = lparent then getsymbol else wrerror(9);
		fieldlist(lsp2);
		if displ > maxsize then maxsize := displ;
		while lsp3 <> nil do
		  begin lsp4 := lsp3^.subvar; lsp3^.subvar := lsp2;
		    lsp3^.size := displ;
		    lsp3 := lsp4
		  end;
		if lsSym = rparent then
		  begin getsymbol;
		    if not (lsSym in [semicolon]) then
		      begin wrerror(6); end
		  end
		else wrerror(4);
	      end;
	      test := lsSym <> semicolon;
	      if not test then
		begin displ := minsize;
		      getsymbol
		end
	    until test;
	    displ := maxsize;
	    lsp^.fstvar := lsp1;
	  end
	else frecvar := nil
      end (*fieldlist*) ;


  begin

    if lsSym in [addop,intconst,realconst,stringconst,ident,lparent] then begin
       simpletype(lsp,fsize);
    end else begin
         if lsSym=arrow then begin
            new(lsp);
            fsp:=lsp;
            lsp^.eltype:=nil;
            lsp^.size:=ptrsize;
            lsp^.form:=pointer;
            getsymbol;
            if lsSym=ident then begin
               error:=false;
               searchid([types],lcp);
               error:=true;
               if lcp=nil then begin
                  new(lcp);
                  lcp^.name:=lsIdn;
                  lcp^.idtype:=lsp;
                  lcp^.next:=fwptr;
                  lcp^.klass:=types;
                  fwptr:=lcp;
               end else begin
                  if lcp^.idtype<>nil then
                     if lcp^.idtype^.form=files then
                        wrerror(108)
                     else
                        lsp^.eltype:=lcp^.idtype;
               end;
               getsymbol;
            end else begin
               wrerror(242);
            end;
         end else begin
             if lsSym=packedsy then begin
                getsymbol;
                if not (lsSym in [arraysy,recordsy,setsy,filesy]) then
                   wrerror(10);
             end;
             if lsSym=arraysy then begin
                getsymbol;
                if lsSym<>lbrack then
                   wrerror(11);
                getsymbol;
                lsp1:=nil;
                repeat
                  new(lsp);
		  lsp^.aeltype:=lsp1;
                  lsp^.inxtype:=nil;
                  lsp^.form:=arrays;
		  lsp1 := lsp;
		  simpletype(lsp2,lsize);
		  lsp1^.size:=lsize;
		  if lsp2<>nil then
		     if lsp2^.form<=subrange then begin
		        if lsp2=realptr then begin
                           wrerror(109);
                           lsp2:=nil;
                        end else
			      if (lsp2=intptr) or (lsp2=shortintptr) or
                                 (lsp2=longintptr) or (lsp2=byteptr) or
                                 (lsp2=wordptr) then begin
                                 wrerror(149);
                                 lsp2:=nil
                              end;
			      lsp^.inxtype:=lsp2
		     end else begin
                         wrerror(113);
                         lsp2:=nil
                     end;
		  test:=lsSym<>comma;
		  if not test then
                     getsymbol
		until test;
                if lsSym<>rbrack then
                   wrerror(93);
                getsymbol;
                if lsSym<>ofsy then
                   wrerror(54); {}
                getsymbol;
                gettype(lsp,lsize);
                repeat
                  with lsp1^ do
		    begin
                      lsp2:=aeltype; aeltype:=lsp;
		      if inxtype <> nil then begin
                         getbounds(inxtype,lmin,lmax);
			 align(lsp,lsize);
			 lsize:=lsize*(lmax-lmin+1);
			 size:=lsize;
		      end;
		  end;
		  lsp := lsp1; lsp1 := lsp2;
		until lsp1 = nil;
             end else begin
                 if lsSym=recordsy then begin
                    getsymbol;
                    oldtop:=top;
                    if top<displev then begin
                       top:=top+1;
                       display[top].fname:=nil;
                       display[top].flabel:=nil;
                       display[top].occur:=rec;
                    end else
                       wrerror(250);
                    displ:=0;

                    fieldlist(lsp1);

                    new(lsp);
                    lsp^.fstfld:=display[top].fname;
                    lsp^.recvar:=lsp1;
                    lsp^.size:=displ;
                    lsp^.form:=records;
                    top:=oldtop;
                    if lsSym<>endsy then
                       wrerror(231);
                    getsymbol;
                 end else begin
                     if lsSym=setsy then begin
                        writeln('Set of ');
                        getsymbol;
                        if lsSym<>ofsy then
                           wrerror(54); {}
                        getsymbol;
                        simpletype(lsp1,lsize);

                           if lsp1^.form>subrange then
                              wrerror(115)
                           else
                              if lsp1=realptr then
                                 wrerror(114)
                              else
                                 if (lsp1=intptr) or (lsp1=shortintptr) or
                                 (lsp1=longintptr) or (lsp1=byteptr) or
                                 (lsp1=wordptr) then
                                    wrerror(169)
                                 else begin
                                     getbounds(lsp1,lmin,lmax);
                                     if (lmin<setlow) or (lmax>sethigh) then
                                        wrerror(169);
                                 end;

                        new(lsp);
                        lsp^.elset:=lsp1;
                        lsp^.size:=setsize;
                        lsp^.form:=power;
                     end else begin
                         if lsSym=filesy then
                            {later}
                     end;
                 end;
             end;
         end;
    end;
    fsp:=lsp;
end;


procedure statement;
  var
    llp:lbp; test,found:boolean;
    lcp:ctp; ttop,ttop1:integer;
  label 2;

  procedure beginstatement;
   begin
     if lsSym=beginsy then begin
        getsymbol;
        repeat
          repeat
            statement;
          until not (lsSym in [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy]);
          test:=lsSym<>semicolon;
          if not test then
             getsymbol
        until test;
        if lsSym<>endsy then
           wrerror(13);
        getsymbol;
     end else
        statement;
  end;


  procedure ifstatement;
    var
      lab:longint;
    begin
      getsymbol;
      writeln(output,'; If - statement');
      lab:=putlabel;
      expression;
      if lsAttr.typtr<>boolptr then
         wrerror(45);
      writeln(output,'cmp al,1');
      createjmp('jne','ifelse',lab);

      if lsSym<>thensy then
         wrerror(57);
      getsymbol;
      beginstatement;

      if (lsSym<>semicolon) and (lsSym<>elsesy) then
         wrerror(85);

      createjmp('jmp','ifend',lab);
      createlabel('ifelse',lab);

      if lsSym=elsesy then begin
         getsymbol;
         beginstatement;
      end;
      createlabel('ifend',lab);
  end;

  procedure labelstatement;
    label 1;
    begin
      writeln('Label ',lsVal.ival);
      writeln(output,'lb',lsVal.ival,':');

      llp:=display[level].flabel;
      while llp<>nil do
        begin
          if llp^.labval=lsVal.ival then
             goto 1;
          llp:=llp^.next;
      end;
      wrerror(3);{}
      1:
      getsymbol;
      if lsSym<>colon then
         wrerror(86);
      getsymbol;

      if llp^.already=true then
         wrerror(81);{}
      llp^.already:=true;
      llp^.defined:=false;
  end;

  procedure gotostatement;
    begin
      getsymbol;
      if lsSym<>intConst then
         wrerror(3);{}

      writeln('Jump to ',lsVal.ival);
      writeln(output,'jmp lb',lsVal.ival);

      ttop:=top;
      while display[ttop].occur <> blck do ttop := ttop - 1;
      ttop1:=ttop;
      found:=false;
      repeat
        llp:=display[ttop].flabel;
	while (llp <> nil) and not found do
        if llp^.labval=lsVal.ival then begin
           found:=true;
	   if ttop=ttop1 then
              {Costam}
           else
              wrerror(399)
	end else
           llp:=llp^.next;
	   ttop:=ttop-1;
      until found or (ttop=0);

      if not llp^.already then
         llp^.defined:=true;

      if not found then
         wrerror(3);

      getsymbol;
  end;


  begin
    2:
    case lsSym of
         intconst: begin labelstatement; goto 2; end;
         ident:    begin
                     searchid([vars,field,func,proc],lcp);
                     getsymbol;

		     if lcp^.klass=proc then
                        call(lcp)
                     else
                        {assignment(lcp);}
                   end;
         beginsy:  wrerror(43);
         gotosy:   gotostatement;
         ifsy:     ifstatement;
         casesy:   ;
         whilesy:  ;
         repeatsy: ;
         forsy:    ;
         withsy:   ;

         else begin
              if not (lsSym in [endsy]) then
                 wrerror(113);
         end;
    end;
    if (lsSym<>endsy) and (lsSym<>semicolon) and (lsSym<>elsesy) then
        wrerror(85);

end;


procedure bodyblock;
  var
    entname:integer;
  label 1;

  procedure constblock;
    var
      lcp,lkp:ctp; lsp:stp; lvalu:valu;
      sign:char;
    begin
      if lsSym<>ident then
         wrerror(2);{}
      while (lsSym=ident)  do
        begin
          new(lcp);
          lcp^.name:=lsIdn; lcp^.klass:=konst; lcp^.idtype:=nil; lcp^.next:=nil;
          getsymbol;
          if not (((lsSym=relop) and (lsOp=eqop)) or (lsSym=colon)) then
             wrerror(16);
          getsymbol;
          consttype(lsp,lvalu);
          enterid(lcp);
	  lcp^.idtype := lsp; lcp^.values := lvalu;

          testsemicolon;
          getsymbol;

          write(output,progname,'_',level,'c_',lcp^.name,' equ ');
          if (lcp^.idtype=charptr) or (isstring(lcp^.idtype)) then begin
             write(output,ord(lcp^.values.valp^.sval[0]),',''');
             for i:=1 to ord(lcp^.values.valp^.sval[0]) do
                 write(output,lcp^.values.valp^.sval[i]);
             write(output,'''');
          end else begin
             write(output,lcp^.values.ival);
          end;
          writeln(output);


      end;

  end;

  procedure typeblock;
    var
      lcp,lcp1,lcp2:ctp; lsp:stp; lsize:addrrange;
    begin
      writeln('Type !!!!!!!!!!');

      if lsSym<>ident then
         wrerror(2);{}

      while lsSym=ident do
        begin
          new(lcp);
          lcp^.name:=lsIdn;
          lcp^.idtype:=nil; {po co ?}
          lcp^.klass:=types;

          getsymbol;

          if not ((lsSym=relop) and (lsOp=eqop)) then
             wrerror(16);

          getsymbol;

          gettype(lsp,lsize);
          enterid(lcp);
          lcp^.idtype:=lsp;

          if lsp^.form=scalar then begin writeln('Typu scalarnego'); readkey; end;

          {Do testowania sforwardowanych}
          lcp1:=fwptr;
          while lcp1 <> nil do
	    begin
	      if lcp1^.name = lcp^.name then
		begin lcp1^.idtype^.eltype := lcp^.idtype;
		  if lcp1 <> fwptr then
		    lcp2^.next := lcp1^.next
		  else fwptr := lcp1^.next;
		end
	      else lcp2 := lcp1;
	      lcp1 := lcp1^.next
	  end;

          testsemicolon;
          getsymbol;

      end;


      if fwptr<>nil then
         wrerror(19);{}

  end;

  procedure varblock;
    var
      lcp,nxt:ctp; test:boolean;
      lsp:stp; lc,lsize:addrrange;
    begin
      nxt:=nil;
      while lsSym=ident do
        begin
          repeat
            if lsSym<>ident then
               wrerror(234);

            new(lcp);
            lcp^.name:=lsIdn;            lcp^.idtype:=nil;
            lcp^.next:=nxt;              lcp^.klass:=vars;
            lcp^.vkind:=actual;          lcp^.vlev:=level;
            enterid(lcp);
            nxt:=lcp;


            getsymbol;
            test:=lsSym<>comma;
            if not test then
               getsymbol;
          until test;

          if lsSym<>colon then
             wrerror(32);

          getsymbol;
          gettype(lsp,lsize);

          while nxt<>nil do    {Dopisanie dla kazdego}
            begin
              align(lsp,lc);
              nxt^.idtype:=lsp;
              nxt^.vaddr:=lc;
              lc:=lc+lsize;

              if lcp^.idtype=strptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' db ',lsize,' dup (?)'); {char}
              if lcp^.idtype=intptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' dw ?');  {sword}
              if lcp^.idtype=realptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' dw ?');  {real}
              if lcp^.idtype=boolptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' db ?');
              if lcp^.idtype=charptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' db ?');
              if lcp^.idtype=nilptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' dw 0');
              if lcp^.idtype=wordptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' dw ?');  {word}
              if lcp^.idtype=longintptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' dd ?');  {sdword}
              if lcp^.idtype=shortintptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' db ?');  {sbyte}
              if lcp^.idtype=byteptr then
                 writeln(output,progname,'_',level,'v_',nxt^.name,' db ?');  {byte}
              nxt:=nxt^.next;
          end;



          testsemicolon;
          getsymbol;
      end;
      if fwptr<>nil then
         wrerror(19);{}

  end;

  procedure labelblock;
    var
       llp:lbp;
    begin
      repeat
        if not (lsSym in [intconst]) then
           wrerror(132);{}

        searchlbl;
        new(llp);
        llp^.labval:=lsVal.ival;
	llp^.defined:=false;
        llp^.already:=false;
        llp^.next:=display[top].flabel;
        llp^.labname:=lsVal.ival; {Tymczasowo}
	display[top].flabel:=llp;

        getsymbol;
        if lsSym=comma then
           getsymbol;
      until (lsSym=semicolon);
      testsemicolon;
      getsymbol;
  end;

  procedure procblock(what:stType);
    begin
  end;

  procedure mainblock(from:ctp);
    var
      test:boolean; llp:lbp;
    begin
      writeln('Main block');


      if from<>nil then
         entname:=from^.pfname
      else
         writeln(output,'start:');
      {Inne}

      repeat
	repeat
          statement;
	until not (lsSym in [beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,withsy,casesy]);
	test := lsSym<>semicolon;
	if not test then
           getsymbol
      until test;
      if lsSym<>endsy then
         wrerror(13);

      llp:=display[top].flabel;
      while llp<>nil do
        begin
          if llp^.defined=true then begin
             lsVal.ival:=llp^.labval;
             wrerror(82);
          end;
          llp:=llp^.next;
      end;

      {Inne}


  end;

  begin{bodyblock}
    repeat
      1:
      case lsSym of
        constsy: begin{}
                   getsymbol;
                   constblock; goto 1;
                 end;
        typesy:  begin{}
                   getsymbol;
                   typeblock;  goto 1;
                 end;
        varsy:   begin{}
                   getsymbol;
                   varblock;   goto 1;
                 end;
        labelsy: begin{}
                   getsymbol;
                   labelblock; goto 1;
                 end;
        procsy,funcsy:  begin
                          getsymbol;
                          procblock(lsSym); goto 1;
                        end;
        beginsy:
        else wrerror(36);
      end;
    until lsSym=beginsy;

    repeat
      getsymbol;
      mainblock(nil);
      if lsSym=endsy then begin
         ends:=true;
         while ch=' ' do getsymbol;
         if ch<>'.' then begin
            wrerror(32);
         end;
         lsSym:=Dot;

         writeln(output,'jmp exit');
         writeln(output,'exit:');
         writeln(output,'  mov ax,4c00h');
         writeln(output,'  int 21h');
         writeln(output,'ret');
         writeln(output,'end program');

      end;
    until lsSym=Dot;
end;{BodyBlock}

procedure progblock;
  var
    extfp:extfilep;
  begin{ProgBlock}
    writeln(output,'; Created by OSPascal ''2002');
    writeln(output,'; Authors: Pawel Suliga');
    progname:='main';
    if lsSym=progsy then begin
       getsymbol;
       testident;
       writeln(output,'; Program - ',lsIdn);
       progname:=lsIdn;
       writeln;
       getsymbol;

       writeln(output,'.model tiny'); writeln(output,'.code'); writeln(output,'org 100h');

       writeln(output,'program: jmp start');

       if not (lsSym in [semicolon,lparent]) then
          wrerror(85);{}
       if lsSym=lparent then begin
          repeat
            getsymbol;

            if lsSym<>ident then
               wrerror(43);
            new(extfp);
	    extfp^.filename:=lsIdn;
            extfp^.nextfile:=fextfilep;
	    fextfilep:=extfp;

            getsymbol;
            if (lsSym<>comma) and (lsSym<>rparent) then
               wrerror(89);
          until lsSym=rparent;
          getsymbol;
          if lsSym<>semicolon then
             wrerror(85);{}
          getsymbol;
       end;
    end;

end;{ProgBlock}


procedure wrerror(num:word);
  begin
    writeln;
    writeln('*****');
    case num of
       3,4:     writeln('Error : ',num,'->',err[num],' (',lsIdn,') Line : ',lncount+1,' Char : ',chcount+1);
       19:    writeln('Error : ',num,'->',err[num],' (',fwptr^.name,') Line : ',lncount+1,' Char : ',chcount+1);
       82:    writeln('Error : ',num,'->',err[num],' (',lsVal.ival,') Line : ',lncount+1,' Char : ',chcount+1)
       else begin
              writeln('Error : ',num,'->',err[num],' Line : ',lncount+1,' Char : ',chcount+1,' ',ch)
       end;
    end;

    readkey;
    donefile;
    halt;
end;{WrError}

procedure initvar;
  begin
    lncount:=0;
end;

procedure initarrays;
   var
     cp,cp1:ctp;
   begin
      for i:=0 to 31 do
          ctArray[chr(i)] := ctIllegal;
      for ch:='a' to 'z' do
          ctArray[ch]:=ctLetter;
      for ch:='A' to 'Z' do
          ctArray[ch]:=ctLetter;
      for ch:='0' to '9' do
          ctArray[ch]:=ctNumber;

      ctArray['+']:=ctSpcl;
      ctArray['-']:=ctSpcl;    ctArray['*'] := ctSpcl;
      ctArray['/']:=ctSpcl;    ctArray['('] := ctBrack;
      ctArray[')']:=ctSpcl;    ctArray['$'] := ctSpcl;
      ctArray['=']:=ctSpcl;    ctArray[' '] := ctSpace;
      ctArray[',']:=ctSpcl;    ctArray['.'] := ctDot;
      ctArray['''']:=ctApostr; ctArray['['] := ctSpcl;
      ctArray[']']:=ctSpcl;    ctArray[':'] := ctCol;
      ctArray['^']:=ctSpcl;    ctArray[';'] := ctSpcl;
      ctArray['<']:=ctLs;      ctArray['>'] := ctGt;
      ctArray['{']:=ctClam;    ctArray['@'] := ctSpcl;


      {Reserved word}
      rwArray[ 1] := 'if';       rwArray[ 2] := 'do';        rwArray[ 3] := 'of';
      rwArray[ 4] := 'to';       rwArray[ 5] := 'in';        rwArray[ 6] := 'or';
      rwArray[ 7] := 'end';      rwArray[ 8] := 'for';       rwArray[ 9] := 'var';
      rwArray[10] := 'div';      rwArray[11] := 'mod';       rwArray[12] := 'set';
      rwArray[13] := 'and';      rwArray[14] := 'not';       rwArray[15] := 'then';
      rwArray[16] := 'else';     rwArray[17] := 'with';      rwArray[18] := 'goto';
      rwArray[19] := 'case';     rwArray[20] := 'type';      rwArray[21] := 'file';
      rwArray[22] := 'begin';    rwArray[23] := 'until';     rwArray[24] := 'while';
      rwArray[25] := 'array';    rwArray[26] := 'const';     rwArray[27] := 'label';
      rwArray[28] := 'repeat';   rwArray[29] := 'record';    rwArray[30] := 'downto';
      rwArray[31] := 'packed';   rwArray[32] := 'forward';   rwArray[33] := 'program';
      rwArray[34] := 'function'; rwArray[35] := 'procedure'; rwArray[36] := 'shl';
      rwArray[37] := 'shr';      rwArray[38] := 'xor';

      {Reserved word -> symbol}
      rsy[ 1] := ifsy;      rsy[ 2] := dosy;      rsy[ 3] := ofsy;
      rsy[ 4] := tosy;      rsy[ 5] := relop;     rsy[ 6] := addop;
      rsy[ 7] := endsy;     rsy[ 8] := forsy;     rsy[ 9] := varsy;
      rsy[10] := mulop;     rsy[11] := mulop;     rsy[12] := setsy;
      rsy[13] := mulop;     rsy[14] := notsy;     rsy[15] := thensy;
      rsy[16] := elsesy;    rsy[17] := withsy;    rsy[18] := gotosy;
      rsy[19] := casesy;    rsy[20] := typesy;    rsy[21] := filesy;
      rsy[22] := beginsy;   rsy[23] := untilsy;   rsy[24] := whilesy;
      rsy[25] := arraysy;   rsy[26] := constsy;   rsy[27] := labelsy;
      rsy[28] := repeatsy;  rsy[29] := recordsy;  rsy[30] := downtosy;
      rsy[31] := packedsy;  rsy[32] := forwardsy; rsy[33] := progsy;
      rsy[34] := funcsy;    rsy[35] := procsy;    rsy[36] := mulop;
      rsy[37] := mulop;     rsy[38] := addop;
      ssy['+'] := addop ;   ssy['-'] := addop;    ssy['*'] := mulop;
      ssy['/'] := mulop ;   ssy['('] := lparent;  ssy[')'] := rparent;
      ssy['$'] := othersy ; ssy['='] := relop;    ssy[' '] := othersy;
      ssy[','] := comma ;   ssy['.'] := dot;      ssy['''']:= othersy;
      ssy['['] := lbrack ;  ssy[']'] := rbrack;   ssy[':'] := colon;
      ssy['^'] := arrow ;   ssy['<'] := relop;    ssy['>'] := relop;
      ssy[';'] := semicolon; ssy['{'] :=lclam;    ssy['}'] := rclam;
      ssy['@'] := atop;

      na[ 1] := 'false';   na[ 2] := 'true';     na[ 3] := 'input';
      na[ 4] := 'output';  na[ 5] := 'get';      na[ 6] := 'put';
      na[ 7] := 'reset';   na[ 8] := 'rewrite';  na[ 9] := 'read';
      na[10] := 'write';   na[11] := 'pack';     na[12] := 'unpack';
      na[13] := 'new';     na[14] := 'release';  na[15] := 'readln';
      na[16] := 'writeln'; na[17] := 'abs';      na[18] := 'sqr';
      na[19] := 'trunc';   na[20] := 'odd';      na[21] := 'ord';
      na[22] := 'chr';     na[23] := 'pred';     na[24] := 'succ';
      na[25] := 'eof';     na[26] := 'eoln';     na[27] := 'sin';
      na[28] := 'cos';     na[29] := 'exp';      na[30] := 'sqrt';
      na[31] := 'ln';      na[32] := 'arctan';   na[33] := 'prd';
      na[34] := 'prr';



      {Operators}
      for i := 1 to nrRw do rop[i] := noop;
      rop[5] := inop;  rop[10] := idiv;  rop[11] := imod;
      rop[6] := orop;  rop[13] := andop; rop[36] := shlop;
      rop[37]:= shrop; rop[38] := xorop;
      sop['+'] := plus; sop['-'] := minus; sop['*'] := mul; sop['/'] := rdiv;
      sop['='] := eqop; sop['<'] := ltop;  sop['>'] := gtop;

      {Errors}
      err[10]:='Unexpected end of file!';
      err[2]:='Identifier expected'; {}
      err[3]:='Unknown identifier.'; {}
      err[4]:='Duplicate identifier'; {}
      err[19]:='Undefined type in pointer definition';
      err[26]:='Type mismatch.'; {}
      err[28]:='Lower bound greater than upper bound.';
      err[36]:='BEGIN expected';
      err[41]:='Operand types do not match operator';{}
      err[54]:='OF expected';
      err[57]:='THEN expected';
      err[81]:='Label already defined';{}
      err[82]:='Undefined label in preceding statement part';{}
      err[85]:='";" expected';
      err[89]:='")" expected';
      err[113]:='Error in statament';

   {Pointers}
    new(intptr);			      (*integer*)
    with intptr^ do
      begin size := intsize; form := scalar; scalkind := standard end;
    new(realptr);			     (*real*)
    with realptr^ do
      begin size := realsize; form := scalar; scalkind := standard end;
    new(charptr);			     (*char*)
    with charptr^ do
      begin size := charsize; form := scalar; scalkind := standard end;
    new(boolptr);			     (*boolean*)
    with boolptr^ do
      begin size := boolsize; form := scalar; scalkind := declared end;
    new(nilptr);				      (*nil*)
    with nilptr^ do
      begin eltype := nil; size := ptrsize; form := pointer end;
    new(parmptr); (*for alignment of parameters*)
    with parmptr^ do
      begin size := parmsize; form := scalar; scalkind := standard end ;
    new(textptr);				       (*text*)
    with textptr^ do
      begin filtype := charptr; size := charsize; form := files end;
    new(strptr);				       (*text*)
    with strptr^ do
      begin aeltype := charptr; size := strsize; form := arrays; inxtype:=nil; end;
    new(wordptr);
    with wordptr^ do
      begin
        size:=intsize; form:=scalar; scalkind:=standard;
    end;
    new(shortintptr);
    with shortintptr^ do
      begin
        size:=charsize; form:=scalar; scalkind:=standard;
    end;
    new(longintptr);
    with longintptr^ do
      begin
        size:=2*intsize; form:=scalar; scalkind:=standard;
    end;
    new(byteptr);
    with byteptr^ do
      begin
        size:=charsize; form:=scalar; scalkind:=standard;
    end;


  {Misc}
    new(cp);					    (*integer*)
    with cp^ do
      begin name := 'integer'; idtype := intptr; klass := types end;
    enterid(cp);
    new(cp);					    (*real*)
    with cp^ do
      begin name := 'real'; idtype := realptr; klass := types end;
    enterid(cp);
    new(cp);					    (*char*)
    with cp^ do
      begin name := 'char'; idtype := charptr; klass := types end;
    enterid(cp);
    new(cp);					    (*boolean*)
    with cp^ do
      begin name := 'boolean'; idtype := boolptr; klass := types end;
    enterid(cp);
    new(cp);					    (*string*)
    with cp^ do
      begin name := 'string'; idtype := strptr; klass := types end;
    enterid(cp);
    new(cp);					    {word}
    with cp^ do
      begin name := 'word'; idtype := wordptr; klass := types end;
    enterid(cp);
    new(cp);					    {shortint}
    with cp^ do
      begin name := 'shortint'; idtype := shortintptr; klass := types end;
    enterid(cp);
    new(cp);					    {longint}
    with cp^ do
      begin name := 'longint'; idtype := longintptr; klass := types end;
    enterid(cp);
    new(cp);					    {shortint}
    with cp^ do
      begin name := 'byte'; idtype := byteptr; klass := types end;
    enterid(cp);

    cp1 := nil;
    for i := 1 to 2 do
      begin new(cp);				    (*false,true*)
	with cp^ do
	  begin name := na[i]; idtype := boolptr;
	    next := cp1; values.ival := i - 1; klass := konst
	  end;
	enterid(cp); cp1 := cp
      end;
    boolptr^.fconst := cp;
    new(cp);					    (*nil*)
    with cp^ do
      begin name := 'nil'; idtype := nilptr;
	next := nil; values.ival := 0; klass := konst
      end;
    enterid(cp);

    {Standart procedures}
    for i:=1 to 12 do begin
        new(cp);
	with cp^ do begin
            name:=na[i+4]; idtype:=nil;
	    next:=nil; key:=i;
	    klass:=proc; pfdeckind:=standard;
	end;
	enterid(cp);
    end;

    {Standart function}
    for i := 1 to 10 do begin
        new(cp);
	with cp^ do begin
             name:=na[i+16]; idtype:=nil;
	     next:=nil; key:=i;
	     klass:=func; pfdeckind:=standard;
	end;
	enterid(cp)
    end;

    new(cp);
    with cp^ do begin
         name:=''; idtype:=realptr; klass:=vars;
	 vkind:=actual; next:=nil; vlev:=1; vaddr:=0;
    end;

    for i:= 27 to 32 do
      begin new(cp1);		    (*sin,cos,exp*)
	with cp1^ do					  (*sqrt,ln,arctan*)
	  begin name := na[i]; idtype := realptr; next := cp;
	    forwdecl := false; extern := true; pflev := 0; pfname := i - 12;
	    klass := func; pfdeckind := declared; pfkind := actual
	  end;
	enterid(cp1)
      end


end;{InitArrays}

procedure initfile;
  begin
    assign(input,temp);
    reset(input);
    assign(output,temp2);
    rewrite(output);
    assign(output2,temp3);
    rewrite(output2);
end;{InitFile}

procedure donefile;
  begin
    close(input);
    close(output);
    close(output2);
end;{DoneFile}


begin

clrscr; {<-temporary}

level:=0; top:=0; lsLabel:=0;

{Init}
initfile;
initvar;
initarrays;
ends:=false;
ch:=' ';
error:=true;


level:=1; top:=1;

{Go!}
getsymbol;
progblock;

repeat
  bodyblock;
until lsSym=Dot;

{Done}
donefile;


readkey;
end.{Program}
