(* kvrm*)
begin { getdescriptor }
     if entry <> nil
	  then begin
	  decltail := nil;
	  with entry^ do
	       case form of
     scalars   : if scalarkind = declared
	       then begin
	       idroot := constidroot;
	       i := 0;
	       while idroot <> -1 do
		    begin
		    with idrecs[idroot], val do
			 begin
			 kind := intkind;
			 ival := i;
			 idroot := next
			 end;
		    i := i + 1
		    end;
	       desc := intdesc;
	       with desc do
		    begin
		    min := 0;
		    max := i - 1;
		siz := max;
		   if max <= %7f then
		      desc.typename := ccint8basictype
			else if max <= %7fff then
			   desc.typename := ccint16basictype
		    end;
		bitsize := 0;
		while siz >1 do
		  begin
		  siz := siz div 2;
		  bitsize := bitsize + 1
		  end;
		desc.packname := bitsize * 256 + %2040;

	       end;
	  subranges : begin
	       if rangetype = nil
		    then desc := intdesc
	       else desc := rangetype^.desc;
	  if min >= 0 then siz := max
	  else if max <= 0 then siz := -min-1
	  else if max > -min then siz := max
	  else siz := -min -1;
       if siz <= %7f then desc.typename := ccint8basictype
	  else if siz <= %7fff then desc.typename := ccint16basictype;
	       desc.min := min;
	       desc.max := max;
		bitsize := 0;
		while siz > 1 do
		  begin
		  siz := siz div 2;
		  bitsize := bitsize + 1
		  end;
	       desc.packname := bitsize * 256 + %2040;

	       end;
	  pointers  : begin
	       with desc do
		    if domaintype = nil
		    then begin
		    vector := false;
		    kind := undefpointer;
		    typename := ccundefineditempointer;
		    domtypename := 0
		    end
	       else begin
		    vector := false;
		    kind := defpointer;
		    with domaintype^ do
			if form = pointers then
				typename := xxpointertypedecl(desc.typename) + ccunboundeditempointer
			else if form = arrays then typename := desc.typename + ccboundeditempointer
				else typename := desc.typename + ccunboundeditempointer;
		    bounded := domaintype^.form = arrays
		    end;
	       desc.packname := desc.typename

	       end;
	  arrays     : begin
	       if indextype = nil
		    then dimension := 0
	       else if indextype = inttype
		    then begin dimension := 0; error(78) end
	       else dimension := cardinality(indextype);
	       if elemtype = nil
		    then typname := ccintbasictype
	       else with elemtype^, desc do
		    begin
		    if form = arrays
			 then begin
	noels := desc.size
		end
		else noels := 1;

		    if form = pointers then
			typname := xxpointertypedecl(typename)
		    else if entry^.arrpacked then typname := packname
		else typname := typename
		    end;
	       with desc do
		    begin
		    vector := true;
		    kind := struct;
		size := noels*dimension;
		    packname := typname;
		typename := typname
		    end
	       end;
	  sets       : begin
	       if basetype = nil
		    then dimension := 1
	       else if basetype = inttype
		    then dimension := maxsetelement - minsetelement + 1
	       else if basetype^.form = subranges
                      then dimension := basetype^.desc.max - minsetelement +1
                      else dimension := cardinality(basetype);
	      if dimension <= 64 then
		desc.packname := (dimension - 1) * 256 + %2080;
	      if dimension <= 8 then dimension := 8
	      else if dimension <= 16 then dimension := 16
                 else if dimension <= 32 then dimension := 32
                    else if dimension <= 64 then dimension := 64
                      else dimension := 128;
	       with desc do
		    begin
                   case dimension of
			   8 : typename := cc8basictype;
			   16 : typename := cc16basictype;
                           32 : typename := cc32basictype;
                           64 : typename := cc64basictype;
                          128 : begin
				packname := cc128basictype;
typename := cc128basictype
				end
                      end;
		    size := dimension;
		    vector := false;
		    kind := sett;
		    end
	       end;
	  records    : begin
	       level := 0;
	       fldselhead := nil;
	       fldseltail := nil;
	       with desc do
		    begin
		    vector := false;
		    kind := struct;
		    if varpart <> nil {mutl needs variants first at present}
			 then varpartdeclaration(varpart,entry^.recpacked);
		    if fixedfieldroot <> -1
			 then fielddeclaration(fixedfieldroot, entry^.recpacked);
		    breakdeclarentry(symbname, typename);
		    packname := typename

		    end
	       end;
     files      :desc := filedesc;
	  varparts,
	  variant    : desc.kind := struct
	  end
	  end
     end; { getdescriptor }

procedure getbounds(entry : typentry; var lowbound, highbound : integer); forwa
rd;

{issue 11}{new proc to print page and line}
procedure outpagelineno(page,line:integer){77a};
begin
  write(page:4,'.',line:2,'  ')
end;

{ new proc to warn when non-iso extensions used }
procedure extension;{78}
begin
if iso then
   begin
   writeln;
   outpagelineno(currentpageno,currentlineno);{issue11}
   writeln('  >>>** warning: line contains an extension to the iso standard')
   end
end;


   procedure printsourceline;{79}

     var
	       tempc,i, w, nextprintpos : integer;
	
     procedure printerrors;{80}
	  var
		    i, lastarrowpos : integer;
	
	  procedure printarrow(arrowposition : lineposition);{81}
	
	       begin
	       lastarrowpos := arrowposition;
	       if arrowposition < nextprintpos
		    then begin
		    writeln;
		    nextprintpos := 1;
(*kvrm *)             write('        ',chr(ordtab))    (* kvrm*)
(*kvadd           write(chr(ordtab))  kvadd*)
		    end;
	       arrowposition := arrowposition + 1;
	  write('^' : arrowposition - nextprintpos);
	       nextprintpos := arrowposition
	       end;
	

	  procedure printcomma;{82}
	       begin
	       write(',^');
	       nextprintpos := nextprintpos + 1
	       end;
	
	  begin { printerrors }
(*kvrm *)   write('        ', chr(ordtab));     (* kvrm*)
(*kvadd write(chr(ordtab));   kvadd*)
	  nextprintpos := 1;
	  totalerrorsdiscovered := totalerrorsdiscovered + errorsdiscovered;
	  if totalerrorsdiscovered > 100 then goto 1;
	  with errorlist[1] do

	       printarrow(position);

	  for i := 2 to errorsdiscovered do
	       with errorlist[i] do
	       begin
	       if position = lastarrowpos
		    then printcomma
	       else printarrow(position);

	       end;
	  if erroroverflow
	       then begin
	       writeln;
	       write(chr(ordtab));
	       write('further errors suppressed');
	       erroroverflow := false
	       end;
	  writeln;
	  for i := 1 to errorsdiscovered do
	     errormessage(errorlist[i].code)
	  end; { printerrors }

     begin { printsourceline }
     if listsource or ((errorsdiscovered > 0) and listerrors)
	  then begin
	   if errorsdiscovered>0 then
	     writeln('>>>**')
	  else write(' ');
	  inbackspace(-1);
	  outpagelineno(currentpageno,currentlineno);{issue11}
	  write(chr(ordtab));
repeat
tempc := inch;
outch(tempc)
until tempc = ilinefeed;
	  if errorsdiscovered > 0
	       then printerrors
	  end;
     errorsdiscovered := 0;

     errorindex := 1;
     linenumpassed := false;
{issue 11}
     end; { printsourceline }

   procedure error;{83}
     begin
	putcode := false;
     if errorsdiscovered < errormax
	  then begin
	  errorsdiscovered := errorsdiscovered + 1;
	  with errorlist[errorsdiscovered] do
	       begin
	       code := errorcode;
	       position := errorindex - 1
	       end
	  end
     else erroroverflow := true
     end;


procedure newch;{84}
     begin
     ch := chr(inch);
     chval := chvals[ch];
    if ch >= space then
	errorindex := errorindex +1
    else if ord(ch) = papthrow then
 begin{issue 11}
   currentpageno := currentpageno + 1;
   currentlineno := 1;
		errorindex := 1
end
	  else if ord(ch) = ordtab then
		begin
		errorindex := errorindex + 9 - errorindex mod 8;
	ch := space;
	  chval := sspace
		end
	{ otherwise no advance for non printing char }
end;
   procedure analysedirective; forward;

procedure insymbol;{85}
     const
	       quote = '''';
     var
	  i, j, l : integer;
endstring, symbolobtained, delimobtained,
warning, stringtoolong, endcomment : boolean;
(*kvmod*)underscwarninggiven : boolean;

procedure getnumconstant(base:chtype;ilength,rlength:integer);{86}
     var
      aninteger,negexponent:boolean;
      digit:array[1..maxdecreallength] of chtype;
	       b,f,r : real;
	  factor,exponent,scale,i,k,fi,ir,j : integer;
	
     begin { get numconstant }
     aninteger := true;
     scale := 0;
     i := 0;
     exponent := 0;
     factor := 1;
     while ch = '0' do
	  newch;
     while chval<=base do {issue 11}{= frig to combat kv}
	  begin
	  i := i+1;
{issue 11}{to combat kv for hex}if chval > d9 then chval := pred(chval);
	  if i <= rlength then
	     digit[i] := chval;
       newch
  	end;
     if ch = '.'
	  then begin
	  newch;
	  if ch = '.'
	       then inbackspace(1)
	  else if ch = ')'
	       then begin
			ch := ']';
			chval := sclbracket
			end

	  else begin
	       aninteger := false;
	       if chval<base
		    then begin
		    if i = 0 then
		      while ch = '0' do
			begin
			scale := scale + 1;
			newch
			end;
		    while chval<base do
		    begin
		    i := i + 1;
		    if i <= rlength then
		       digit[i] := chval;
		    newch;
		    scale := scale + 1
		    end
		    end
	       else error(22)
	       end
	  end;
     if chval = le
	  then begin

	  aninteger := false;
	  newch;
	  negexponent := (ch = '-');
	  if negexponent or (ch = '+')
	       then newch;
	  if chval<base
	       then while chval<base do
	       begin
	       exponent := exponent*ord(base) + ord(chval);
	       newch
	       end
	  else error(22);
	  if negexponent
	       then scale := scale + exponent
	  else scale := scale - exponent
	  end;
     if aninteger
	  then begin
	  if i > ilength
	       then begin
	       error(101);
	       i := ilength
	       end;
	  k := 0;
	  for j := 1 to i do
	       k := k*ord(base) + ord(digit[j]);
	  with constant do
	       begin
	       kind := intkind;
	       ival := k
	       end;
	  symbol := intconst
	  end
     else begin
	  if i > rlength
	       then begin
	       writeln('real constant too long : inaccuracy will result');
	scale := scale + rlength - i;
	       i := rlength
	       end;
	  ir := 0;
	  r:= ir;
	  b := ord(base);
	  fi := 1;
	  f := fi;
	  for j := 1 to i do
	       r := r*b + ord(digit[j]);
{issue 11} if scale >= 0 then
{issue 11}for j:= 1 to scale do r := r/b
{issue 11}else
{issue 11}  begin
{issue 11}  for j := 1 to -scale do f := f/b;
{issue 11}  if f<> 0 then r := r/f
{issue 11}     else error(101)
{issue 11}end;
	  with constant do
	       begin
	       kind := realkind;
	       rval := r;
	       end;
	  symbol := realconst
	  end
     end; { getnumconstant }

{complete reorganisation of insymbol to improve efficiency}
   begin { insymbol }
operator := notop;
repeat {until symbol obtained}
     symbolobtained := true;
     case chval of
la,lb,lc,ld,le,lf,lg,lh,li,lj,lk,ll,lm,ln,lo,lp,lq,
lr,ls,lt,lu,lv,lw,lx,ly,lz:
	  begin {identifier or delimiter}
	  sig := 0;
	  i := 0;
(*kvmod*) underscwarninggiven := false;
	  idname := spaces;
	  repeat {read and pack name}
	      ch := valchs[chval];
(*kvmod*)     if (chval = sundersc) and (not underscwarninggiven) then
(*kvmod*)     begin
(*kvmod*)        extension;
(*kvmod*)        underscwarninggiven := true;
(*kvmod*)     end;
	     i := i + 1;
	    if i < maxidentlength
		 then begin
		if i <= 8 then
		 sig := sig*2 + ord(ch);
		 idname[i] := ch
		 end;
	    idarray[idindex + i] := ch;
	    newch
	  until chval > lz;
	  delimobtained := false;
	  if i <= maxidentlength then
	  begin
	  l := delimstart[i-1];
	  j := delimend[i-1]
	  end
	  else begin
	    l := 1;
	    j := 0
	    end;
	  while (not delimobtained) and (l <= j) do
	       with delimiter[l] do
	       if signature = sig then
	       if name = idname
	       then begin {delimiter matched}
	       symbol := symb;
	       operator := op;
	       delimobtained := true
	       end
	  else l := l + 1
	  else l := l+1;
	  if not delimobtained
	       then begin {identifier}
	       symbol := ident;
	       idnamelength := i
	       end
	  end {identifier or delimiter};
d0,d1,d2,d3,d4,d5,d6,d7,d8,d9:
	  begin {numeric constant}
(*kvmod*) getnumconstant(sundersc,maxdecintlength,maxdecreallength);
	if chval <= lz then error(114)
	  end {numeric constant};
     squote : begin {string}
	  i := 0;
	stringtoolong := false;
	  endstring := false;
	  newch;
	  repeat
	       if ch = quote
		    then begin
		    newch;
		    if ch <> quote
			 then endstring := true
		    end;
	       if not endstring
		    then if i < maxstringlength
		    then begin
		    i := i + 1;
		    stringelement^[i] := ch;
		    if ch = linefeed then
			begin
			error(100);
			printsourceline;
   currentlineno := currentlineno + 1;{issue 11}
			endstring := true
			end;
		    newch
		    end
	       else begin
		    endstring := true;
		    stringtoolong := true
		    end
	  until endstring;
	  if i = 0
	       then begin
	       error(22);
	       symbolobtained := false
	       end
	  else if i = 1
	       then begin
	       with constant do
		    begin
		    kind := charkind;
		    cval := stringelement^[1]
		    end;
	       symbol := charconst
	       end
	  else begin
	       if stringtoolong
		    then error(109);
	       with constant do
		    begin
		    kind := stringkind;
		    length := i
		    end;
	       symbol := stringconst
	       end
	  end; {of quote string}
     soparen :   begin
	  if ch = '{'
	       then ch := '*'
	  else newch;
	  if ch = '*'
	       then begin {comment or directive}
		(*kvrm *) warning := true;     (* kvrm*)
		(*kvadd   warning := false;  kvadd*)
	       newch;
		if ch = '$' then
			analysedirective;
	       repeat
		    endcomment := (ch = '*');
		    if ch <> '}' then newch;
		if chval = snewline then
		  begin
		  printsourceline;
		  if warning then begin
		  writeln;
		  outpagelineno(currentpageno,currentlineno);{issue11}
		  writeln('warning.possibly unclosed comment')
		  end;
currentlineno := currentlineno + 1;{issue 11}
		  warning := false
		  end
	       until ((ch = ')') and endcomment) or (ch = '}');
	       symbolobtained := false;
	       newch
	       end {comment or directive}
	  else if ch = '.'
	       then begin
	       newch;
	       symbol := leftbracket
	       end
	  else symbol := leftparent
	  end;
     scolon :   begin
	  newch;
	  if ch = '='
	       then begin
	       newch;
	       symbol := becomes
	       end {assignment operator}
	  else symbol := colon
	  end;
     sdot :   begin
	  newch;
	  if ch = '.'
	       then begin
	       newch;
	       symbol := ddot
	       end
	  else if ch = ')'
	       then begin
	       newch;
	       symbol := rightbracket
	       end
	  else symbol := period
	  end;
     slt :   begin
	  newch;
	  symbol := relop;
	  if ch = '='
	       then begin
	       newch;
	       operator := leop
	       end
	  else if ch = '>'
	       then begin
	       newch;
	       operator := neop
	       end
	  else operator := ltop
	  end;
     sgt :   begin
	  newch;
	  symbol := relop;
	  if ch = '='
	       then begin
	       newch;
	       operator := geop
	       end
	  else operator := gtop
	  end;
     smul :   begin
	  newch;
	  if ch = '*'  { muss compile-time command }
	       then begin
		    symbolobtained := false;
		    extension;
		   (*kvrm *) selectoutput(0); (* kvrm*)
		   (*kvrm *) ppccmd; (* kvrm*)
   currentlineno := currentlineno + 1;
 		   errorindex := 1;
    ch := space;
		    chval := sspace
	       end
	  else begin
	       symbol := mulop;
	       operator := mul
	       end
	  end;
     sshriek,sdquote,spound,sdollar,sand,
	sgrave,stilda,sbar,squestion :
	  begin
	  error(6);
	  symbolobtained := false;
	  newch;
	  end;
	seq,sbslash,sat,sopbracket,
     splus,sscolon,sminus,sarrow,sclparen,
     sclbracket,scomma,sslash:
	  begin
	  with charsymbol[chval] do
	       begin
	       symbol := symb;
	       operator := op
	       end;
	  newch
	  end;
  sspace,
  sothers : begin
            newch;
            symbolobtained := false
            end;
  snewline :begin
            printsourceline;
      currentlineno := currentlineno +1;{issue 11}
            newch;
            symbolobtained := false
            end;
     spercent :   begin		{ hexadecimal constant }
	  extension;
	  newch;
(*kvmod*) getnumconstant(lf,maxhexintlength,maxhexreallength)
	  end
     end
until symbolobtained
end; { insymbol }

procedure analysedirective;{87}

	var notenddirective : boolean;
     function directive : boolean;
	  begin {true if + on input}
	  newch;
	  directive := (ch = '+');
	  newch
	  end;

     begin {analyse directive}
	notenddirective := true;
     while notenddirective do
	  begin
	if (ch = ',') or (ch = '$') then newch
	else if ch = 'Y' then
	   export := directive
	  else if ch = 'S' then
		begin
		newch;
		insymbol;
		if symbol = intconst then
		   tlcodearea(constant.ival)
		end
	   else if ch = 'P'
	       then begin
	  newch;
	  insymbol;
	  if symbol = intconst then
	    begin
	    printpar := constant.ival;
	    tlprint(printpar)
	    end
	       end
	  else if ch = 'T'
	       then trace := directive
	  else if ch = 'L'
	       then listsource := directive
	  else if ch = 'I'
	       then begin iso := directive;
(*kvrm *)         if iso then                 (* kvrm*)
    begin {issue 11}
(*kvrm *)(*kvmod*)       delimend[8] := 36;    (* kvrm*)
     delimend[5] := 32
  end
(*kvrm *)(*kvmod*)else begin
     delimend[8] := 37;  (* kvrm*)
     delimend[5] := 33
    end
	       end
	  else if ch = 'E'
	       then listerrors := directive
         else if ch = 'C'
            then begin
checking := directive;
releaseregister(b,false);tlclit32(cc8basictype,ord(checking));
plantname(load,b,0);
plantname(store,b,heapcheck)
end
else if ch = 'R' then
if directive then
begin
ccrealbasictype := %1c;
idrecs[realid].idtype := real64type
end
else begin
ccrealbasictype := %c;
idrecs[realid].idtype := real32type
end
else if ch = 'D' then
begin
newch;
insymbol;
if symbol = intconst then
tldataarea(constant.ival)
end
else if ch = 'N' then in16 := directive
(*kvadd  else if ch = 'A' then                                            kvadd*
)
(*kvadd       begin                                                       kvadd*
)
(*kvadd          newch;                                                   kvadd*
)
(*kvadd          insymbol;                                                kvadd*
)
(*kvadd          if symbol = stringconst then                             kvadd*
)
(*kvadd          begin                                                    kvadd*
)
(*kvadd             tlident(addbound(stringelement^[1],constant.length)); kvadd*
)
(*kvadd          end else                                                 kvadd*
)
(*kvadd          begin                                                    kvadd*
)
(*kvadd             if symbol = charconst then                            kvadd*
)
(*kvadd             begin                                                 kvadd*
)
(*kvadd                tlident(addbound(stringelement^[1],1));            kvadd*
)
(*kvadd             end else                                              kvadd*
)
(*kvadd             begin                                                 kvadd*
)
(*kvadd                writeln('>>>*warning. archive string expected');   kvadd*
)
(*kvadd             end;                                                  kvadd*
)
(*kvadd          end;                                                     kvadd*
)
(*kvadd       end                                                         kvadd*
)
	else notenddirective := false
	  end
     end; {analyse directive}


   procedure disposescope; forward;

procedure openscope(kind : scopekind);{88}
     begin
     scopenumber := scopenumber + 1;
     if top < displaylimit
	  then top := top + 1
     else begin
	  error(103);
	  if top > displaylimit
	       then disposescope
	  else top := displaylimit + 1
	  end;
     with display[top] do
	  begin
	  idscope := -1;
	  scope := kind;
	  if (kind = bloc) or (kind = pseudobloc)
	       then begin
	       typeroot := nil;
	       labelroot := nil;
	     if kind = bloc then
	       level := top
	       end
	  end
     end;

procedure closescope;{89}
     begin
     if display[top].scope = bloc
	  then begin
	  repeat
	       level := level - 1
	  until display[level].scope = bloc;
	  tlnamecount := display[level + 1].initialtlname
	  end;
     top := top - 1
     end;

procedure savescope( var entry : scopentry);{90}
     var id : identry;
     begin
     new(entry);
     entry^ := display[top];
	if entry^.idscope <> -1 then
     for id := entry^.idscope to topid do
	idrecs[id].textlevel := -2;
     level := level - 1;
     top := level;
     end;


procedure restorescope(entry : scopentry);{91}
     var id : identry;
     begin
     openscope(bloc);
     id := entry^.idscope;
	if id <> -1 then
     while idrecs[id].textlevel = -2 do
	begin
	idrecs[id].textlevel := top;
     idrecs[id].topscope := scopenumber;
	id := id + 1
	end;
     dispose(entry)
     end;

   procedure disposescope;{92}

     procedure disposeid(root : identry);{93}
	  var i : integer;
	
	  procedure disposentry(id : identry);{94}
	
	       procedure disposeformal(root : formalentry);{95}
		    var
			      thisformal : formalentry;
		    begin
		    while root <> nil do
			 begin
			 thisformal := root;
			 with root^ do
			      begin
			      if kind in [procparam, funcparam]
				   then disposeformal(formalroot);
			      root := next
			      end;
			 dispose(thisformal)
			 end
		    end;
	
	       begin { disposentry }
			with idrecs[id] do
		     if class in [proc,func] then
			begin
		     if kind = declared
		    then begin
		     with decl^ do
			if declkind = actual then
			if not external
			 then begin
			 if forwardproc
			      then error(48);
			 if formalroot <> nil
			      then disposeformal(formalroot)
			end;
		     dispose(decl)
		     end
			 end;
	       end; { disposentry }
	
	  begin { disposeid }

	while topid >= root do
	   begin
	   disposentry(topid);
	   i := idrecs[topid].signature mod 512;
	   hashtable[i] := idrecs[hashtable[i]].nxthash;
	   topid := topid - 1
	   end;
	  idindex := idrecs[topid + 1].iindex
	  end; { disposeid }

     procedure disposetype(root : typentry);{96}
	  var
		    thisentry : typentry;
	  begin
	  while root <> nil do
	       begin
	       thisentry := root;
	       with thisentry^ do
		    begin
		    root:=next;
		    case form of
	       scalars   : dispose(thisentry, scalars);
	       subranges : dispose(thisentry, subranges);
	       pointers  : dispose(thisentry, pointers);
	       sets      :
dispose(thisentry, sets);
	       arrays    : dispose(thisentry, arrays);
		    records   : begin
			 if fieldscope <> -1 then
			    disposeid(fieldscope);
			 dispose(thisentry, records)
			 end;
	       files     : dispose(thisentry, files);
	       varparts  : dispose(thisentry, varparts);
	       variant   : dispose(thisentry, variant)
		    end
		    end
	       end
	  end;

     procedure disposelabel(root : labelentry);{97}
	  var
		    thisentry : labelentry;
	  begin
	  while root <> nil do
	       begin
	       thisentry := root;
		root := root^.next;
	       dispose(thisentry)
	       end
	  end;

     begin { disposescope }
     with display[top] do
	  begin
	  if idscope <> -1
	       then disposeid(idscope);
	  if typeroot <> nil
	       then disposetype(typeroot);
	  if labelroot <> nil
	       then disposelabel(labelroot)
	  end
     end; { disposescope }

   function newtype( formneeded : typeform) : typentry;{98}
     var
	       newentry : typentry;
     begin
     case formneeded of
     scalars   : begin
	  new(newentry, scalars, declared);
	  with newentry^ do
	       begin
	       scalarkind := declared;
	       constidroot := -1
	       end
	  end;
     subranges : begin
	  new(newentry, subranges);
	  with newentry^ do
	       begin
	       rangetype := nil;
	       min := 0;
	       max := 1
	       end
	  end;
     pointers  : begin
	  new(newentry, pointers);
	  newentry^.domaintype := nil
	  end;
     sets      : begin
	  new(newentry, sets);
	  newentry^.basetype := nil
	  end;
     arrays    : begin
	  new(newentry, arrays);
	  with newentry^ do
	       begin
	       elemtype := nil;
	       indextype := nil;
	       end
	  end;
     records   : begin
	  new(newentry, records);
	  with newentry^ do
	       begin
	       fieldscope := -1;
	       fixedfieldroot := -1;
	       varpart := nil
	       end
	  end;
     files     : begin
	  new(newentry, files);
	  newentry^.componenttype := nil
	  end;
     varparts  : begin
	  new(newentry, varparts);
	  with newentry^ do
	       begin
	       tagfield := -1;
	       variantroot := nil
	       end
	  end;
     variant   : begin
	  new(newentry, variant);
	  with newentry^ do
	       begin
	       varfieldroot := -1;
	       nextvariant := nil;
	       subvarpart := nil;
	       aslastvariant := true;
	       with val do
		    begin
		    kind := intkind;
		    ival := 0
		    end
	       end
	  end
     end;
     newentry^.form := formneeded;
     with display[level] do
	  begin
	  newentry^.next := typeroot;
	  typeroot := newentry;
	  end;
     newtype := newentry
     end;

   procedure initidchain(var chain : idchain);{99}
     begin
     with chain do
	  begin
	  head := -1;
	  tail := -1
	  end
     end;

procedure chainid(var chain : idchain; entry : identry);{100}
     begin
     with chain do
	  begin
	  if head = -1
	       then head := entry
	  else idrecs[tail].next := entry;
	  tail := entry
	  end
     end;

procedure linkidchains(var chain1, chain2 : idchain);{101}
     begin
     if chain1.head = -1
	  then chain1 := chain2
     else if chain2.head <> -1
	  then begin
	  idrecs[chain1.tail].next := chain2.head;
	  chain1.tail := chain2.tail
	  end
     end;

procedure reverseidchain(root : identry;  var newroot : identry);{102}
     var
	       p, q : identry;
     begin
     p := -1;
     while root <> -1 do
	  begin
	  q := idrecs[root].next;
	  idrecs[root].next := p;
	  p := root;
	  root := q
	  end;
     newroot := p
     end;

{ new function to compare identifiers }
function equal(index1, index2, length : idarrlength): boolean;{103}
var i : idarrlength;
    endloop : boolean;
begin
endloop := false;
i := length;
repeat
  endloop := idarray[index1 + i] <> idarray[index2 + i];
  i := i - 1
until endloop or (i <= 0);
equal := not endloop
end;

   function newid(  classneeded : idclass): identry;{104}
     var
	       c : char;
	  i : integer;
	  tempentry,newentry : identry;
	  lefttaken : boolean;
     begin
     if not initstagepassed
	  then begin
	  i := 1;
	  sig := 0;
	  repeat
	       sig := sig*2 + ord(idname[i]);
	       i := i + 1;
	       if i <= 8
		    then c := idname[i]
	       else c := space
	  until c = space;
	  end;
     if topid >= maxids then error(109)
     else topid := topid + 1;
	newentry := topid;
     with idrecs[newentry] do
	  begin
	  topscope := scopenumber;
	  notyetdefined := false;
	  iindex := idindex;
	  length := idnamelength;
	  signature := sig;
	  tlname := 0;
	  idtype := nil;
	  textlevel := top;
	  nxthash := -1;
	  next := -1;
	  class := classneeded;
	  case classneeded of
     types  : notyetdefined := true;
     consts : begin
		notyetdefined := true;
val := defaulconstant;
		end;
     vars   : begin
			varkind := normalvar;
			assigned := false;
			canassign := true;
			end;
     field  : begin
			selectroot := nil;
			tagf := false
			end;
	  proc,
	  func   : begin
	       kind := declared;
	       new(decl);
	       with decl^ do
		begin
		formalroot := nil;
		declkind := actual;
		external := false;
		forwardproc := false;
		restlname := 0
		end
	       end
	  end;
	i := signature mod 512;
	  end;
     tempentry := display[top].idscope;
     if tempentry = -1
	  then display[top].idscope := newentry;
	tempentry := hashtable[i];
	hashtable[i] := newentry;
	idrecs[newentry].nxthash := tempentry;
	while tempentry <> -1 do
	   begin
		with idrecs[tempentry] do
		   if length = idnamelength then
		      if signature = sig then
				   if ((textlevel >= 0) and (topscope >= scopenumber)) or
							(textlevel = top)  then
			    if equal(iindex,idindex,idnamelength) and
		   not defauldeclaration then begin error(32); tempentry := -1 end;
		if tempentry <> -1 then
		   tempentry := idrecs[tempentry].nxthash
	   end;
     idindex := idindex + idnamelength;
     if idindex > maxidarray then error(109);
     newid := newentry
     end; {newid}

   function newlabel:labelentry;{105}
     var
	       newentry, thisentry : labelentry;
	  dig,d,i,j,newval : integer;
	  labelfound : boolean;
     begin
     newval := constant.ival;
     if newval > 9999 then error(107);
     thisentry := display[level].labelroot;
     labelfound := false;
     while (thisentry <> nil) and (not labelfound) do
	  with thisentry^ do
	  if val = newval
	  then begin
	  error(92);
	  newlabel := thisentry;
	  labelfound := true
	  end
     else thisentry := next;
     if not labelfound
	  then begin
	  new(newentry);
	  with newentry^ do
	       begin
	       with display[level] do
		    begin
		    next := labelroot;
		    labelroot := newentry
		    end;
	       val := newval;
	       nottobeused := false;
	       nottobedefined := false;
	       jumpto := false;
	       defined := false
	       end;
(*kvmod*)    j := 1;
	d := maxintpower;

	idname := spaces;
	for i := 1 to maxdecintlength do
	   begin
	   dig := newval div d;
(*kvmod*)  if (dig <> 0) or (j > 0) then
	      begin
	      idname[j] := chr(ord('0') + dig);
(*kvadd     newval := newval - (dig * d);  kvadd*)
	      j := j + 1;
	      end;
	   d := d div 10
	   end;
	  xxlabelspecification(worksymbname, ccuserlabel, newentry^.labeltlname);
	  xxstaticstoreallocation(worksymbname, cclabelbasictype,
			0, newentry^.reftlname);
	  xxsetaregmode(cclabelbasictype);
	  plantname(loadref, a, newentry^.labeltlname);
	  plantname(store, a, newentry^.reftlname);
	  newlabel := newentry
	  end;
     end;

procedure inlibrary( var entry : identry; declared : boolean; var inlib : boole
an); forward;

function searchid(classesallowed : setofidclass) : identry;{106}
     var
	       saventry, tempentry, bestentry : identry;
	  withs, found : boolean;
	  i, t, bestlevel : integer;
	
     function chosen(classes : setofidclass) : idclass;{107}
	  begin
	  if vars in classes
	       then chosen := vars
	  else if field in classes
	       then chosen := field
	  else if proc in classes
	       then chosen := proc
	  else if func in classes
	       then chosen := func
	  else if types in classes
	       then chosen := types
	  else chosen := consts
	  end;

     begin { searchid }
     withs := display[top].scope = withst;
     found := false;
     misused := false;
	bestentry := -1;
	bestlevel := -1;
	i := sig mod 512;
	if hashtable[i] <> -1 then
	   begin
	   tempentry := hashtable[i];
	   while (tempentry <>-1) and not found do
		begin
		with idrecs[tempentry] do
		   begin
		   if signature = sig then
		      if idnamelength = length then
			if textlevel > bestlevel then
			 if equal(iindex, idindex, idnamelength) then
			   begin
			   if createidentry then
			     topscope := scopenumber;
			   bestlevel := textlevel;
			   found := not withs;
			   bestentry := tempentry
			   end
		      end;
		tempentry := idrecs[tempentry].nxthash
		end
		end;
		found := bestentry <> -1;
		if found then
		   if idrecs[bestentry].class in classesallowed then
		       levelfound := bestlevel
		   else begin
		     if createidentry then error(34);
		     misused := true
		     end
		else if createidentry then
	        begin
	       t := top;
	       top := level;
		inlibrary(bestentry,false, found);
		if found then
		   misused := not(idrecs[bestentry].class in classesallowed);
		if (not found) or misused then
		   begin
		  if misused
		       then error(34)
		  else if forwardref
		       then writeln('type ', idname, ' not defined')
		  else error(35);
		  defauldeclaration := true;
		  bestentry := newid(chosen(classesallowed));
		  defauldeclaration := false;
	      end;
	  level := top;
	  top := t;
	  levelfound := level
	  end;

     searchid := bestentry
     end; { searchid }

function searchlabel( entry : labelentry): labelentry;{108}
     var
	       i, t, labelval : integer;
	  found : boolean;
	  thisentry : labelentry;
     begin
     labelval := constant.ival;
     i := level;
     found := false;
     while i > 0 do
	  begin
	  thisentry := display[i].labelroot;
	  while (thisentry <> nil) and (not found) do
	       with thisentry^ do
	       if val = labelval
	       then begin
	       found := true;
	       levelfound := i;
	       i := 0
	       end
	  else thisentry := next;
	  i := i - 1
	  end;
     if not found
	  then begin
	  error(93);
	  thisentry := newlabel
	  end;
     searchlabel := thisentry
     end;

   procedure getbounds;{109}
     begin
     if (entry = nil) or (entry = inttype)
	  then begin
	  lowbound := 1;
	  highbound := 1
	  end
     else with entry^.desc do
	  begin
	  lowbound := min;
	  highbound := max
	  end
     end;

function cardinality;{110}
     var
	       low, high : integer;
     begin
     getbounds(entry, low, high);
     cardinality := high - low + 1
     end;

function isstring(entry : typentry) : boolean; forward;


function comptypes;{111}
     var
	       comp : boolean;
     begin
     if (t1 = nil) or (t2 = nil) or (t1 = t2)
	  then comp := true
     else if t1^.form = t2^.form
	  then case t1^.form of
subranges : comp := comptypes(t1^.rangetype, t2^.rangetype);
sets      : if t1^.setpacked = t2^.setpacked
	  then comp := comptypes(t1^.basetype, t2^.basetype)
     else comp := false;
arrays    : comp := (isstring(t1) and isstring(t2));
pointers  : comp := (t1^.domaintype = nil) or (t2^.domaintype = nil);
     scalars,
	  records,
	  files,
	  varparts,
     variant   : comp := (t1^.desc.kind=reals)and(t2^.desc.kind=reals)
     end
     else begin {not identical but possibly subranges}
	  if t1^.form = subranges
	       then comp := comptypes(t1^.rangetype, t2)
	  else if t2^.form = subranges
	       then comp := comptypes(t1, t2^.rangetype)
	  else comp := false;
	  end;
     comptypes := comp
     end;

function isstring;{112}
     begin
     isstring := false;
     if entry <> nil
	  then with entry^ do
	  if form = arrays
	  then if (elemtype = chartype)and arrpacked
	  then with indextype^ do
	  if form = subranges
	  then if comptypes(rangetype, inttype) and (min = 1)
	  then isstring := true
     end;


   function newstring: typentry;{113}
     var
	       length : integer;
	  indexentry, arrayentry : typentry;
     begin
     length := constant.length;
     indexentry := newtype( subranges);
     with indexentry^ do
	  begin
	  rangetype := inttype;
	  min := 1;
	  max := length;
	  desc := intdesc;
	  with desc do
	       begin
	       min := 1;
	       max := length
	       end
	  end;
     arrayentry := newtype(arrays);
     with arrayentry^ do
	  begin
	  desc.size:=length;
	  arrpacked := true;
	  indextype := indexentry;
	  elemtype := chartype;
	  desc := stringdesc;
	   xxstringaslit
	  end;
     newstring := arrayentry
     end;

procedure newfile(entry : identry); {114}
     var
	       endloop : boolean;
	  f : filentry;
	  fname : mutlname;
     begin
     endloop := false;
     f := permfileroot;
     while (f <> nil) and (not endloop) do
	  with f^ do
	if equal(name,idrecs[entry].iindex,idrecs[entry].length)
	  then begin
	  declared := true;
	  endloop := true
	  end
     else f := next;
     if endloop
	  then chainid(pfileidchain, entry)
     else chainid(display[top].filechain, entry);
     with idrecs[entry] do
	  begin
	  varkind := filevar;
	reffilevar := false;
	  permanent := endloop;
xxstaticstoreallocation(entry,filetypename,0,tlname);
if permanent then
(***)begin
xxstaticstoreallocation(nullsymbname, cccharbasictype, -1, fname);
tlclits(cccharbasictype, addbound(idarray[f^.mussequiv+1],f^.length));
tlass(fname, -1);
tlassvalue(0,1);
tlassend;
xxsetaregmode(ccpointerbasictype);
plantname(loadref, a, fname);
plantname(loadref,d,tlname);
plantname(selfld,d,2);
plantname(store, a, ccitemreferenced);
end;
plantname(loadref,d,tlname);
plantname(selfld,d,0);
if permanent then tlclit32(ccint16basictype,0)
else tlclit32(ccint16basictype,6);
xxsetaregmode(ccint16basictype);
plantname(load,a,0);
plantname(store,a,ccitemreferenced);
plantname(loadref,d,tlname);
plantname(selfld,d,1);
tlclit32(ccint16basictype,999);
plantname(load,a,0);
plantname(store,a,ccitemreferenced);
 if idtype^.sequence in [units,recs] then {issue 11}
  begin
   xxstaticstoreallocation(nullsymbname,idtype^.componenttype^.desc.typename,
      0,fname);
   xxsetaregmode(ccpointerbasictype);
   plantname(loadref,a,fname);
	plantname(loadref,d,tlname);
   plantname(selfld,d,3);
   plantname(selalt,d,7);
   plantname(selfld,d,0);
   plantname(store, a, ccitemreferenced)
 end {issue 11}
end
end;

    procedure checkmonadicoperand(op : opkind; operandtype : typentry;  var res
type : typentry);{115}
     begin
     restype := nil;
     if operandtype <> nil
	  then case op of
scalararithmetic  : if comptypes(operandtype, real32type)
	  then restype := operandtype
     else if comptypes(operandtype, inttype)
	  then restype := inttype
     else error(65);
scalarlogical     : if comptypes(operandtype, booltype)
	  then restype := booltype
     else error(65)
     end;
     end;


procedure checkdyadicoperands(op : opkind; var operator : optype; t1, t2 : typen
try;  var restype : typentry);{116}
var
    d : descriptor;
    entry : stackentry;

     procedure intrealconversion;{117}
	  begin
	  if comptypes(t1, real32type) or comptypes(t2, real32type)
	       then if comptypes(t1, inttype)
	       then begin
	       float(topstackentry^.next, t2);
	       restype := t2
	       end
	  else if comptypes(t2, inttype)
	       then begin
	       float(topstackentry, t1);
	       restype := t1
	       end
	  else error(65)
	  else error(60)
	  end;




     begin { checkdyadicoperands }
     restype := nil;
     if (t1 <> nil) and (t2 <> nil)
	  then case op of
     scalararithmetic  : begin
	  if comptypes(t1, t2)
	       then begin
		if comptypes(t1,inttype) then
		  begin
	        topstackentry^.desc.typename := ccintbasictype;
	        topstackentry^.next^.desc.typename := ccintbasictype;
	       if operator = rdiv
	       then begin
	       float(topstackentry, idrecs[realid].idtype);
	       float(topstackentry^.next, idrecs[realid].idtype);
	       restype := idrecs[realid].idtype
	       end
	  else restype := inttype
	  end
	  else if comptypes(t1, real32type)
	       then restype := t1
	  else error(65)
	end
	  else intrealconversion ;					
	  if comptypes(restype , real32type)
	       then if operator = idiv
	       then begin
	       error(65);
	       operator := rdiv
	       end
	  else if operator = modop
	       then error(65)
	  end;
scalarlogical     : if comptypes(t1, booltype) and comptypes(t2, booltype)
	  then restype := booltype
     else error(65);
scalarassignment  : if comptypes(t1, t2)
	  then begin
	if t1^.desc.typename <> t2^.desc.typename then
	if assigntype = 0 then
	   xxconvaregmode(topstackentry,0,t1);
	restype := t1
		end
     else if comptypes(t1, real32type) and
	  comptypes(t2, inttype)
	  then begin
	  float(topstackentry, t1);
	  restype := t1
	  end
     else error(60);
scalarcomparison  : if comptypes(t1, t2)
	  then begin
restype := t1;
if t1^.desc.kind = ordinal then
if t1^.desc.typename > t2^.desc.typename then
		begin
		restype := t1;
		xxconvaregmode(topstackentry,0,t1)
		end
	     else if t1^.desc.typename < t2^.desc.typename then
		begin
		xxconvaregmode(topstackentry^.next,0,t2);
		restype := t2
		end
end
     else intrealconversion;
     pointerassignment,
     pointercomparison : begin
	  if comptypes(t1, t2)
	       then begin
			restype := t1;
			if topstackentry^.kind = konstant then
			   topstackentry^.desc := topstackentry^.next^.desc
			else if topstackentry^.next^.kind = konstant then
				topstackentry^.next^.desc := topstackentry^.desc
			end
	  else error(60);
	  if not (operator in [eqop, neop, notop])
	       then begin
	       error(62);
	       restype := nil
	       end
	  end;
     setarithmetic,
     setcomparison     : begin
	  if comptypes(t1, t2)
	       then if t1^.desc.typename > t2^.desc.typename then
		begin
		plantentry(load,a,topstackentry);
		restype := t1;
		xxconvsettype(areg,t2^.desc.typename,t1^.desc.typename);
entryusing[a] := topstackentry;
		with topstackentry^ do
		begin
		kind := data;
		datainreg := true;
		register := a;
		desc := t1^.desc
		end
		end
	     else if t1^.desc.typename < t2^.desc.typename then
		begin
		plantentry(load,a,topstackentry^.next);
		xxconvsettype(areg,t1^.desc.typename,t2^.desc.typename);
entryusing[a] := topstackentry^.next;
		with topstackentry^.next^ do
		begin
		kind := data;
		datainreg := true;
		register := a;
		desc := t2^.desc
		end;
		restype := t2
		end
	     else restype := t1
	  else error(60);
	  if operator in [ltop, gtop]
	       then begin
	       error(62);
	       restype := nil
	       end
	  end;
inset             : if t2^.form = sets
	  then if comptypes(t1, t2^.basetype)
	  then begin
	 restype := t1;
	if checking then
	   begin
	   d := t2^.basetype^.desc;
	   with d do
	      begin
	      if min < minsetelement then
		min := minsetelement;
	      if max > maxsetelement then
		max := maxsetelement;
	      end;
	   entry := unstack;
	   check(d);
	   stack(entry)
	   end
	end
     else error(60)
     else error(61);
setassignment     : if comptypes(t1, t2)
	  then begin
	plantentry(load,a,topstackentry);
	xxconvsettype(areg,t2^.desc.typename, t1^.desc.typename);
entryusing[a] := topstackentry;
	with topstackentry^ do
	begin
	kind := data;
	datainreg := true;
	register := a;
	desc := t1^.desc
	end;
	restype := t1
	end
     else error(60);
     strcomparison,
     stringassignment  : if isstring(t1) and isstring(t2)
        then if t1^.indextype^.max = t2^.indextype^.max
       	  then restype := t1
              else error(60)
     else error(65);
confassignment, structassignment  : if comptypes(t1, t2)
	  then restype := t1
     else error(60);
end
     end; { checkdiadicoperands }

function entryfortypename( name : integer) : typentry;{118}
     var temp : typentry;
     begin
     if (name = ccintbasictype)  or (name = ccintbasictype + %40)
	  then entryfortypename := inttype
     else if (name = ccrealbasictype)
	  then entryfortypename := idrecs[realid].idtype
     else if name = cccharbasictype
	  then entryfortypename := chartype
     else if name = ccboolbasictype
	  then entryfortypename := booltype
     else begin
		if name >= %80 then name := name - %40;
		if name in [ccint8basictype,
		ccint16basictype,ccint32basictype]
	then begin
	temp := newtype(subranges);
	with temp^ do
	  begin
	  rangetype := inttype;
	  min := -maxint;
	  max := maxint;
	  desc.vector := false;
	  desc.typename := name
	  end;
	entryfortypename := temp
	end
     else entryfortypename := nil
	end
     end;

procedure inlibrary;{119}
     var
	       restype : typentry;
	  formalbase, newformal, lastformal : formalentry;
	  temp, i, noparams, restypename : integer;
{issue 11} libindex : lo32;
     begin

     if declared
	  then begin
	  with idrecs[entry] do
	       begin {find name in muss library directory}
		libindex := findn(addbound(idarray[iindex+1],length),0);
{issue 11} if libindex = [] 		then error(35)
	       else begin
		    formalbase := decl^.formalroot;
		    if idtype = nil
			 then restypename := 0
		    else restypename := idtype^.desc.typename;
		    end
	       end;
{issue 11}	if libindex <>  []
	       then begin {check consistency of parameters with muss library}
	       i := 0;
	       noparams := findp(libindex, -1, 0);
	       while (formalbase <> nil) and (i < noparams) do
		    begin
		    i := i + 1;
		    with formalbase^ do
			 begin
			 temp := findp(libindex, -1, i);
			if temp <> ptypename
			      then begin
			writeln;
			outpagelineno(currentpageno,currentlineno);{issue11}
		writeln('>>** warning : parameter of external proc not of declared type ');
				if temp < 256 then ptypename := temp
				end;
			 formalbase := next
			 end
		    end;
	       if (formalbase <> nil) or (i <> noparams)
		    then error(57);
	        temp := findp(libindex, -1,noparams + 1);
			if temp <> restypename then
			begin
			writeln;
			outpagelineno(currentpageno,currentlineno);{issue11}
			writeln('>>>** warning : result of external func not of declared type');
			restypename := temp
			end
	       end
	  end
     else begin
	  libindex := findn(addbound(idarray[idindex+1],idnamelength),0);
{issue 11}	if libindex <> []
	       then begin {create parameter properties from muss library}
	       noparams := findp(libindex, -1, 0);
		restypename := findp(libindex, -1, noparams +1);
		restype := entryfortypename(restypename);
	       i := 1;
	       formalbase := nil;
	       lastformal := nil;
	       while i <= noparams do
		    begin
		    new(newformal);
		    with newformal^ do
			 begin
			 next := nil;
			 id := -1;
			 ptypename := findp(libindex, -1, i);
			 ptype := {entryfortypename(ptypename)}nil;
			 kind := valparam
			 end;
		    if lastformal = nil
			 then formalbase := newformal
		    else lastformal^.next := newformal;
		    lastformal := newformal;
		    i := i + 1
		    end;
	       if restypename = 0
		    then entry := newid(proc)
	       else entry := newid(func);
	       with idrecs[entry] do
		    begin
		    if restype <> nil then idtype := restype
				else if restypename = ccpointerbasictype then
				idtype := pointertype;
		    notyetdefined := false;

		    decl^.formalroot := formalbase
		    end
	       end
	  end;
{issue 11}  if libindex = []
	  then inlib := false
     else begin {declare library proc to mutl}
	  inlib := true;
	  idrecs[entry].decl^.external := true;
      idrecs[entry].decl^.restypnm := restypename;
	  xxprocspecification(entry);
	  end;
     end;


procedure accept(symbolexpected : symboltype);{120}

(*$S5*)
     begin
     if symbol = symbolexpected
	 then insymbol
     else error(missingsymbolerrorcode[symbolexpected]);
     end;

procedure skip(symbolsexpected : setofsymbols);{121}
     begin
     while not (symbol in symbolsexpected) do
	  insymbol
     end;

procedure checkexpectedsymbols(symbolsexpected : setofsymbols);{122}
     begin
     if not (symbol in symbolsexpected)
	  then begin
	  error(6);
	  skip(symbolsexpected)
	  end
     end;

procedure checkpossiblesymbols(expectedsymbols, possiblesymbols : setofsymbols);
{123}
     begin
     if not (symbol in expectedsymbols)
	  then begin
	  error(6);
	  skip(expectedsymbols + possiblesymbols)
	  end
     end;

procedure checksymbol(symbolexpected : symboltype; symbolsexpected : setofsymbol
s);{124}
     begin
     if symbol = symbolexpected
	  then begin
	  insymbol;
	  checkexpectedsymbols(symbolsexpected)
	  end
     else error(missingsymbolerrorcode[symbolexpected])
     end;


{new procedure to improve code for closing files}
procedure closefile(id:identry);{125}
begin
xxplant(stkl,pclosetlname);
xxsetaregmode(ccunboundeditempointer);
with idrecs[id] do
  if reffilevar then plantname(load,a,tlname)
  else plantname(loadref,a,tlname);
xxplant(stkpar,areg);
tlclit32(ccint,2);
stacknamedparam(0,ccint);
stacknamedparam(zerotlname,ccint);
stacknamedparam(zerotlname,ccint);
xxendproccallseq(0)
end;
procedure releasefiles(root:identry);{126}
begin
while root <> -1 do
begin
closefile(root);
root := idrecs[root].next
end
end;

        procedure programm;{127}
(*$S1*)

     var
	       fileentry : filentry;
	  progid : identry;
	  apsymbols, bpsymbols : setofsymbols;
	
     procedure block(blocksymbols : setofsymbols; endblocksymbol : symboltype; d
blockid : identry);{128}
	  type
		    domentry = ^domainrec;
	       domainrec = record
		    iindex,length : idarrlength;
		    name : identname;
		    signature : integer16;
		    pointerentry : typentry;
		    next : domentry
		    end;
	  var
		labroot : labelentry;
		    lblocksymbols : setofsymbols;
	       domainroot : domentry;
	       {endtypedefinition : boolean;}
	
	  	  procedure inconstant(symbols : setofsymbols;  var ct : typentry; var c :
constrec);{129}
	       var
			 t : typentry;
		    id : identry;
		    sign, negsign : boolean;
	       begin
	       t := nil;
	       c := defaulconstant;
	       checkpossiblesymbols(constbegsys, symbols);
	       if symbol in constbegsys
		    then begin
		    if symbol = charconst
			 then begin
			 t := chartype;
			 c := constant;
			 insymbol
			 end
		    else if symbol = stringconst
			 then begin
			 t:= newstring;
			 c := constant;
			 insymbol
			 end
		    else begin
			 if symbol = addop {signed constant}
			      then begin
			      sign := true;
			      negsign := (operator = minus);
			      insymbol
			      end
			 else sign := false;
			 if symbol = ident
			      then begin
			      id := searchid([consts]);
			      insymbol;
			      with idrecs[id] do
				   begin
				   if notyetdefined then error(18);
				   t:= idtype;
				   c := val
				   end
			      end
			 else if symbol = intconst
			      then begin
			      t := inttype;
			      c := constant;
			      insymbol
			      end
			 else if symbol = realconst
			      then begin
			
			      t := realcompiletimetype;{issue 11}
			      c := constant;
			      insymbol
			      end
			 else begin
			      error(22);
			      skip(symbols)
			      end;
			 if sign
			      then with c do
			      if not (kind in [intkind, realkind])
			      then begin
			      error(36);
			      skip(symbols)
			      end
			 else if negsign
			      then if kind = intkind
			      then ival := - ival
			 else if kind = realkind
			      then rval := - rval;
			 end;
		    checkexpectedsymbols(symbols)
		    end;
		ct := t
	       end;
	
	  	 function typ(tsymbols : setofsymbols;  symbname : identry): typentry;{130}

(*$S5*)
	       var
			 typeobtained,varpentry,elementtype, arrayentry, lastarrayentry, indexentry :
 typentry;
		    domainentry : domentry;
		    tempentry, fxdroot,domainid : identry;
		    packtype, endloop : boolean;
		
	       function simpletyp(ssymbols : setofsymbols ): typentry;{131}
		    var
			      i, t : integer;
			 c : constrec;
			 id : identry;
			 entry, stentry : typentry;
			 cchain : idchain;
			
		    procedure newsubrange(lowtype : typentry; lowbound : integer);{132}
			 begin
			 accept(ddot);
			 inconstant(ssymbols, entry, c);
			 stentry := newtype(subranges);
			 with stentry^ do
			      begin
			      min := lowbound;
			      if comptypes(lowtype, entry)
(*kvmod*)                      and (entry <> nil)
				   then if entry^.desc.kind = ordinal
				   then begin
				   max := constval(c);
				   rangetype := entry
				   end
			      else begin
				   error(77);
				   rangetype := nil
				   end
			      else error(60);
			      if min > max
				   then begin
				   error(33);
				   min := max
				   end
			      end;
			 getdescriptor(stentry, symbname)
			 end;
		
		    begin { simpletyp }
		    checkpossiblesymbols(simptypebegsys, ssymbols);
		    if symbol in simptypebegsys
			 then begin
			 if symbol = leftparent {enumerated type}
			      then begin
			      t := top;
			      top := level;
			      initidchain(cchain);
			      stentry := newtype(scalars);
			      repeat
				   insymbol;
				   if symbol = ident
					then begin
					id := newid(consts);
					idrecs[id].notyetdefined := false;
					idrecs[id].idtype := stentry;
					chainid(cchain, id);
					insymbol
					end
				   else error(2);
				   checkexpectedsymbols(ssymbols + [comma, rightparent])
			      until symbol <> comma;
			      stentry^.constidroot := cchain.head;
			      getdescriptor(stentry, symbname);
			      accept(rightparent);
			      top := t
			      end
			 else if symbol = ident {previously declared type or new subrange}
			      then begin
			      id := searchid([types, consts]);
			      insymbol;
			      with idrecs[id] do
				   if class = consts {subrange}
				   then newsubrange(idtype, val.ival)
			      else begin
				if notyetdefined then
				   error(18);
stentry := idtype
				end
			      end
			 else begin {subrange of integer type}
			      inconstant(ssymbols + [ddot], entry, c);
			      if entry^.desc.kind <> ordinal then
				 begin
				 stentry := nil;
				 error(44)
				 end
			      else newsubrange(entry,constval(c));
			      end;
			 simpletyp := stentry;
			 checkexpectedsymbols(ssymbols)
			 end
		    else simpletyp := nil
		    end; { simpletyp }
	       	
	       procedure fieldlist(fsymbols : setofsymbols;  fixedroot : identry;  vpen
try : typentry);{133}
		    var
			      endinnerloop, endouterloop : boolean;
			 cv, lb, hb, i, ser : integer;
			 c : constrec;
			 fieldtype, tagtype, ct, varentry, varroot, thisvarroot,
			      lastvarentry, thislastvarentry, svpentry : typentry;
			 fieldchain, sametypefields : idchain;
			 tempentry, fieldentry, fxroot, tagid : identry;
			
		    procedure reversetypechain(root : typentry;  var newroot : typentry);{134}
			 var
				   p, q : typentry;
			 begin
			 p := nil;
			 while root <> nil do
			      begin
			      q := root^.nextvariant;
			      root^.nextvariant := p;
			      p := root;
			      root := q;
			      end;
			newroot := p
			 end;
		
		    begin    { fieldlist }
(*kvmod*)         fxroot := -1;
		    ser := - 1;
		    checkexpectedsymbols(fsymbols + [ident, casesy,semicolon]);
		    initidchain(fieldchain);
		    while symbol = ident do {create chain of identrys to describe fields}
			 begin
			 endouterloop := false;
			 initidchain(sametypefields);
			 while not endouterloop do
			      begin
			      if symbol = ident
				   then begin
				   fieldentry := newid(field);
				   ser := ser + 1;
				   idrecs[fieldentry].serial := ser;
				   chainid(sametypefields, fieldentry);
				   insymbol
				   end
			      else error(2);
			      checkpossiblesymbols([comma, colon], fsymbols + [semicolon, casesy]);
			      if symbol = comma
				   then insymbol
			      else endouterloop := true
			      end;
			 accept(colon);
			 fieldtype := typ(fsymbols + [casesy, semicolon], nullsymbname);
			 fieldentry := sametypefields.head;
			 while fieldentry <> -1 do
			      with idrecs[fieldentry] do
			      begin
			      idtype := fieldtype;
			      fieldentry := next
			      end;
			 linkidchains(fieldchain, sametypefields);
			 if symbol = semicolon
			      then begin
			      insymbol;
			      checkpossiblesymbols([ident, casesy,endsy, rightparent], fsymbols)
			      end
			 else if symbol = casesy
			      then error(14)
			 end;  { while symbol = ident }
		    reverseidchain(fieldchain.head, fixedroot);
		    if symbol = casesy {record has variants}
			 then begin
			 insymbol;
			 vpentry := newtype(varparts);
			 if symbol = ident
			      then begin
			      createidentry := false;
			      tagid := searchid([types]);
			      createidentry := true;
                             if tagid <> -1 then insymbol;
			      if (tagid = -1) or (symbol = colon)
				   then begin
				   tagid := newid(field);
				idrecs[tagid].tagf := true;
				   ser := ser + 1;
				   idrecs[tagid].serial := ser;
				   if symbol <> colon then insymbol;
				   accept(colon);
				   tagtype :=simpletyp(fsymbols + [ofsy, leftparent]);
				   end
			      else begin
				   tagtype := idrecs[tagid].idtype;
				   tagid := -1
				   end;
			      if tagtype <> nil
				   then if tagtype^.desc.kind = ordinal
				   then begin
				   if tagid <> -1
					then idrecs[tagid].idtype := tagtype;
				   vpentry^.tagfield := tagid;
				if tagtype = inttype then
				begin
				lb := -maxint;
				hb := maxint;
				end
				else begin
				lb := tagtype^.desc.min;
				hb := tagtype^.desc.max
				end;
				   ser := ser + 1;
				   vpentry^.serial := ser
				   end
			      else error(41)
			      end
			 else begin
			      error(2);
			      skip(fsymbols + [ofsy, leftparent])
			      end;
			 accept(ofsy); {start of variant list}
			 varroot := nil;
			 i := - 1;
			 lastvarentry := nil;
			 endouterloop := false;
			 repeat
			      thisvarroot := nil;
			      i := i + 1;
			      endinnerloop := false;
			      repeat
				   inconstant(fsymbols + [comma, colon, leftparent], ct, c);
				   if not comptypes(tagtype, ct)
					then error(60);
				   varentry := newtype(variant);
				   with varentry^ do
					begin
					val := c;
				cv := constval(c);
				if (cv < lb) or (cv > hb) then error(107);
					distinctvariantcount := i
					end;
				   if thisvarroot = nil
					then thisvarroot := varentry
				   else thislastvarentry^.nextvariant := varentry;
				   thislastvarentry := varentry;
				   if symbol = comma
					then insymbol
				   else endinnerloop := true
			      until endinnerloop;
			      accept(colon);
			      accept(leftparent);
			      fieldlist(fsymbols + [rightparent, semicolon], fxroot, svpentry);
fxroot := fxdroot;svpentry := varpentry;

			      varentry := thisvarroot;
			      while varentry <> nil do
				   with varentry^ do
				   begin
				   subvarpart := svpentry;
				   varfieldroot := fxroot;
				   varentry := nextvariant
				   end;
			      if thisvarroot <> nil
				   then thisvarroot^.aslastvariant := false;
			      if varroot = nil
				   then varroot := thisvarroot
			      else lastvarentry^.nextvariant := thisvarroot;
			      lastvarentry := thislastvarentry;
			      checksymbol(rightparent, fsymbols + [semicolon]);
			      if symbol = semicolon
				   then insymbol
			      else endouterloop := true;
			      if symbol = endsy then endouterloop := true
			 until endouterloop;
			 reversetypechain(varroot, vpentry^.variantroot)
			 end  { if symbol = casesy }
		    else vpentry := nil;
fxdroot := fixedroot;varpentry := vpentry;

		    end; {fieldlist}
	       
	       begin { typ }
	       packtype := false;
	       checkpossiblesymbols(typebegsys, tsymbols);
	       if symbol in typebegsys
		    then begin
		    if symbol in simptypebegsys
			 then typeobtained :=simpletyp(tsymbols)
		    else if symbol = arrow {pointer type}
			 then begin
			 typeobtained := newtype(pointers);
			 insymbol;
			 if symbol = ident
			      then begin
			      if endtypedefinition
				   then begin
				   domainid := searchid([types]);
				   typeobtained^.domaintype := idrecs[domainid].idtype
				   end
			      else begin
				   new(domainentry);
				   with domainentry^ do
					begin
					iindex := idindex;
					length := idnamelength;
					idindex := idindex + idnamelength;
					name := idname;
					signature := sig;
					pointerentry := typeobtained;
					next := domainroot
					end;
				   domainroot := domainentry
				   end;
			      insymbol
			      end
			 else error(2);
			 getdescriptor(typeobtained, symbname)
			 end
		    else begin
			 if symbol = packedsy
			      then begin
			      packtype := true;
			      insymbol;
			      end;
			 checkpossiblesymbols(typedeclsys, tsymbols);
			 if symbol in typedeclsys {structured type}
			      then case symbol of
			 arraysy  : begin
			      insymbol;
			      accept(leftbracket);
			      lastarrayentry := nil;
			      endloop := false;
			      repeat
				   arrayentry := newtype(arrays);
				   arrayentry^.elemtype := lastarrayentry;
				   lastarrayentry := arrayentry;
				   indexentry := simpletyp(tsymbols + [comma, rightbracket, ofsy]);
				   if indexentry <> nil
					then if indexentry^.desc.kind = ordinal
					then arrayentry^.indextype := indexentry
				   else error(44);
				   if symbol = comma
					then insymbol
				   else endloop := true
			      until endloop;
			      accept(rightbracket);
			      accept(ofsy);
			      elementtype :=typ(tsymbols, nullsymbname);
			      repeat
				   lastarrayentry := arrayentry^.elemtype;
				   arrayentry^.elemtype := elementtype;
				   arrayentry^.arrpacked := packtype;
				   getdescriptor(arrayentry, nullsymbname);
				   elementtype := arrayentry;
				   arrayentry := lastarrayentry
			      until arrayentry = nil;
			      typeobtained := elementtype
			      end;
			 recordsy : begin
			      withtop := withtop - 1;
			      insymbol;
			      openscope(withst);
			      typeobtained := newtype(records);
			      with typeobtained^ do
				   begin
				   recpacked := packtype;
				   fieldlist(tsymbols + [endsy] - [semicolon], fixedfieldroot, varpart);
				   fixedfieldroot := fxdroot;varpart := varpentry;
				   fieldscope := display[top].idscope
				   end;
			      closescope;
				if typeobtained^.fieldscope <> -1 then
			      for tempentry := typeobtained^.fieldscope to topid do
				if idrecs[tempentry].class = field then
				idrecs[tempentry].textlevel := withtop;
			      withtop := withtop + 1;
			  if symbol = semicolon then insymbol;
			      accept(endsy);
			      getdescriptor(typeobtained, symbname)
			      end;
			 setsy     : begin
			      insymbol;
			      accept(ofsy);
			      typeobtained := newtype(sets);
			      typeobtained^.setpacked := packtype;
			      elementtype :=simpletyp(tsymbols);
			      if elementtype <> nil
				   then if elementtype^.desc.kind = ordinal
				   then typeobtained^.basetype := elementtype
			      else error(46);
			      getdescriptor(typeobtained, symbname)
			      end;
			 filesy    : begin
			      insymbol;
			      accept(ofsy);
			      elementtype :=typ(tsymbols, nullsymbname);
			      typeobtained := newtype(files);
			      if elementtype <> nil
				   then if elementtype^.form = files
				   then error(39)
			      else with typeobtained^ do
				   begin
				   componenttype := elementtype;
				if comptypes(elementtype,chartype) then bufalt := 0
				else if comptypes(elementtype,booltype) then bufalt := 1
				else if comptypes(elementtype,inttype) then
				begin if ccint =ccint16basictype then
					bufalt := 2 else bufalt := 3
				end{issue 11}
				else if comptypes(elementtype,real32type) then
				begin if ccrealbasictype = %c then bufalt := 4 else bufalt := 5 end

				else if elementtype^.form = arrays then bufalt := 6
				else bufalt := 7;
				if bufalt = 0 then sequence := chars
				else if bufalt < 6 then sequence := binary
				else sequence := units;
				   end;
			      getdescriptor(typeobtained, symbname)
			      end
			 end
			 else typeobtained := nil
			 end;
		    checkexpectedsymbols(tsymbols)
		    end
	       else typeobtained := nil;
typ := typeobtained
	       end; { typ }
	
	  	 procedure labeldeclaration;{135}
	       var
			 entry : labelentry;
	       begin
	       repeat
		    insymbol;
		    if symbol = intconst
			 then begin
			 entry := newlabel;
			 insymbol
			 end
		    else error(15);
		    checkexpectedsymbols(lblocksymbols + [comma, semicolon])
	       until symbol <> comma;
	       checksymbol(semicolon, lblocksymbols)
	       end;
	
	  procedure constdefinition;{136}
	       var
			 c : constrec;
		    t : typentry;
		    id : identry;
	       begin
	       insymbol;
	       if symbol <> ident
		    then begin
		    error(2);
		    skip(lblocksymbols + [ident])
		    end;
	       while symbol = ident do
		    begin
		    id := newid(consts);
		    insymbol;
		    if (symbol = relop) and (operator = eqop)
			 then insymbol
		    else error(16);
		    inconstant(lblocksymbols + [semicolon], t, c);
		    with idrecs[id] do
			 begin
			 notyetdefined := false;
			 idtype := t;
			 val := c
			 end;
		    checksymbol(semicolon, lblocksymbols + [ident])
		    end
	       end;
	
	  procedure typedefinition;{137}
	       var
		    saveindex : idarrlength;
			 typeobtained : typentry;
		    id : identry;
		    domainentry : domentry;
	       begin
	       insymbol;
	       if symbol <> ident
		    then begin
		    error(2);
		    skip(lblocksymbols + [ident])
		    end;
	       while symbol = ident do
		    begin
		    id := newid(types);
		    insymbol;
		    if (symbol = relop) and (operator = eqop)
			 then insymbol
		    else error(16);
		    with idrecs[id] do
			begin
			 idtype :=typ(lblocksymbols + [semicolon], id);
			notyetdefined := false
			end;
		    checksymbol(semicolon, lblocksymbols + [ident])
		    end;
	       forwardref := true;
	       while domainroot <> nil do
		    with domainroot^ do
		    begin
		    idname := name;
		    saveindex := idindex;
		    idindex := iindex;
		    idnamelength := length;
		    sig := signature;
		    id := searchid([types]);
		    idindex := saveindex;
		    with pointerentry^, idrecs[id] do
			 begin
			 domaintype := idtype;
if idtype^.form = arrays then
   desc.dimen := idtype^.desc.size
else desc.dimen := 0;
			if idtype^.form = pointers then
			   desc.domtypename :=
				xxpointertypedecl(idtype^.desc.typename)
			 else desc.domtypename := idtype^.desc.typename
			 end;
		    domainentry := domainroot;
		    domainroot := next;
		    dispose(domainentry)
		    end;
	       forwardref := false
	       end;
	
	  procedure vardeclaration;{138}
	       var
			 vartype : typentry;
		    i,id : identry;
		    endloop : boolean;
		    sametypeids : idchain;
		    avsymbols, bvsymbols : setofsymbols;
	       begin
	       avsymbols := lblocksymbols + typedeclsys;
	       bvsymbols := avsymbols + [comma, colon];
	       insymbol;
	       repeat {until no more variables to be declared}
		    initidchain(sametypeids);
		    endloop := false;
		    while not endloop do {list of variables of same type}
			 begin
			 if symbol = ident
			      then begin
			      id := newid(vars);
			      chainid(sametypeids, id);
			      insymbol
			      end
			 else error(2);
			 checkpossiblesymbols(bvsymbols, [semicolon]);
			 if symbol = comma
			      then insymbol
			 else endloop := true
			 end; {end of list of variables of same type}
		    accept(colon);
		    vartype :=typ(avsymbols + [semicolon], nullsymbname);
		    id := sametypeids.head;
		    while id <> -1 do
			 with idrecs[id] do
			 begin
			 idtype := vartype;
			 if vartype <> nil
			      then with vartype^ do
			      if form = files
			      then newfile(id)
			 else if form = arrays then
			 begin
			xxstaticstoreallocation(id,desc.typename,desc.size,tlname);
			if (elemtype^.form = pointers) and checking then
			  begin
			  tlcnull(desctypename(elemtype^.desc));
			  tlass(tlname,-2);
			  tlassvalue(0,desc.size)
			  end
			end
			 else if form = sets then
			    if setpacked then
				xxstaticstoreallocation(id,desc.packname,0,tlname)
			    else xxstaticstoreallocation(id,desc.typename,0,tlname)
			else xxstaticstoreallocation(id, desc.typename, 0, tlname);
			if checking then
			 if vartype^.form = pointers then
			   begin
			   xxsetaregmode(desctypename(vartype^.desc));
			   tlcnull(aregmode);
			   plantname(load,a,0);
			   plantname(store,a,tlname)
			   end
			else if vartype^.form = records then
			   begin
			   i := vartype^.fieldscope;
			   while (idrecs[i].class <= field) and (i <= topid) do
			   begin
			   if idrecs[i].class= field then
				with idrecs[i] do
				if idtype^.form = pointers then
				  begin
				  stackvariable(idrecs[id].tlname,vartype^.desc);
				  fieldreference(selectroot,idtype^.desc);
				  xxsetaregmode(desctypename(idtype^.desc));
				  tlcnull(aregmode);
				  plantname(load,a,0);
				  plantentry(store,a,topstackentry)
				  end;
				i := i + 1
			   end
			end;
			 id := next
			 end;
		    checksymbol(semicolon, lblocksymbols + [ident])
	       until (symbol <> ident) and (not (symbol in typedeclsys)) {until no more
 variables to be declared}
	       end;
(*kvrm *)
	  **in -1
