(* kvrm*)
	 procedure procdeclaration;{139}
	       var
		 earlierdeclared, extproc, forproc, conformant : boolean;
		    typeobtained : typentry;
		    saveid, savetop, id : identry;
		    exsymbol : symboltype;
		

{new proc to deal with conformant array param declaration }
function conformtype(var pidchain : idchain) : typentry;{140}
var
   elemid, typid,first,last : identry;
   thistype, lasttype, elementtype : typentry;
   endloop, packedparam : boolean;
begin
if symbol = packedsy then
   begin
   packedparam := true;
   insymbol
   end
else packedparam := false;
accept(arraysy);
accept(leftbracket);
lasttype := nil;
(*kvmod*)elementtype := nil;
endloop := false;
repeat
   level := level -1;
   thistype := newtype(arrays);
   level := level + 1;
   thistype^.elemtype := lasttype;
   lasttype := thistype;
   if symbol = ident then
      begin
      first := newid(vars);
      insymbol;
      chainid(pidchain,first);
      accept(ddot);
      thistype^.low := first;
      if symbol = ident then
	  begin
	  last := newid(vars);
	  insymbol;
	  chainid(pidchain,last);
	  thistype^.high := last;
(*kvmod *)  if symbol = colon then
(*kvmod *)     accept(colon) else
(*kvmod *)  begin accept(colon);
(*kvmod *)        insymbol;
(*kvmod *)  end;
	  if symbol = ident then
	     begin
	     typid := searchid([types]);
	   insymbol;
	     with idrecs[typid] do
		begin
		idrecs[first].idtype := idtype;
		idrecs[last].idtype := idtype;
		if idtype^.desc.kind = ordinal then
		   thistype^.indextype := idtype
		else error(44);
		end
	     end
	  else error(2)
         end
      else error(2)
      end
   else error(2);
   if symbol = semicolon then insymbol
   else endloop := true
   until endloop;
accept(rightbracket);
accept(ofsy);
if symbol = ident then
   begin
   elemid := searchid([types]);
   elementtype := idrecs[elemid].idtype;
   insymbol

   end
else if symbol in [packedsy, arraysy] then
      elementtype := conformtype(pidchain)
      else error(2);
(*kvmod*)if elementtype <> nil then
repeat
   lasttype := thistype^.elemtype;
   thistype^.elemtype := elementtype;
   with thistype^.desc do
      begin
      vector := true;
      kind := struct;
      if thistype^.elemtype^.form = pointers then
	  typename := xxpointertypedecl(typename)
      else typename := thistype^.elemtype^.desc.typename;
      size := -1
      end;
   thistype^.desc.size := -1;
   thistype^.arrpacked := packedparam;
   elementtype := thistype;
   thistype := lasttype
until thistype = nil;
conformtype := elementtype
end;

	       procedure obtaintype(isrestype : boolean; idroot : identry);{141}
		    var
			      id : identry;
		    begin
		    typeobtained := nil;
		    conformant := false;
		    if symbol = ident then
			      begin
			 id := searchid([types]);
			 typeobtained := idrecs[id].idtype;
			 insymbol
			 end
		       else error(2);
		    if isrestype
			 then if typeobtained <> nil
			 then if typeobtained^.desc.kind = struct
			 then begin
			 error(51);
			 typeobtained := nil;
			 end;
		    while idroot <> -1 do
			 with idrecs[idroot] do
			 begin
			 idtype := typeobtained;
			 idroot := next
			 end
		    end;
	
procedure parameterlist(formallist : boolean; psymbols : setofsymbols;	var form
albase : formalentry);{142}
var
     name : integer;
     pkind : paramkind;
     endid, paramid : identry;
     fbase, newformal, thisformal, lastformal: formalentry;
     pidchain : idchain;
     extraparam , endloop : boolean;
     exsymbol : symboltype;
     begin
     formalbase := nil;
     checkpossiblesymbols(psymbols + [leftparent], lblocksymbols);
     if symbol = leftparent {start of parameter list}
	  then begin
	  insymbol;
	  checkpossiblesymbols(parambegsys, lblocksymbols + [rightparent]);
	  while symbol in parambegsys do {while not at the end of the parameter list}
	       begin
	       exsymbol := symbol;
	       case exsymbol of
	       procsy,
	       funcsy : begin
		    conformant := false;
		    insymbol;
		    if symbol = ident
			 then begin
			 if exsymbol = procsy
			      then paramid := newid(proc)
			 else paramid := newid(func);
			 insymbol
			 end
		    else error(2);
		    openscope(pseudobloc);
		    if exsymbol = procsy
			 then begin
			 parameterlist(true, [semicolon,rightparent], fbase);
			 checkexpectedsymbols(lblocksymbols + [semicolon, rightparent]);
			 typeobtained := nil;
			 pkind := procparam
			 end
		    else begin
			 parameterlist(true, [colon, semicolon,rightparent], fbase );
			 if not (symbol in lblocksymbols + [colon])
			      then begin
			      error(6);
			      skip(lblocksymbols + [semicolon, rightparent])
			      end;
			 accept(colon);
			 obtaintype(true, paramid);
			 checkexpectedsymbols(lblocksymbols + [semicolon, rightparent]);
			 pkind := funcparam
			 end;
		    with idrecs[paramid].decl^ do	
			 begin
			 formalroot := fbase;
			 declkind := formal
			 end;
		    name := ccprocpointer;
		    xxprocspecification(paramid); {declare procedure to mutl}
		    disposescope;
		    closescope
		    end;
	       varsy,
	       ident  : begin
		    if symbol = varsy
			 then begin
			 insymbol;
			 pkind := varparam
			 end
		    else pkind := valparam;
		    endloop := false;
		    initidchain(pidchain);
		    while not endloop do {form chain of parameter identifiers of the same type
}
			 begin
			 if symbol = ident
			      then begin
			      paramid := newid(vars);
			      chainid(pidchain, paramid);
			      insymbol
			      end
			 else error(2);
			 if not (symbol in lblocksymbols + [comma, colon])
			      then begin
			      error(7);
			      skip(lblocksymbols + [comma, semicolon, rightparent, arraysy])
			      end;
			 if symbol = comma
			      then insymbol
			 else endloop := true
			 end; {end of list of parameters of the same type}
		    paramid := pidchain.head;
		    endid := pidchain.tail;
		    accept(colon);
		    if symbol in [packedsy, arraysy] then
			begin
			typeobtained := conformtype(pidchain);
			conformant := true
			end
		    else obtaintype(false, paramid);
		    checkexpectedsymbols(lblocksymbols + [semicolon, rightparent]);
		    if typeobtained <> nil
			 then with typeobtained^ do
			 begin
			 if form = files
			 then if pkind = valparam then error(39);
			 if desc.typename = ccundefineditempointer then
			    name := desc.domtypename + ccboundeditempointer
			 else name := desc.typename;
			 if (pkind = varparam) or conformant
			      then if form = arrays then
			name := name + ccboundeditempointer
			 else if form = pointers then
					name := xxpointertypedecl(name) + ccunboundeditempointer
			 else name := name + ccunboundeditempointer
			end
		    end
	       end;
		extraparam := false;
	       while paramid <> -1 do {create chain of formalentrys to describe paramet
er list}
		    begin
		    new(newformal);
		    with newformal^ do
			 begin
			 next := nil;
			 id := paramid;
			 if extraparam then
			    begin
			    conformant := false;
			    ptype := idrecs[paramid].idtype;
			    ptypename := ptype^.desc.typename;
			    pkind := auxparam;
			    kind := auxparam;
			    end
			 else begin
			 ptype := typeobtained;
			 ptypename := name;
			 kind := pkind;
			   end;
			if conformant then
			   begin
			   with idrecs[paramid] do
			      begin
			        idtype := typeobtained;
			      varkind := refvar;
			      conform := true;
			      end;
			   extraparam := paramid = endid;
			   kind := confparam;
			   copy := pkind <> varparam
			   end
			 else if pkind in [procparam, funcparam]
			      then formalroot := fbase
			 else if pkind = varparam
			      then with idrecs[paramid] do
			begin
			conform := false;
			if ptype^.form = files then
			  begin
			  varkind := filevar;
			  reffilevar := true
			  end
			else varkind := refvar;
			end
			 end;
		    if formalbase = nil
			 then formalbase := newformal
		    else lastformal^.next := newformal;
		    lastformal := newformal;
		    paramid := idrecs[paramid].next
		    end;
	       if symbol = semicolon
		    then begin
		    insymbol;
		    checkpossiblesymbols(lblocksymbols + parambegsys, [rightparent])
		    end
	       end;
	  checksymbol(rightparent, psymbols + lblocksymbols)
	  end; {end of parameter list}
     end; {parameterlist}

	 begin { procdeclaration }
extproc := false;
forproc := false;
exsymbol := symbol;
earlierdeclared := false;
insymbol;
if symbol = ident
     then begin {check whether procedure already declared}
     createidentry := false;
     id := searchid([proc, func]);
     createidentry := true;
     if id <> -1
	  then with idrecs[id] do
	  earlierdeclared := (textlevel = top) and decl^.forwardproc and
	  (decl^.declkind = actual);
     insymbol
     end
else begin
     error(2);
     idname := '????????????'
     end;
if earlierdeclared
     then with idrecs[id] do
     with decl^ do
     begin
     if exsymbol = procsy then
	if class <> proc then error(34)
	else
     else if class <> func then error(34);
     forwardproc := false;
     accept(semicolon);
     checkexpectedsymbols(lblocksymbols);
     saveid := formalscope^.idscope;
     restorescope(formalscope)
     end
else begin {procedure not already declared}
     if exsymbol = procsy
	  then begin
	  id := newid(proc);
	  openscope(bloc);
		parameterlist(false, [semicolon], idrecs[id].decl^.formalroot)
	  end
     else begin {function}
	  id := newid(func);
	  openscope(bloc);
		parameterlist(false, [semicolon, colon], idrecs[id].decl^.formalroot);
	  accept(colon);
	  obtaintype(true, id) {type of result}
	  end;
     accept(semicolon);
     if symbol = ident
(*kvrm *)   then if idname = 'EXTERNAL    ' (* kvrm*)     { procedure in externa
l library  }
(*kvadd then if idname = 'EXTERN      '  kvadd*)     { procedure in external lib
rary  }
	  then begin
(*kvmod*) if outerleveltest > 0 then
(*kvmod*) begin
(*kvmod*)    {error(121);}{temporarily removed to allow redefinition of addbound
 for sets}{issue 11}
(*kvmod*) end;
	  if earlierdeclared
	       then error(87);
(*kvmod*)  idrecs[id].decl^.external := true;
	  (*kvrm *) inlibrary(id, true, extproc) (* kvrm*)
	      (*kvadd extproc := true;  kvadd*)
	  end
     else if idname = 'FORWARD     '
	  then begin
	  if earlierdeclared
	       then error(87);
	  forproc := true
	  end;
(*kvmod*) if (outerleveltest = 0) and (not programcomp) then
(*kvmod*) begin
(*kvmod*)    export := true;
(*kvmod*) end else
(*kvmod*) begin
(*kvmod*)    export := false;
(*kvmod*) end;
      if extproc
	   then begin
	   display[top].initialtlname := tlnamecount;
	   disposescope;
	   closescope
(*kvrm *)    end         (* kvrm*)
(*kvadd  end;      kvadd*)
(*kvrm *)      else                                              (* kvrm*)
	  xxprocspecification(id) {declare procedure to mutl}
      end;
(*kvmod*) export := false;
if forproc {procedure declared 'forward'}
     then with idrecs[id].decl^ do
     begin
     forwardproc := true;
     savescope(formalscope)
     end
else if not extproc {not forward or external}
     then begin {procedure definition}
     display[top].initialtlname := tlnamecount;
     xxstartprocdefinition(id);
     repeat
	idrecs[id].notyetdefined := true;
(*kvmod*) outerleveltest := outerleveltest + 1;
	  block(lblocksymbols, semicolon, id);
(*kvmod*) outerleveltest := outerleveltest - 1;
	idrecs[id].notyetdefined := false;
(*kvrm *)   if symbol = semicolon          (* kvrm*)
(*kvadd if (symbol = semicolon) and (not eof(intxt))  kvadd*)
	       then begin
	       insymbol;
	       if not (symbol in [procsy, funcsy, beginsy])
		    then begin
		    error(6);
		    skip(lblocksymbols)
		    end
	       end
(*kvrm *)   else error(14)      (* kvrm*)
(*kvadd else if not eof(intxt)            kvadd*)
(*kvadd         then begin                kvadd*)
(*kvadd                 error(14);        kvadd*)
(*kvadd              end                  kvadd*)
(*kvrm *) until symbol in [procsy, funcsy, beginsy];   (* kvrm*)
(*kvadd  until (symbol in [procsy, funcsy, beginsy]) or eof(intxt); (* kvsc*)
if idrecs[id].decl^.restlname <> 0 then
begin
xxsetaregmode(idrecs[id].idtype^.desc.typename);
plantname(load,a,idrecs[id].decl^.restlname);
xxplant(return,areg)
end
else xxplant(return,0);
     tlendproc;
     disposescope;
     if earlierdeclared then
		begin
		 if saveid <> -1 then
		while (saveid <= topid) and (idrecs[saveid].textlevel = top) do
		   begin
		   idrecs[saveid].textlevel := -2;
		   saveid := saveid + 1
		   end
		end;
     closescope
     end; {procedure definition}
if extproc or forproc
     then begin
     insymbol;
     accept(semicolon);
     checkexpectedsymbols(lblocksymbols)
     end
end; { procdeclaration }

	 procedure body;{143}

(*$S1*)
     var
	       endbody, endloop : boolean;
	
	       procedure statement(statsymbols : setofsymbols);{144}
	  var
		labelroot,allowedlabel : allowedlabelentry;
		    thislabel : labelentry;
	       varid, id : identry;
	       vartype, exptype : typentry;
	       labentry : labelentry;
	       lstatsymbols : setofsymbols;
	
	  procedure expression(esymbols : setofsymbols); forward;
	
	
	  procedure intexpression(isymbols : setofsymbols);{145}
	       begin
	       usebreg := true;
	       expression(isymbols);
	       usebreg := false;
	       if exptype <> inttype
		    then if exptype <> nil
		    then begin
		    error(60);
		    exptype := nil
		    end
	       end;
	
	  procedure condexpression(csymbols : setofsymbols; lab : integer);{146}
	       begin
		simplereln := true;
	       expression(csymbols);
	       if exptype <> booltype
		    then if exptype <> nil
		    then begin
		    error(60);
		    exptype := nil
		    end
		   else
		else if simplereln then
		   xxplant(ccjumpop[relnoperator],lab)
		   else jumponfalse(lab);
		simplereln := false
	       end;
	
	  procedure ordinalexpression(osymbols : setofsymbols);{147}
	       begin
	       usebreg := true;
	       expression(osymbols);
	       usebreg := false;
	       if exptype <> nil
		    then if exptype^.desc.kind <> ordinal
		    then begin
		    error(60);
		    exptype := nil
		    end
	       end;
	
	  		  procedure selector(ssymbols : setofsymbols; vid : identry);{148}
(*$S5*)
	       var
			 id : identry;
		    filet,t : typentry;
		    selectfactor, lowerbound, upperbound : integer;
		    fieldfound, selerror : boolean;
		    lssymbols : setofsymbols;
		    sdesc : descriptor;
	       begin
			tagfld := false;
	       selerror := false;
	       lssymbols := ssymbols + selectsys;
	       if vid <> -1
		    then with idrecs[vid] do
		    begin
		    t := idtype;
		    if t <> nil
			 then case class of
	       types,consts,proc,null : error(34);
	       vars : case varkind of
	       filevar : if symbol <> arrow then
			if reffilevar then stackreference(tlname,t^.desc){issue 11}
				else stackvariable(tlname,t^.desc);
	       normalvar : stackvariable(tlname, t^.desc);
	       refvar    : stackreference(tlname, t^.desc)
		    end;
	       field : begin
			withreference(display[levelfound].withbase, selectroot, t^.desc);
			tagfld := tagf
			end;
	       func  : with decl^ do
			if (kind = declared) and (declkind = actual)
			 then stackvariable(restlname, t^.desc)
		    else begin
			 error(60);
			 selerror := true
			 end
		    end
		    end
	       else selerror := true;
	       if selerror
		    then begin
		    t := nil;
		    stackdefault
		    end;
	       if not (symbol in lssymbols)
		    then begin
		    error(31);
		    t := nil;
		    skip(lssymbols)
		    end;
	       varid := vid;
	       while symbol in selectsys do
		    begin
		    case symbol of
		    {array element}			       leftbracket : begin
			 repeat
			      if t <> nil
				   then if t^.form = arrays then packerror := t^.arrpacked
				   else begin
				   error(69);
				   t := nil
				   end;
			      insymbol;
			      ordinalexpression(ssymbols + [comma, rightbracket]);
			      if t <> nil
				   then with t^ do
				   if comptypes(indextype, exptype)
				   then
					if desc.size = -1 then
					   begin
					   confreference(t);
					   t := elemtype
					   end
					else begin
				   getbounds(indextype, lowerbound, upperbound);
			if elemtype^.form = arrays then
			selectfactor := elemtype^.desc.size
			else selectfactor := 0;
                                  if checking then
                                     check(desc);
				   indexedreference(lowerbound, selectfactor, elemtype^.desc);
				   t := elemtype
				   end
			      else begin
				   error(70);
				   t := nil
				   end
			 until symbol <> comma;
			 accept(rightbracket)
			 end;
		    {field}		       period      : begin
			 if t <> nil
			      then if t^.form = records then packerror := t^.recpacked
			      else begin
			      error(71);
			      t := nil
			      end;
			 insymbol;
			 if symbol = ident
			      then begin
			      if t <> nil
				   then begin
					fieldfound := false;
					id := t^.fieldscope;
					repeat
					if idrecs[id].signature = sig then
					   if idrecs[id].length = idnamelength then
					      fieldfound := equal(idrecs[id].iindex, idindex, idnamelength)
			and (idrecs[id].class = field);
				if not fieldfound then id := id + 1;
					until fieldfound or (idrecs[id].class > field);
				   if not fieldfound
					then begin
					error(79);
					t := nil
					end
				   else with idrecs[id] do
					begin
					t := idtype;
					tagfld := tagf;
					if t <> nil
					     then fieldreference(selectroot, t^.desc)
					end
				   end;
			      insymbol
			      end
			 else error(2)
			 end;
		    {pointer}		       arrow       : begin
			 if t <> nil
			      then begin
			      with t^ do
				   if form = pointers
				   then begin
				   t := domaintype;
				   if t <> nil
					then pointerreference(t^.desc);
				   end
			      else if form = files
				   then begin
				      filet := componenttype;
				   if filet <> nil
					then begin
				with idrecs[vid] do
				if sequence = chars then {issue 11}{lazy input}
				begin
					releaseregister(a,false);
					releaseregister(d,false);
					xxplant(stkl,pbuffvtlname);
					xxsetaregmode(ccunboundeditempointer);
					if reffilevar then plantname(load,a,tlname)
					else plantname (loadref,a,tlname);
					xxplant(stkpar,areg);
					xxplant(enter,0);
					exptype := chartype;
					stackdata(a,chardesc);
				end else
				begin
					releaseregister(d,true);
{issue 11}{end of lazy input mod}
					 if reffilevar then plantname(load,d,tlname)
					 else plantname(loadref,d,tlname);
					plantname(selfld,d,3);
					plantname(selalt,d,t^.bufalt);
					plantname(selfld,d,0);
					stackreference(0,filet^.desc);
					topstackentry^.refinreg := true;
					entryusing[d] := topstackentry;
					if (sequence in [units, recs])
					     then begin
						tldtype(filet^.desc.typename,filet^.desc.size);
pointerreference(filet^.desc) end;
					end;
				t := filet
				   end;end{issue 11}
			      else error(72);
			      end;
			 insymbol
			 end
		    end;
		    if not (symbol in lssymbols)
			 then begin
			 error(31);
			 t := nil;
			 skip(lssymbols)
			 end;
		    end;
(*kvmod*)    if t <> nil then
	       if t^.form = sets then packedset := t^.setpacked;
	       vartype := t
	       end;
	
	  	       procedure callproc(csymbols : setofsymbols; pid : identry);{149}
	       var
			 whichpf : standprocs;
		    group : opofstandproc;
		    lcsymbols : setofsymbols;
		
	       procedure variabl(vsymbols : setofsymbols);{150}
		    var
			      id : identry;
		    begin
		    if symbol = ident
			 then begin
			 id := searchid([vars, field]);
				if id <> -1 then
				with idrecs[id] do
				if class = vars then
				if varkind = normalvar then
				if not canassign then error(116);
			 insymbol
			 end
		    else begin
			 error(2);
			 id := -1
			 end;
		    selector(vsymbols, id);
		    assigntype := 0;
		    if vartype <> nil then
			if vartype^.form in [scalars, subranges, sets] then
			  assigntype := vartype^.desc.typename;
		    if assigntype = cc128basictype then assigntype := 0;
		    end;
	
	       		  procedure fileproc;{151}
		    type
    pcallpmode = (none,one,cons,two);{issue 11}
		    var
			      standfile, reffile, notonlyskipping : boolean;
			 l1, l2, componname,
			 filname,filalt,fildim : mutlname;
			 compontype, itemtype : typentry;
			 fileid : identry;
			 seq : fileseqkind;
			 fileop : fileopkind;
			 fpsymbols : setofsymbols;
 paramval : integer;{issue 11}
			
procedure resetwrite(inp:boolean);{152}
begin
xxplant(stkl,pclosetlname);
xxsetaregmode(ccunboundeditempointer);
if reffile then plantname(load,a,filname)
else plantname(loadref,a,filname);
xxplant(stkpar,areg);
tlclit32(ccint,ord(inp));
stacknamedparam(0,ccint);
tlclit32(ccint,ord(seq));
stacknamedparam(0,ccint);
if seq in [units,recs] then
(*kvmod*)  tlctype(ccint,0,componname)
else tlclit32(ccint,0);
stacknamedparam(0,ccint);
xxendproccallseq(0)
end;
procedure checkflag(val : integer;var lab:mutlname);{153}
begin
xxlabelspecification(nullsymbname,cccompilerlabel,lab);
tlclit32(ccint16basictype,val);
xxsetaregmode(ccint16basictype);
plantname(load,a,ccitemreferenced);
plantname(logicaland,a,0);
plantname(comp,a,zerotlname);
xxplant(ifeqtr,lab)
end;

procedure filecomp(component:integer);{154}
begin
if reffile then plantname(load,d,filname)
else plantname(loadref,d,filname);
plantname(selfld,d,component);
if component=3 then
begin plantname(selalt,d,filalt);
plantname(selfld,d,0);
end;

end;

		    procedure storearegin(component : integer);{154a}
			 begin
			     if component = 1 then
			      if (fileop = outp) and not standfile then
				  plantname(revsubtract,a,zerotlname);
			filecomp(component);
			 if component = 3 then
			  if filalt >=4 then
			    begin
			    tldtype(componname,fildim);
			    plantname(load,d,ccitemreferenced)
			    end;
		      plantname(store, a, ccitemreferenced)
			 end;
		
procedure iooperation(kind : iokind;callget : boolean);{154b}
     var
	       tlname : integer;
	  entry : stackentry;
     begin
     entry := unstack;
     if entryusing[a] <> entry then
	releaseregister(a, true);
     if not(kind = readscalar) or reffile then
	releaseregister(d, true);
     case kind of
     readscalar      : begin
	  if callget
	       then begin
	       xxsetaregmode(entry^.desc.typename);
	filecomp(3);
	    plantname(load, a, ccitemreferenced)
	       end;
	  plantentry(store, a, entry)
	  end;
     readstructured  : begin
      xxsetaregmode(entry^.desc.typename);
	filecomp(3);
	tldtype(componname,fildim);
	plantname(load,d,ccitemreferenced);
	plantname(load,a,ccitemreferenced);
	plantentry(store,a,entry)
	  end;
     writescalar,writestructured : begin{issue 11}
	xxsetaregmode(entry^.desc.typename); {issue 11}
	plantentry(load, a, entry);
	storearegin(3);
	  freestack(entry)
	  end;
     end
     end;
		
		    procedure stacintconstparam(val : integer);{155}
			 begin
			 stackintconstant(val);
			 topstackentry^.desc.typename := ccint;
			 stackdescribedparam
			 end;
		
		    procedure proccallseq(tlname : integer ; mode : pcallpmode);{159}{issue 11
}
			 begin
xxplant(stkl, tlname);
if mode <> none then
begin
 if (mode = one) or (mode = two) then begin
			 with topstackentry^ do
			      if kind = data
			      then if dataonstack and not datainreg
			      then plantentry(load, a, topstackentry);
		stackdescribedparam
end;
 if mode > one then begin
   stacintconstparam(paramval);
   paramval := 0;
 end;
end;
			 xxendproccallseq(0)
			 end;

procedure pcallpiobin(tlname:integer;binary:boolean);{160}{new procedure}{issue
11}
begin
 xxplant(stkl,tlname);
 xxsetaregmode(ccunboundeditempointer);
 if reffile then plantname(load,a,filname)
  else plantname(loadref,a,filname);
 xxplant(stkpar,areg);
 if binary then
  tlclit32(ccint,filalt)
 else
  tlctype(ccint,0,componname);
 stacknamedparam(0,ccint);
 xxendproccallseq(0)
end;

		    procedure selectstream;{162}
			 var
				   tlname : integer;
			 begin
			releaseregister(a,false);
			releaseregister(d,false);
			 xxsetaregmode(ccint);
			filecomp(1);
			plantname(load,a,ccitemreferenced);
			 if fileop = inp
			      then tlname := sitlname
			 else begin
				tlname := sotlname;
				if not standfile then
				   plantname(revsubtract,a,zerotlname);
				end;
				stackdata(a, intdesc);
			 proccallseq(tlname,one);
			 end;
		
		    procedure getstandfile;{163}
			 begin
			 fildim := 0;
			filalt := 0;
			 if fileop = inp
			      then begin
			      fileid := infileid;
			      if inpnotdecl then error(97);
			      inpnotdecl := false;
			      filname := inpfiletlname;
			      end
			 else begin
			      fileid := outfileid;
			      if outpnotdecl then error(98);
			      outpnotdecl := false;
			      filname := outpfiletlname;
			      end;
			 standfile := true;
			 reffile := false;
			 seq := chars;
			 compontype := chartype;
			 end;
		
		
		    		     procedure gett;{164}{issue 11}
			 begin
  case seq of
chars:
				begin
			xxplant(stkl,pgettlname);
				xxsetaregmode(ccunboundeditempointer);
				if reffile then plantname(load,a,filname)
				else plantname(loadref,a,filname);
				xxplant(stkpar,areg);
				xxplant(enter,0)
				end;
			 binary : pcallpiobin(pinbintlname,true);{issue 11}
			 units,
			 recs    :pcallpiobin(pinrectlname,false);{issue 11}
			 end;
			 end;
		
		   procedure fileenq(i:integer);{165}
		     begin
		      releaseregister(a,false);
			releaseregister(d,false);
		     xxsetaregmode(ccintbasictype);
		     filecomp(0);
		      plantname(load,a,ccitemreferenced);
		     tlclit32(ccintbasictype, i);
		     plantname(logicaland, a, 0);
		     exptype := booltype;
		     stackdata(a,intdesc);
		     stackintconstant(i);
		     simplereln := false;
		     performoperation(scalarcomparison,eqop,booltype);
		     end;

		    procedure eolnn;{165a}{issue 11}{modified for lazy input}
			 begin
			 if seq = chars
			      then begin
			selectstream;
			proccallseq(nextchtlname,none);
			exptype := booltype;
			stackdata(a,intdesc);
stackintconstant(ilinefeed);
			simplereln := false;
			performoperation(scalarcomparison,eqop,booltype)
			      end
			 else begin
			      error(126);
			      exptype := booltype;
			      stackdefault
			      end
			 end;
		
procedure eofff;{issue 11}{newproc for lazy input}
	begin
if seq = chars
	then begin
		selectstream;
		proccallseq(ienqtlname,none);
		tlclit32(ccintbasictype,8);
		plantname(logicaland,a,0);
		exptype := booltype;
		stackdata(a,intdesc);
		stackintconstant(0);
		simplereln := false;
		performoperation(scalarcomparison,neop,booltype);
	end else
		fileenq(8)
end;{issue 11}{new proc}

		    procedure pagee;{166}
			 begin
			 if seq = chars
			      then begin
		     selectstream;
			      xxplant(stkl, outchtlname);
			      tlclit32(ccint, papthrow);
			      stacknamedparam(0,ccint);
			      xxendproccallseq(0)
			      end
			 else error(126)
			 end;
		
		    procedure putt;{167}
			 var
				   tlname : mutlname;
			 begin
			selectstream;
			 case seq of
			 chars: begin
			      filecomp(3);
			      stackreference(0,compontype^.desc);
			      topstackentry^.refinreg:=true;
			      entryusing[d]:=topstackentry;
				xxconvaregmode(topstackentry, 0, inttype);
				   proccallseq(outchtlname,one)
			      end;
   binary: pcallpiobin(poutbintlname,true);{issue 11}
			 units,
			 recs   :pcallpiobin(poutrectlname,false);{issue 11}
			 end
			 end;
		
		    		     procedure readd;{168}{issue 11}{rewritten for lazy input using MUS
S}
			 var
				   endloop : boolean;
			      op : iokind;
			      width : integer;tlname : mutlname;
			      itemtype : typentry;
			 begin
			 endloop := false;
			 while not endloop do
			      begin
			      variabl(csymbols + [comma,rightparent]);
			      selectstream;
			      assigntype := 0;
			      itemtype := vartype;
			      if seq = chars
				   then begin
					if comptypes(itemtype, chartype) then
					gett
				else
				begin
				   if comptypes(itemtype, inttype)
					then tlname := initlname
				   else if comptypes(itemtype, real32type)
					then tlname := inrealtlname
				   else if comptypes(itemtype, booltype)
					then tlname := inbooltlname
				   else if isstring(itemtype)
					then tlname := instrtlname;
			      if tlname = instrtlname
				   then begin
				 width := cardinality(itemtype^.indextype);
				releaseregister(a,false);
				xxsetaregmode(ccpointerbasictype);
				plantname(loadref,a,operandtlname(topstackentry));
				 xxplant(stkl, tlname);
				stacknamedparam(areg,ccpointerbasictype);
				 tlclit32(ccint, width);
				 stacknamedparam(0,ccint);
				 xxendproccallseq(0)
				end
			else begin
				proccallseq(tlname,none);
				xxplant(convareg,topstackentry^.desc.typename)
			end;end;
			if tlname <> instrtlname then iooperation(readscalar,false)
			end
		else begin
		if seq in [binary,units,recs] then
		if comptypes(itemtype,compontype) then
		begin if seq = binary then
		iooperation(readscalar,true)
		else iooperation(readstructured,true)
		end
		else error(80);
		gett
		end;
			      if symbol = comma
				   then insymbol
			      else endloop := true
			      end
			 end;
		
		    procedure resett;{169}
			 begin
			 resetwrite(true);
		 {issue 11} if seq <> chars then gett;
			 end;
		
		    procedure skiptonextline;{170}
			 begin
			selectstream;
			 if seq = chars
			      then if fileop = inp
			      then begin
proccallseq(inchtlname,none);{issue 11}
				proccallseq(sltlname,none);
{issue 11}{lazy input}
				end

			 else begin
     paramval := 1;
			      proccallseq(nltlname,cons);
				tlclit32(ccint16basictype,31);
				xxsetaregmode(ccint16basictype);
				plantname(load,a,0);
			      filecomp(0);
				plantname(andstore,a,ccitemreferenced);
			      end
			 else error(127)
			 end;
		
		    procedure rewritee;{171}
			 var
				   tlname : mutlname;
			 begin
			  resetwrite(false);
{issue 11}
			 end;
		
		    		     procedure writee;{172}
			 var
				   endloop, putspaces, widthspecified : boolean;
			      width, tlname : integer;
			      itemtype : typentry;
			 begin
			 endloop := false;
			 repeat
			      expression(fpsymbols);
			selectstream;
			      itemtype:=exptype;
			      case seq of
			 binary :begin {issue 11}
		iooperation(writescalar,false);
		putt
	end;
			      chars  : begin
				   putspaces := false;
				   widthspecified := false;
				   if comptypes(itemtype, inttype)
					then begin
					xxplant(stkl, outitlname);
				plantentry(load,a,topstackentry);
					if topstackentry^.desc.typename <>
						ccint then
					   xxplant(convareg, ccint);
					stackdescribedparam
					end
				   else if comptypes(itemtype, real32type)
					then begin
					xxplant(stkl, outrealtlname);
					xxconvaregmode(topstackentry,0,real64type);
					stackdescribedparam
					end
				 else if comptypes(itemtype,booltype)
				     then begin
				     width := 5;
				     xxplant(stkl, obooltlname);
				     stackdescribedparam
				     end
				else if isstring(itemtype)
				     then begin
				     width := cardinality(itemtype^.indextype);
				     xxplant(stkl, outstrtlname);
				     forcepointer(ccpointerbasictype);
				     stackdescribedparam
				     end
				   else begin
					putspaces := true;
					if comptypes(itemtype, chartype)
					     then begin
					     width := 1;
					xxconvaregmode(topstackentry,0,inttype);
					     tlname := outchtlname
					     end
					else error(60)
					end;
				   if symbol = colon
					then begin
					insymbol;
					expression(fpsymbols);
					if comptypes(exptype, inttype)
					     then widthspecified := true
					else error(60);
					if topstackentry^.desc.typename <>
						ccint then
				begin
				plantentry(load,a,topstackentry);
				xxplant(convareg,ccint)
				end;
					if not putspaces
					     then stackdescribedparam;
					if symbol = colon
					     then begin
					     insymbol;
					     expression(lcsymbols);
					     if comptypes(exptype, inttype)
						  then if comptypes(itemtype, real32type)
						  then begin
				plantentry(load,a,topstackentry);
						if topstackentry^.desc.typename <>
							ccint then
						   xxplant(convareg,ccint);
						stackdescribedparam
						end
					     else error(55)
					     else error(60)
					     end
					else if comptypes(itemtype, real32type)
					     then
					     stacknamedparam(zerotlname,ccint)
					end
				   else if comptypes(itemtype, inttype)
					then stacknamedparam(zerotlname,ccint)
				  else if isstring(itemtype) or
					comptypes(itemtype,booltype) then
				     begin
				     tlclit32(ccint, width);
				     stacknamedparam(0,ccint)
				     end
				   else if comptypes(itemtype, real32type)
					then begin
					stacknamedparam(zerotlname,ccint);
					stacknamedparam(zerotlname,ccint)
					end;
				   if putspaces
					then begin
					if widthspecified
					     then begin
					     stackintconstant(width);
					     performoperation(scalararithmetic, minus, inttype);
					     releaseregister(a,true);
					     proccallseq(sptlname,one)
					     end;
					proccallseq(tlname,one)
					end
				   else xxendproccallseq(0);
				if whichpf <> writelnp then
				begin
				tlclit32(ccint16basictype,32);
				xxsetaregmode(ccint16basictype);
				plantname(load,a,0);
				   filecomp(0);
				plantname(orstore,a,ccitemreferenced)
				end
				   end;
			      units,
			      recs   : begin
				   iooperation(writestructured, false);
				   putt
				   end
			      end;
			      if symbol = comma
				   then insymbol
			      else endloop := true
			 until endloop
			 end;
		
		    		  begin { fileproc }
		    standfile := false;
		    fpsymbols := lcsymbols + [colon];
		    fileop := fileoperation[whichpf];
		    if symbol = leftparent
			 then begin
			 notonlyskipping := true;
			 insymbol;
			 if symbol = ident
			      then begin
			      createidentry := false;
			      fileid := searchid([vars, field]);
			      createidentry := true;
			      if fileid <> -1
				   then if idrecs[fileid].idtype <> nil
				   then if (idrecs[fileid].idtype^.form = files)
				   and (ch <> '^')
				   then begin
				   insymbol;
				   compontype := idrecs[fileid].idtype^.componenttype;
				 if compontype^.form = arrays then
				   fildim := compontype^.desc.size
				 else fildim := 0;
                                  seq:=idrecs[fileid].idtype^.sequence;
                                 if seq in [units,recs] then componname := compo
ntype^.desc.typename;
				   if (fileid = infileid) or (fileid = outfileid) then
				    getstandfile
				   else with idrecs[fileid] do
					begin
					reffile := reffilevar;
					filname := tlname;
					filalt := idtype^.bufalt
					end;
				   if symbol = comma
					then insymbol
				   else notonlyskipping := false
				   end
			      else getstandfile
			      else getstandfile
			      else getstandfile
			      end
			 else getstandfile;
			 if whichpf in [resetp, rewritep, closep]
			      then if standfile
			      then error(127);
			 case whichpf of
		    closep   :begin extension; closefile(fileid) end;
		    eoff     : eofff;
		    eolnf    : eolnn;
		    getp     : gett;
		    pagep    : pagee;
		    putp     : putt;
		    readp    : readd;
			 readlnp  : begin
			      if notonlyskipping
				   then readd;
			      skiptonextline
			      end;
		    resetp   : resett;
		    rewritep : rewritee;
		    writep   : writee;
			 writelnp : begin
			      if notonlyskipping
				   then writee;
			      skiptonextline
			      end
			 end;
			 accept(rightparent)
			 end
		    else begin
			 getstandfile;
			 case whichpf of
			    resetp,rewritep,closep : error(127);
			    readp,writep : error(9);
		    eoff     : fileenq(8);
			    getp     :gett;
			    putp     :putt;
		    eolnf    : eolnn;
		    pagep    : pagee;
			 readlnp,
			 writelnp : skiptonextline
			 end
			 end
		    end; { fileproc }
	
	       		  procedure mathsfunc;{173}
		    var
			      entry : stackentry;
			 code : integer;
			 restype : typentry;
		    begin
		    restype := nil;
		    code := ccmfncode[whichpf];
		    expression(lcsymbols);
		    case whichpf of
		    absf, sqrf
		    : if comptypes(exptype, inttype)
			 then restype := inttype
		    else if comptypes(exptype, real32type)
			 then restype := exptype
		    else error(58);
		    arccosf, arcsinf, arctanf, cosf, coshf, sinhf,
			 expf, lnf, logf, sinf, tanf, tanhf, sqrtf
		    : begin
			 if whichpf in [arccosf, arcsinf, logf, tanf, tanhf, sinhf, coshf] then
			    extension;
			 restype := idrecs[realid].idtype;
			 if comptypes(exptype, inttype)
			      then float(topstackentry, idrecs[realid].idtype)
			 else if not comptypes(exptype, real32type)
			      then begin
			      error(58);
			      restype := nil
			      end			
			 end;
	       oddf   : if comptypes(exptype, inttype)
			 then restype := booltype
		    else error(58)
		    end;  { case whichpf of }
		    entry := unstack;
		    if restype <> nil
			 then if whichpf = sqrf
			 then
			 begin
			 plantentry(load, a, entry);
			 plantentry(multiply, a, entry);
			 end
		    else begin
			 if entryusing[a] <> entry
			      then plantentry(load,a,entry);
			if whichpf = oddf then aregmode := ccboolbasictype
			 else xxconvaregmode(entry,0,restype);
{vax  			 if (aregmode = ccint16basictype) or (aregmode = ccint8basictype)  then
			   xxplant(convareg,ccint32basictype);
 vax}
			 freestack(entry);
			 plantname(mfn, a, code);
			 xxplant(convareg, restype^.desc.typename);
			 end;
		    if restype <> nil
			 then stackdata(a, restype^.desc);
		    exptype := restype;
		    end;  { mathsfunc }
	
	       		  procedure convfunc;{174}
		    var
			      temp,kind : integer;
		    begin
		    kind := 0;
		    expression(lcsymbols);
		    case whichpf of
	       chrf   : begin if comptypes(exptype, inttype)
			 then exptype := chartype
		    else begin
			 error(58);
			 exptype := nil
			 end;
			if topstackentry^.kind = konstant then
			  with topstackentry^.val do
			    begin
			    temp := ival;
			    kind := charkind;
			    cval := chr(temp)
			    end
			end;
		    ordf   : begin if exptype <>nil then
			 if exptype^.desc.kind in [defpointer, undefpointer]   { ord(pointer) - not s
tandard pascal }
			      then
			      begin
			      extension;
			      exptype := inttype
			      end
			 else if exptype^.desc.kind = ordinal
			      then exptype := inttype
			 else begin
			      error(58);
			      exptype := nil
			      end;
			if topstackentry^.kind = konstant then
			  with topstackentry^.val do
			    begin
			    if kind = charkind then temp := ord(cval)
			    else if kind = boolkind then temp := ord(bval)
			    else temp := ival;
			    kind := intkind;
			    ival := temp
			    end
			end;
		    roundf,
		    truncf : begin
			 if comptypes(exptype, real32type)
			      then exptype := inttype
			 else begin
			      error(58);
			      exptype := nil
			      end;
			 if whichpf = roundf
			      then kind := 1
			 end
		    end;
		    if exptype <> nil
			 then xxconvaregmode(topstackentry, kind, exptype)
		    end;
	
	       		  procedure ordinalfunc;{175}
                   var ordtype : typentry;
		    begin
		    ordinalexpression(lcsymbols);
                   ordtype := exptype;
		    if exptype <> nil
		then if topstackentry^.kind = konstant then
		  with topstackentry^.val do
		    case kind of
			boolkind: if whichpf = succf then bval := succ(bval)
					else bval := pred(bval);
			charkind:if whichpf=succf then cval:=succ(cval)
					else cval:=pred(cval);
			intkind :if whichpf=succf then ival:=ival+1
					else ival:=ival-1
			end
			 else begin
                        xxconvaregmode(topstackentry,0,inttype);
                        stackintconstant(1);
			 if whichpf = succf
			      then performoperation(scalararithmetic, plus, inttype)
			 else performoperation(scalararithmetic, minus, inttype);
                         xxconvaregmode(topstackentry,0,ordtype)
                         end
		    end;
	
	       		  procedure transferproc;{176}
		    var
			      i, lowbound, highbound : integer;
			 it,et,e1, e2, i1, i2 : typentry;
			 destinentry, sourcentry : stackentry;
			
		    procedure arrayvar( asymbols : setofsymbols);{177}
			 begin
			 it := nil;
			 et := nil;
			 variabl(asymbols);
			 if vartype <> nil
			      then with vartype^ do
			      if form = arrays
			      then begin
			      it := indextype;
			      et := elemtype
			      end
			 else error(58)
			 end;
		
		    begin {transferproc}
		    arrayvar(lcsymbols);
i1 := it;e1 := et;
		    getbounds(i1, lowbound, highbound);
		    accept(comma);
		    case whichpf of
		    packp   : begin
			 ordinalexpression(lcsymbols);
			 if not comptypes(exptype, i1)
			      then error(60);
			 accept(comma);
			 setbounds(true, true, false, lowbound, 0);
			 arrayvar(lcsymbols - [comma]);
i2 := it;e2 := et;
			 getbounds(i2, lowbound, highbound);
			 destinentry := unstack;
			 setbounds(false, false, true, 0, highbound - lowbound)
			 end;
		    unpackp : begin
			 i := highbound - lowbound;
			 arrayvar(lcsymbols);
i2 := it;e2 := et;
			 getbounds(i2, lowbound, highbound);
			 accept(comma);
			 ordinalexpression(lcsymbols - [comma]);
			 if not comptypes(exptype, i2)
			      then error(60);
			 setbounds(true, true, true, lowbound, i);
			 releaseregister(d, false);
			 destinentry := unstack;
			 end
		    end;
		    sourcentry := unstack;
		    stack(destinentry);
		    stack(sourcentry);
		    if comptypes(e1, e2) and (vartype <> nil)
			 then performoperation(structassignment, notop, vartype)
		    else error(60)
		    end; {transferproc}
	
	       		  procedure dynamicstoreproc;{178}
		    var
typenm : integer;
			      found, structureknown : boolean;
			 tagval : constrec;
			 descrequired : descriptor;
			 varpartentry, variantentry, tagtype : typentry;
			 tempentry,entry : stackentry;
dimension : integer;
		    begin
		    structureknown := false;
		    varpartentry := nil;
		    variabl(csymbols + [comma, rightparent]);
		    if vartype <> nil
			 then with vartype^ do
			 if form = pointers
			 then if domaintype <> nil
			 then with domaintype^ do begin
if form = arrays then dimension := desc.size
else dimension := 0;
			 if form = records
			 then begin
			 structureknown := true;
			 descrequired := desc;
typenm := desc.typename;
			 varpartentry := varpart
			 end
		    else typenm := desc.typename
end

		    else
		    else error(58);
		    while symbol = comma do
			 begin
			 insymbol;
			  inconstant(csymbols + [comma, rightparent], tagtype, tagval);
			 if tagtype <> nil
			      then if tagtype^.desc.kind = ordinal
			      then if structureknown and (varpartentry <> nil)
			      then with varpartentry^ do
			      if form = varparts
			      then if tagfield = -1
			      then begin
			      error(86);
			      structureknown := false
			      end
			 else if comptypes(idrecs[varpartentry^.tagfield].idtype, tagtype)
			      then begin
			      variantentry := variantroot;
			      found := false;
			      while (variantentry <> nil) and (not found) do
				   with variantentry^ do
				   if constval(val) = constval(tagval)
				   then begin
				   varpartentry := subvarpart;
				   descrequired := desc;
				   found := true
				   end
			      else variantentry := nextvariant;
			      if not found
				   then begin
				   descrequired := desc;
				   varpartentry := nil
				   end
			      end
			 else begin
			      error(60);
			      structureknown := false
			      end
			 else
			 else if structureknown
			      then begin
			      error(42);
			      structureknown := false
			      end
			 else begin
			      error(42);
			      structureknown := false
			      end;
			 end;
		    if vartype <> nil
			 then begin
			 entry := unstack;
		       (*mu6g*)if (dimension = 0) and (entry^.desc.kind =
				(*mu6g*) undefpointer) then
			(*mu6g*)dimension := 1;
			 if whichpf = newp
			      then begin {call to piolib  to implement new}
xxplant(stkl, maketlname);

(*kvmod*)tlctype(ccintbasictype,0,typenm);
stacknamedparam(0,ccintbasictype);
(*kvmod*)tlctype(ccintbasictype,1,typenm);
stacknamedparam(0,ccintbasictype);
tlclit32(ccintbasictype, dimension);
stacknamedparam(0,ccintbasictype);
xxendproccallseq(0);

plantname(loadref,d,heaptemp);
(*mu6g*)if (dimension = 0) then
   plantname(selalt,d,0)
else plantname(selalt,d,1);
plantname(selfld,d,0);
with entry^.desc do
   if kind = undefpointer then
     xxsetaregmode(domtypename+ccboundeditempointer)
   else xxsetaregmode(typename);
plantname(load,a,ccitemreferenced);

			      plantentry(store, a, entry)
			      end
			 else begin
{ call to piolib to implement dispose }
if checking then
  begin
  new(tempentry);
  tempentry^ := entry^;
  if entryusing[d] = entry then
    xxretainreg(d);
  plantentry(load,a, entry);
  releaseregister(a,false);
  tlcnull(entry^.desc.typename);
  plantname(load,a,0);
  plantentry(store,a,tempentry);
  dispose(tempentry)
  end;
xxplant(stkl, removetlname);

(*kvmod*)tlctype(ccintbasictype,0,typenm);
(*mu6g*)if dimension = 0 then
  (*mu6g*)begin
  (*mu6g*)releaseregister(a,false);
  (*mu6g*)xxsetaregmode(ccintbasictype);
  (*mu6g*)plantname(loadneg,a,0);
  (*mu6g*)xxplant(stkpar, areg)
{issue 11} end else
stacknamedparam(0,ccintbasictype);
(*kvmod*)tlctype(ccintbasictype,1,typenm);
stacknamedparam(0, ccintbasictype);
releaseregister(d,false);
(*plantname(loadref,d,heaptemp);
plantname(selalt,d,1);
plantname(selfld,d,0);
xxsetaregmode(cc64basictype);
tlclit64(cc64basictype,0);
plantname(load,a,0);
plantname(store,a,ccitemreferenced);*)
plantentry(load,a,entry);
plantname(loadref,d,heaptemp);
if (dimension = 0) then
   plantname(selalt,d,0)
else plantname(selalt,d,1);
freestack(entry);
plantname(selfld,d,0);
plantname(store,a,ccitemreferenced);
xxendproccallseq(0);

			      end
			 end
		    end;
	
	       		  procedure userproc;{179}
		type
			  copyentry = ^copyrec;
			  copyrec = record
					next : copyentry;
					source,destination,stype,dtype : mutlname
					end;
		    var
			      copyroot, thiscopy : copyentry;
			 entry : stackentry;
			      confbase, formalbase : formalentry;
			 auxtlname, entryoperand, low, high : integer;
			 parid : identry;
 			 firstconf, endloop, bounded : boolean;
			conftype : typentry;
			

		    procedure compparam(p, q : formalentry);{180}
			 begin
			 while (p <> nil) and (q <> nil) do
			      with p^ do
			      begin
			      if kind = q^.kind
				   then begin
				    if kind in [funcparam, procparam] then
				   compparam(formalroot, q^.formalroot);
				   if ptype <> q^.ptype
					then error(58)
				   end
			      else error(60);
			      p := next;
			      q := q^.next
			      end;
			 if (p <> nil) or (q <> nil)
			      then error(57)
			 end;
		
		    begin {userproc}
		    copyroot := nil;
		    firstconf := true;
		    releaseregister(a,true);
		    with idrecs[pid] do
			with decl^ do
			 begin
			 formalbase := formalroot;
			 if declkind = actual then
				begin
				entryoperand := 0;
				xxplant(stkl, tlname)
				end
			   else begin
				entryoperand := tlname;
				xxplant(stkl, formaltlname)
				end
			 end;
		    if symbol = leftparent {start of parameter list}
			 then begin
			 if formalbase = nil then error(6);
			 repeat
			      insymbol;
			      if formalbase <> nil
				   then with formalbase^ do
				   begin
				   case kind of
				   auxparam : ;
				   confparam : begin
					if not copy then
					   begin
					   variabl(lcsymbols);
(*kvmod*)                                  if (vartype <> nil) and (ptype <> nil
) then
   					if vartype^.desc.typename <> ptype^.desc.typename then
					      error(58);
					   exptype := vartype
					   end
					else begin
					   expression(lcsymbols);
					   if exptype^.desc.size = -1 then error(113);
					   plantentry(load,a, topstackentry);
					   releaseregister(a, false);
					   end;
					if firstconf then
					   begin
					   conftype := exptype;
					   firstconf := false
					   end
					else if exptype <> conftype then error(58);
					forcepointer(ptypename);
					stackdescribedparam;
					confbase := formalbase^.next;
(*kvmod*)                             if confbase <> nil then
(*kvmod*)                                endloop := confbase^.kind <> auxparam
(*kvmod*)                               else endloop := true;
					if not endloop then firstconf := true;
					while not endloop do
					   begin
(*kvmod*)                                if exptype <> nil then
					   if exptype^.desc.size = -1 then
					      with exptype^ do
						begin
(*kvmod*)                                     if (low >= 0) and (high <= maxids)
 then
(*kvmod*)                                     begin
						stacknamedparam(idrecs[low].tlname, ccintbasictype);
						stacknamedparam(idrecs[high].tlname, ccintbasictype)
(*kvmod*)                                     end
						end
					   else begin
					   getbounds(exptype^.indextype,low,high);
					   tlclit32(ccintbasictype, low);
					   stacknamedparam(0, ccintbasictype);
					   tlclit32(ccintbasictype, high);
					   stacknamedparam(0, ccintbasictype);
					   end;
(*kvmod*)                                if exptype <> nil then
					   exptype := exptype^.elemtype;
(*kvmod*)                                if (confbase <> nil) and
(*kvmod*)                                   (confbase^.next <> nil) then
					   confbase := confbase^.next^.next;
					   if confbase <> nil then
					      endloop := confbase^.kind <> auxparam
					   else endloop := true;
					   end
					end;
				   funcparam,
				   procparam : begin
					if symbol = ident
					     then begin
					     parid := searchid([proc, func]);
					     with idrecs[parid] do
						with decl^ do
						  begin
						  if idtype <> ptype
						       then error(58);
						  if kind = declared
						       then begin
						       compparam(formalroot, formalbase^.formalroot);
						       stacknamedparam(tlname,ccprocpointer)
						       end
						  else error(125)
						 end
					     end
					else begin
					     error(2);
					     skip(lcsymbols)
					     end;
					insymbol;
					checkexpectedsymbols(lcsymbols)
					end;
				   varparam  : begin
					packerror := false;
					variabl(lcsymbols);
				if packerror then error(115);
				if tagfld then error(81);
					if vartype <> nil
					     then if vartype^.form = arrays
					     then bounded := true
					else bounded := false;
					if vartype <> ptype
					     then error(58)
					else if (*kvmod*)(vartype <> nil) and  (vartype^.desc.typename <>
								ptype^.desc.typename) then
						   begin
						   new(thiscopy);
						   thiscopy^.next := copyroot;
						   copyroot := thiscopy;
						   with copyroot^ do
							   begin
						stype := ptype^.desc.typename;
							dtype := vartype^.desc.typename;
							xxstaticstoreallocation(nullsymbname,stype,0,source);
							entry := unstack;
							plantentry(loadref,d,entry);
							releaseregister(d,false);
							destination := entry^.selvartlname;
							xxconvaregmode(entry,0,ptype);
							plantname(store,a,source);
							freestack(entry);
							stackvariable(source,ptype^.desc)
							end
						   end;
					forcepointer(ptypename);
					stackdescribedparam;
					end;
				   valparam  : begin
					if ptype <> nil then
						assigntype := ptype^.desc.typename
					else assigntype := 0;
					expression(lcsymbols );
					       if ptype <> nil then begin
						  if checking and (ptype^.form in [ subranges, scalars, sets])
						     then check(ptype^.desc) end{issue 11}
			else if topstackentry^.desc.vector and (topstackentry^.desc.typename = cc8bas
ictype ) then
			forcepointer(cc8basictype+ccboundeditempointer);
{issue 11 ,strings passed to weakly typed MUSS procedures need pointers}

					if not comptypes(exptype, ptype)
					     then if comptypes(ptype, real32type) and
					     comptypes(exptype, inttype)
					     then begin
					     float(topstackentry, ptype);
					     exptype := ptype
					     end
					else error(58);
					if exptype <> nil then
					if (exptype^.desc.kind in[ ordinal, reals])
			and (exptype^.desc.typename <> ptypename) then
					   begin
					   entry := unstack;
					   plantentry(load, a, entry);
					   xxplant(convareg, formalbase^.ptypename);
					   aregmode:= formalbase^.ptypename;
					   xxplant(stkpar, areg);
					   freestack(entry);
					   end
					else stackdescribedparam
					end
				   end;
				   if kind = confparam then
					formalbase := confbase
				   else formalbase := next
				   end
			 until symbol <> comma; {end of parameter list}
				if formalbase <> nil then error(57);
			 accept(rightparent)
			 end
		    else if formalbase <> nil then error(9);
		    xxendproccallseq(entryoperand);
		    with idrecs[pid] do
			 if class = func
			 then begin
			 if idtype <> nil
			      then with idtype^ do
			 stackdata(a, desc)
			else stackdefault;
			with decl^ do
			if external then
			   topstackentry^.desc.typename := restypnm;
			   exptype := idtype
			end;
			while copyroot <> nil do
				begin
				with copyroot^ do
				   begin
				releaseregister(a,true);
				xxsetaregmode(stype);
				plantname(load,a,source);
				plantname(load,d,destination);
				xxplant(convareg, dtype);
				plantname(store,a,ccitemreferenced)
				end;
			   thiscopy := copyroot;
			   copyroot := copyroot^.next;
			  dispose(thiscopy)
			   end;
		    end; {userproc}
	
	
	       	       begin { callproc }
	       assigntype := 0;
	       lcsymbols := csymbols + [comma, rightparent, ident];
	       with idrecs[pid] do
		    if kind = standard
		    then begin
		    whichpf := index;
		    group := groupofstandproc[whichpf];
		    if group = filehandling
			 then fileproc
		    else if symbol = leftparent
			 then begin
			 insymbol;
			 case group of
		    maths	: mathsfunc;
		    conv	 : convfunc;
		    ordinals     : ordinalfunc;
		    transf       : transferproc;
		    dynamstore   : dynamicstoreproc
			 end;
			 accept(rightparent)
			 end
		    else error(9)
		    end {of processing standard proc call}
	       else userproc;
		assigntype := 0
	       end; { callproc }
	  	
	  procedure expression;{181}
	       var
			 eop : optype;
		    etype, restype : typentry;
		    operation : opkind;
		
	       procedure loadfirstfac;{182}
		    begin
		    if not usebreg then assigntype := 0;
		    if exptype <> nil
			 then
			 if exptype^.form <> files then
			 if (topstackentry^.kind <> konstant)and (topstackentry^.desc.typename <> cc1
28basictype)
			 then
			 begin
			 if usebreg then plantentry(load, b, topstackentry)
			 else plantentry(load, a, topstackentry);
			 if entryusing[d] = topstackentry then entryusing[d] := nil
			 end
		    end;
	
	       procedure simpleexpression(ssymbols : setofsymbols);{183}
		    var
			      sop : optype;
			 stype, restype : typentry;
			 operation : opkind;
			 lssymbols : setofsymbols;
			 neg, signed : boolean;
			
		    procedure getsimpleop(t1, t2 : typentry; var operation : opkind);{184}
			 begin
			 if t1 <> nil
			      then if t1^.form = sets
			      then operation := setarithmetic
			 else operation := scalararithmetic
			 else if t2 <> nil
			      then if t2^.form = sets
			      then operation := setarithmetic
			 else operation := scalararithmetic
			 else operation := scalararithmetic
			 end;
		
		    procedure term(tsymbols : setofsymbols);{185}
			 var
				   top : optype;
			      ltsymbols : setofsymbols;
			      ttype, restype : typentry;
			      operation : opkind;
			
			 			procedure factor(fsymbols : setofsymbols);{186}
				type sett = set of 0..7;
			      var
					facoperator : optype;
				   constset : array[1..16] of sett;
				   ftype, setype, restype : typentry;
				   c : constrec;
                                  dimen, maxel,
				   i, val, low, high : integer;
			tlname : mutlname;
				   sconst, endloop, svar : boolean;
				   fid : identry;
				   gfsymbols : setofsymbols;
				   lfsymbols : setofidclass;
{ set manipulation procedures radically revised to
    improve efficiency of code for constant sets }
(*kvrm *) function addbound(var addr : sett; bound : integer): addrlo8; external
; (* kvrm*)
(*kvadd function addbound(var addr : sett; bound : integer): symbolicnamentry; e
xtern;  kvadd*)

procedure singletonset(tlname,typename : integer);{187}
     var
	       val : integer;
     i : 0..7;
	  entry : stackentry;
     begin
     entry := unstack;
     if entry^.kind = konstant then
	  begin
	  sconst := true;
	  val := constval(entry^.val);
	  freestack(entry);
	  if (val < minsetelement) or (val > maxsetelement)
	       then error(108)
	  else begin
	     i := val mod 8;
	     val := 16 - val div 8;
	     constset[val] := constset[val] + [i]
	     end
	  end
	else
     if typename = cc128basictype then
	begin
	if not svar then
	  begin
	  svar := true;
	  releaseregister(a,false);
	  xxsetaregmode(cc128basictype);
	  plantname(load,a,empty128tlname);
	  plantname(store,a,worksettlname)
	  end;
	xxplant(stkl, setelemtlname);
	plantentry(load,a,entry);
	xxplant(convareg,ccint);
	xxplant(stkpar,areg);
	freestack(entry);
	xxendproccallseq(0)
	end
        else begin
	xxconvsettype(singleset,cc32basictype, typename);
	plantentry(logicallshift, a, entry);
	plantname(orstore, a, tlname);
	end
     end;

procedure rangeset(tlname,typename:integer);{188}
     var
	       initentry, finalentry, sizeentry : stackentry;
     full : sett;
	  fullset : array[1..8] of sett;
     i,j : integer;
	  k,inittlname, init, final : integer;
     begin
     full := [0..7];
     sizeentry := unstack;
     finalentry := unstack;
     initentry := unstack;
     if (initentry^.kind = konstant) and (finalentry^.kind = konstant)
	  then begin
	  sconst := true;
	  init := constval(initentry^.val);
	  final := constval(finalentry^.val);
	   freestack(sizeentry);
	  freestack(initentry);
	  freestack(finalentry);
	  if (init < minsetelement) or (final > maxsetelement)
	       then error(108)
	  else if init > final then error(33)
	  else begin
	    i := init mod 8;
	    j := final mod 8;
	    init := 16 - init div 8;
	    final := 16 - final div 8;
	    if init = final then
		constset[init] := constset[init] + [i..j]
	    else begin
		constset[init] := constset[init] + [i..7];
		constset[final] := constset[final] + [0..j];
		for k := final + 1 to init - 1 do
		   constset[k] := full
		end
	    end
	  end
	  else
	   if typename = cc128basictype then
	     begin
	     if not svar then
		begin
		svar := true;
		releaseregister(a,false);
		xxsetaregmode(cc128basictype);
		plantname(load,a,empty128tlname);
		plantname(store,a,worksettlname)
		end;
	     xxplant(stkl, setrangetlname);
	     plantentry(load,a,initentry);
	     freestack(initentry);
	     xxplant(convareg,ccint);
	     xxplant(stkpar,areg);
	     plantentry(load,a,finalentry);
	     xxplant(convareg,ccint);
	     xxplant(stkpar,areg);
	     freestack(finalentry);
	     freestack(sizeentry);
	     xxendproccallseq(0)
	   end
	   else begin
	   xxsetaregmode(typename);
	   for k := 1 to 8 do fullset[k] := full;
	   tlclits(cc64basictype,addbound(fullset[1],8));
	   plantname(load,a,0);
	  plantentry(load,b,initentry);
	  releaseregister(b,false);
	  inittlname := initentry^.tlname;
	  freestack(initentry);
	  retainentry := false;
          plantentry(load, b, sizeentry);
          plantentry(subtract, b, finalentry);
          retainentry := true;
          plantname(add, b, inittlname);
	  xxplant(stk,breg);
          plantname(logicalrshift, a, ccdataonstack);
          plantname(logicallshift, a, inittlname);
          plantname(orstore, a, tlname);
     end
     end;
(*kvrm *)
**in -1
