automat.pas

This is Pascal compiler

   549    end (*insymbol*) ;
   550  
   551    procedure enterid(fcp: ctp);
   552      (*enter id pointed at by fcp into the name-table,
   553       which on each declaration level is organised as
   554       an unbalanced binary tree*)
   555      var nam: alpha; lcp, lcp1: ctp; lleft: boolean;
   556    begin nam := fcp^.name;
   557      lcp := display[top].fname;
   558      if lcp = nil then
   559        display[top].fname := fcp
   560      else
   561        begin
   562          repeat lcp1 := lcp;
   563            if lcp^.name = nam then   (*name conflict, follow right link*)
   564              begin error(101); lcp := lcp^.rlink; lleft := false end
   565            else
   566              if lcp^.name < nam then
   567                begin lcp := lcp^.rlink; lleft := false end
   568              else begin lcp := lcp^.llink; lleft := true end
   569          until lcp = nil;
   570          if lleft then lcp1^.llink := fcp else lcp1^.rlink := fcp
   571        end;
   572      fcp^.llink := nil; fcp^.rlink := nil
   573    end (*enterid*) ;
   574  
   575    procedure searchsection(fcp: ctp; var fcp1: ctp);
   576      (*to find record fields and forward declared procedure id's
   577       --> procedure proceduredeclaration
   578       --> procedure selector*)
   579       label 1;
   580    begin
   581      while fcp <> nil do
   582        if fcp^.name = id then goto 1
   583        else if fcp^.name < id then fcp := fcp^.rlink
   584          else fcp := fcp^.llink;
   585  1:  fcp1 := fcp
   586    end (*searchsection*) ;
   587  
   588    procedure searchid(fidcls: setofids; var fcp: ctp);
   589      label 1;
   590      var lcp: ctp;
   591    begin
   592      for disx := top downto 0 do
   593        begin lcp := display[disx].fname;
   594          while lcp <> nil do
   595            if lcp^.name = id then
   596              if lcp^.klass in fidcls then goto 1
   597              else
   598                begin if prterr then error(103);
   599                  lcp := lcp^.rlink
   600                end
   601            else
   602              if lcp^.name < id then
   603                lcp := lcp^.rlink
   604              else lcp := lcp^.llink
   605        end;
   606      (*search not successful; suppress error message in case
   607       of forward referenced type id in pointer type definition
   608       --> procedure simpletype*)
   609      if prterr then
   610        begin error(104);
   611          (*to avoid returning nil, reference an entry
   612           for an undeclared id of appropriate class
   613           --> procedure enterundecl*)
   614          if types in fidcls then lcp := utypptr
   615          else
   616            if vars in fidcls then lcp := uvarptr
   617            else
   618              if field in fidcls then lcp := ufldptr
   619              else
   620                if konst in fidcls then lcp := ucstptr
   621                else
   622                  if proc in fidcls then lcp := uprcptr
   623                  else lcp := ufctptr;
   624        end;
   625  1:  fcp := lcp
   626    end (*searchid*) ;
   627  
   628    procedure getbounds(fsp: stp; var fmin,fmax: integer);
   629      (*get internal bounds of subrange or scalar type*)
   630      (*assume fsp<>intptr and fsp<>realptr*)
   631    begin
   632      fmin := 0; fmax := 0;
   633      if fsp <> nil then
   634      with fsp^ do
   635        if form = subrange then
   636          begin fmin := min.ival; fmax := max.ival end
   637        else
   638            if fsp = charptr then
   639              begin fmin := ordminchar; fmax := ordmaxchar
   640              end
   641            else
   642              if fconst <> nil then
   643                fmax := fconst^.values.ival
   644    end (*getbounds*) ;
   645  
   646    function alignquot(fsp: stp): integer;
   647    begin
   648      alignquot := 1;
   649      if fsp <> nil then
   650        with fsp^ do
   651          case form of
   652            scalar:   if fsp=intptr then alignquot := intal
   653                      else if fsp=boolptr then alignquot := boolal
   654                      else if scalkind=declared then alignquot := intal
   655                      else if fsp=charptr then alignquot := charal
   656                      else if fsp=realptr then alignquot := realal
   657                      else (*parmptr*) alignquot := parmal;
   658            subrange: alignquot := alignquot(rangetype);
   659            pointer:  alignquot := adral;
   660            power:    alignquot := setal;
   661            files:    alignquot := fileal;
   662            arrays:   alignquot := alignquot(aeltype);
   663            records:  alignquot := recal;
   664            variant,tagfld: error(501)
   665          end
   666    end (*alignquot*);
   667  
   668    procedure align(fsp: stp; var flc: addrrange);
   669      var k,l: integer;
   670    begin
   671      k := alignquot(fsp);
   672      l := flc-1;
   673      flc := l + k  -  (k+l) mod k
   674    end (*align*);
   675  
   676    procedure printtables(fb: boolean);
   677      (*print data structure and name table*)
   678      var i, lim: disprange;
   679  
   680      procedure marker;
   681        (*mark data structure entries to avoid multiple printout*)
   682        var i: integer;
   683  
   684        procedure markctp(fp: ctp); forward;
   685  
   686        procedure markstp(fp: stp);
   687          (*mark data structures, prevent cycles*)
   688        begin
   689          if fp <> nil then
   690            with fp^ do
   691              begin marked := true;
   692                case form of
   693                scalar:   ;
   694                subrange: markstp(rangetype);
   695                pointer:  (*don't mark eltype: cycle possible; will be marked
   696                          anyway, if fp = true*) ;
   697                power:    markstp(elset) ;
   698                arrays:   begin markstp(aeltype); markstp(inxtype) end;
   699                records:  begin markctp(fstfld); markstp(recvar) end;
   700                files:    markstp(filtype);
   701                tagfld:   markstp(fstvar);
   702                variant:  begin markstp(nxtvar); markstp(subvar) end
   703                end (*case*)
   704              end (*with*)
   705        end (*markstp*);
   706  
   707        procedure markctp;
   708        begin
   709          if fp <> nil then
   710            with fp^ do
   711              begin markctp(llink); markctp(rlink);
   712                markstp(idtype)
   713              end
   714        end (*markctp*);
   715  
   716      begin (*marker*)
   717        for i := top downto lim do
   718          markctp(display[i].fname)
   719      end (*marker*);
   720  
   721      procedure followctp(fp: ctp); forward;
   722  
   723      procedure followstp(fp: stp);
   724      begin
   725        if fp <> nil then
   726          with fp^ do
   727            if marked then
   728              begin marked := false; write(output,' ':4,ord(fp):6,size:10);
   729                case form of
   730                scalar:   begin write(output,'scalar':10);
   731                            if scalkind = standard then
   732                              write(output,'standard':10)
   733                            else write(output,'declared':10,' ':4,ord(fconst):6);
   734                            writeln(output)
   735                          end;
   736                subrange: begin
   737                            write(output,'subrange':10,' ':4,ord(rangetype):6);
   738                            if rangetype <> realptr then
   739                              write(output,min.ival,max.ival)
   740                            else
   741                              if (min.valp <> nil) and (max.valp <> nil) then
   742                                write(output,' ',min.valp^.rval:9,
   743                                      ' ',max.valp^.rval:9);
   744                            writeln(output); followstp(rangetype);
   745                          end;
   746                pointer:  writeln(output,'pointer':10,' ':4,ord(eltype):6);
   747                power:    begin writeln(output,'set':10,' ':4,ord(elset):6);
   748                            followstp(elset)
   749                          end;
   750                arrays:   begin
   751                            writeln(output,'array':10,' ':4,ord(aeltype):6,' ':4,
   752                              ord(inxtype):6);
   753                            followstp(aeltype); followstp(inxtype)
   754                          end;
   755                records:  begin
   756                            writeln(output,'record':10,' ':4,ord(fstfld):6,' ':4,
   757                              ord(recvar):6); followctp(fstfld);
   758                            followstp(recvar)
   759                          end;
   760                files:    begin write(output,'file':10,' ':4,ord(filtype):6);
   761                            followstp(filtype)
   762                          end;
   763                tagfld:   begin writeln(output,'tagfld':10,' ':4,ord(tagfieldp):6,
   764                              ' ':4,ord(fstvar):6);
   765                            followstp(fstvar)
   766                          end;
   767                variant:  begin writeln(output,'variant':10,' ':4,ord(nxtvar):6,
   768                              ' ':4,ord(subvar):6,varval.ival);
   769                            followstp(nxtvar); followstp(subvar)
   770                          end
   771                end (*case*)
   772              end (*if marked*)
   773      end (*followstp*);
   774  
   775      procedure followctp;
   776        var i: integer;
   777      begin
   778        if fp <> nil then
   779          with fp^ do
   780            begin write(output,' ':4,ord(fp):6,' ',name:9,' ':4,ord(llink):6,
   781              ' ':4,ord(rlink):6,' ':4,ord(idtype):6);
   782              case klass of
   783                types: write(output,'type':10);
   784                konst: begin write(output,'constant':10,' ':4,ord(next):6);
   785                         if idtype <> nil then
   786                           if idtype = realptr then
   787                             begin
   788                               if values.valp <> nil then
   789                                 write(output,' ',values.valp^.rval:9)
   790                             end
   791                           else
   792                             if idtype^.form = arrays then  (*stringconst*)
   793                               begin
   794                                 if values.valp <> nil then
   795                                   begin write(output,' ');
   796                                     with values.valp^ do
   797                                       for i := 1 to slgth do
   798                                         write(output,sval[i])
   799                                   end
   800                               end
   801                             else write(output,values.ival)
   802                       end;
   803                vars:  begin write(output,'variable':10);
   804                         if vkind = actual then write(output,'actual':10)
   805                         else write(output,'formal':10);
   806                         write(output,' ':4,ord(next):6,vlev,' ':4,vaddr:6 );
   807                       end;
   808                field: write(output,'field':10,' ':4,ord(next):6,' ':4,fldaddr:6);
   809                proc,
   810                func:  begin
   811                         if klass = proc then write(output,'procedure':10)
   812                         else write(output,'function':10);
   813                         if pfdeckind = standard then
   814                           write(output,'standard':10, key:10)
   815                         else
   816                           begin write(output,'declared':10,' ':4,ord(next):6);
   817                             write(output,pflev,' ':4,pfname:6);
   818                             if pfkind = actual then
   819                               begin write(output,'actual':10);
   820                                 if forwdecl then write(output,'forward':10)
   821                                 else write(output,'notforward':10);
   822                                 if externl then write(output,'extern':10)