automat.pas

This is Pascal compiler

   823                                 else write(output,'not extern':10);
   824                               end
   825                             else write(output,'formal':10)
   826                           end
   827                       end
   828              end (*case*);
   829              writeln(output);
   830              followctp(llink); followctp(rlink);
   831              followstp(idtype)
   832            end (*with*)
   833      end (*followctp*);
   834  
   835    begin (*printtables*)
   836      writeln(output); writeln(output); writeln(output);
   837      if fb then lim := 0
   838      else begin lim := top; write(output,' local') end;
   839      writeln(output,' tables '); writeln(output);
   840      marker;
   841      for i := top downto lim do
   842        followctp(display[i].fname);
   843      writeln(output);
   844      if not eol then write(output,' ':chcnt+16)
   845    end (*printtables*);
   846  
   847    procedure genlabel(var nxtlab: integer);
   848    begin intlabel := intlabel + 1;
   849      nxtlab := intlabel
   850    end (*genlabel*);
   851  
   852    procedure block(fsys: setofsys; fsy: symbol; fprocp: ctp);
   853      var lsy: symbol; test: boolean;
   854  
   855      procedure skip(fsys: setofsys);
   856        (*skip input string until relevant symbol found*)
   857      begin
   858        if not eof(input) then
   859          begin while not(sy in fsys) and (not eof(input)) do insymbol;
   860            if not (sy in fsys) then insymbol
   861          end
   862      end (*skip*) ;
   863  
   864      procedure constant(fsys: setofsys; var fsp: stp; var fvalu: valu);
   865        var lsp: stp; lcp: ctp; sign: (none,pos,neg);
   866            lvp: csp; i: 2..strglgth;
   867      begin lsp := nil; fvalu.ival := 0;
   868        if not(sy in constbegsys) then
   869          begin error(50); skip(fsys+constbegsys) end;
   870        if sy in constbegsys then
   871          begin
   872            if sy = stringconst then
   873              begin
   874                if lgth = 1 then lsp := charptr
   875                else
   876                  begin
   877                    new(lsp,arrays);
   878                    with lsp^ do
   879                      begin aeltype := charptr; inxtype := nil;
   880                         size := lgth*charsize; form := arrays
   881                      end
   882                  end;
   883                fvalu := val; insymbol
   884              end
   885            else
   886              begin
   887                sign := none;
   888                if (sy = addop) and (op in [plus,minus]) then
   889                  begin if op = plus then sign := pos else sign := neg;
   890                    insymbol
   891                  end;
   892                if sy = ident then
   893                  begin searchid([konst],lcp);
   894                    with lcp^ do
   895                      begin lsp := idtype; fvalu := values end;
   896                    if sign <> none then
   897                      if lsp = intptr then
   898                        begin if sign = neg then fvalu.ival := -fvalu.ival end
   899                      else
   900                        if lsp = realptr then
   901                          begin
   902                            if sign = neg then
   903                              begin new(lvp,reel);
   904                                if fvalu.valp^.rval[1] = '-' then
   905                                  lvp^.rval[1] := '+'
   906                                else lvp^.rval[1] := '-';
   907                                for i := 2 to strglgth do
   908                                  lvp^.rval[i] := fvalu.valp^.rval[i];
   909                                fvalu.valp := lvp;
   910                              end
   911                            end
   912                          else error(105);
   913                    insymbol;
   914                  end
   915                else
   916                  if sy = intconst then
   917                    begin if sign = neg then val.ival := -val.ival;
   918                      lsp := intptr; fvalu := val; insymbol
   919                    end
   920                  else
   921                    if sy = realconst then
   922                      begin if sign = neg then val.valp^.rval[1] := '-';
   923                        lsp := realptr; fvalu := val; insymbol
   924                      end
   925                    else
   926                      begin error(106); skip(fsys) end
   927              end;
   928            if not (sy in fsys) then
   929              begin error(6); skip(fsys) end
   930            end;
   931        fsp := lsp
   932      end (*constant*) ;
   933  
   934      function equalbounds(fsp1,fsp2: stp): boolean;
   935        var lmin1,lmin2,lmax1,lmax2: integer;
   936      begin
   937        if (fsp1=nil) or (fsp2=nil) then equalbounds := true
   938        else
   939          begin
   940            getbounds(fsp1,lmin1,lmax1);
   941            getbounds(fsp2,lmin2,lmax2);
   942            equalbounds := (lmin1=lmin2) and (lmax1=lmax2)
   943          end
   944      end (*equalbounds*) ;
   945  
   946      function comptypes(fsp1,fsp2: stp) : boolean;
   947        (*decide whether structures pointed at by fsp1 and fsp2 are compatible*)
   948        var nxt1,nxt2: ctp; comp: boolean;
   949          ltestp1,ltestp2 : testp;
   950      begin
   951        if fsp1 = fsp2 then comptypes := true
   952        else
   953          if (fsp1 <> nil) and (fsp2 <> nil) then
   954            if fsp1^.form = fsp2^.form then
   955              case fsp1^.form of
   956                scalar:
   957                  comptypes := false;
   958                  (* identical scalars declared on different levels are
   959                   not recognized to be compatible*)
   960                subrange:
   961                  comptypes := comptypes(fsp1^.rangetype,fsp2^.rangetype);
   962                pointer:
   963                    begin
   964                      comp := false; ltestp1 := globtestp;
   965                      ltestp2 := globtestp;
   966                      while ltestp1 <> nil do
   967                        with ltestp1^ do
   968                          begin
   969                            if (elt1 = fsp1^.eltype) and
   970                               (elt2 = fsp2^.eltype) then comp := true;
   971                            ltestp1 := lasttestp
   972                          end;
   973                      if not comp then
   974                        begin new(ltestp1);
   975                          with ltestp1^ do
   976                            begin elt1 := fsp1^.eltype;
   977                              elt2 := fsp2^.eltype;
   978                              lasttestp := globtestp
   979                            end;
   980                          globtestp := ltestp1;
   981                          comp := comptypes(fsp1^.eltype,fsp2^.eltype)
   982                        end;
   983                      comptypes := comp; globtestp := ltestp2
   984                    end;
   985                power:
   986                  comptypes := comptypes(fsp1^.elset,fsp2^.elset);
   987                arrays:
   988                  begin
   989                    comp := comptypes(fsp1^.aeltype,fsp2^.aeltype)
   990                        and comptypes(fsp1^.inxtype,fsp2^.inxtype);
   991                    comptypes := comp and (fsp1^.size = fsp2^.size) and
   992                        equalbounds(fsp1^.inxtype,fsp2^.inxtype)
   993                  end;
   994                records:
   995                  begin nxt1 := fsp1^.fstfld; nxt2 := fsp2^.fstfld; comp:=true;
   996                    while (nxt1 <> nil) and (nxt2 <> nil) do
   997                      begin comp:=comp and comptypes(nxt1^.idtype,nxt2^.idtype);
   998                        nxt1 := nxt1^.next; nxt2 := nxt2^.next
   999                      end;
  1000                    comptypes := comp and (nxt1 = nil) and (nxt2 = nil)
  1001                                and(fsp1^.recvar = nil)and(fsp2^.recvar = nil)
  1002                  end;
  1003                  (*identical records are recognized to be compatible
  1004                   iff no variants occur*)
  1005                files:
  1006                  comptypes := comptypes(fsp1^.filtype,fsp2^.filtype)
  1007              end (*case*)
  1008            else (*fsp1^.form <> fsp2^.form*)
  1009              if fsp1^.form = subrange then
  1010                comptypes := comptypes(fsp1^.rangetype,fsp2)
  1011              else
  1012                if fsp2^.form = subrange then
  1013                  comptypes := comptypes(fsp1,fsp2^.rangetype)
  1014                else comptypes := false
  1015          else comptypes := true
  1016      end (*comptypes*) ;
  1017  
  1018      function string(fsp: stp) : boolean;
  1019      begin string := false;
  1020        if fsp <> nil then
  1021          if fsp^.form = arrays then
  1022            if comptypes(fsp^.aeltype,charptr) then string := true
  1023      end (*string*) ;
  1024  
  1025      procedure typ(fsys: setofsys; var fsp: stp; var fsize: addrrange);
  1026        var lsp,lsp1,lsp2: stp; oldtop: disprange; lcp: ctp;
  1027            lsize,displ: addrrange; lmin,lmax: integer;
  1028  
  1029        procedure simpletype(fsys:setofsys; var fsp:stp; var fsize:addrrange);
  1030          var lsp,lsp1: stp; lcp,lcp1: ctp; ttop: disprange;
  1031              lcnt: integer; lvalu: valu;
  1032        begin fsize := 1;
  1033          if not (sy in simptypebegsys) then
  1034            begin error(1); skip(fsys + simptypebegsys) end;
  1035          if sy in simptypebegsys then
  1036            begin
  1037              if sy = lparent then
  1038                begin ttop := top;   (*decl. consts local to innermost block*)
  1039                  while display[top].occur <> blck do top := top - 1;
  1040                  new(lsp,scalar,declared);
  1041                  with lsp^ do
  1042                    begin size := intsize; form := scalar;
  1043                      scalkind := declared
  1044                    end;
  1045                  lcp1 := nil; lcnt := 0;
  1046                  repeat insymbol;
  1047                    if sy = ident then
  1048                      begin new(lcp,konst);
  1049                        with lcp^ do
  1050                          begin name := id; idtype := lsp; next := lcp1;
  1051                            values.ival := lcnt; klass := konst
  1052                          end;
  1053                        enterid(lcp);
  1054                        lcnt := lcnt + 1;
  1055                        lcp1 := lcp; insymbol
  1056                      end
  1057                    else error(2);
  1058                    if not (sy in fsys + [comma,rparent]) then
  1059                      begin error(6); skip(fsys + [comma,rparent]) end
  1060                  until sy <> comma;
  1061                  lsp^.fconst := lcp1; top := ttop;
  1062                  if sy = rparent then insymbol else error(4)
  1063                end
  1064              else
  1065                begin
  1066                  if sy = ident then
  1067                    begin searchid([types,konst],lcp);
  1068                      insymbol;
  1069                      if lcp^.klass = konst then
  1070                        begin new(lsp,subrange);
  1071                          with lsp^, lcp^ do
  1072                            begin rangetype := idtype; form := subrange;
  1073                              if string(rangetype) then
  1074                                begin error(148); rangetype := nil end;
  1075                              min := values; size := intsize
  1076                            end;
  1077                          if sy = colon then insymbol else error(5);
  1078                          constant(fsys,lsp1,lvalu);
  1079                          lsp^.max := lvalu;
  1080                          if lsp^.rangetype <> lsp1 then error(107)
  1081                        end
  1082                      else
  1083                        begin lsp := lcp^.idtype;
  1084                          if lsp <> nil then fsize := lsp^.size
  1085                        end
  1086                    end (*sy = ident*)
  1087                  else
  1088                    begin new(lsp,subrange); lsp^.form := subrange;
  1089                      constant(fsys + [colon],lsp1,lvalu);
  1090                      if string(lsp1) then
  1091                        begin error(148); lsp1 := nil end;
  1092                      with lsp^ do
  1093                        begin rangetype:=lsp1; min:=lvalu; size:=intsize end;
  1094                      if sy = colon then insymbol else error(5);
  1095                      constant(fsys,lsp1,lvalu);
  1096                      lsp^.max := lvalu;