(* kvrm*)
			      begin{factor}
			      if not (symbol in facbegsys)
				   then begin
				   error(30);
				   skip(fsymbols + facbegsys);
				   exptype := nil
				   end;
			      lfsymbols := [consts, vars, field, func];
			      gfsymbols := fsymbols + [comma, rightbracket];
			      repeat {until symbol in fsymbols}
				   if symbol in facbegsys
					then begin
					case symbol of
					nilsy : begin
						stackconstant(nilconst, pointerdesc);
						insymbol;
						exptype := pointertype
						end;
					ident       : begin
					     fid := searchid(lfsymbols);
					     insymbol;
					     case idrecs[fid].class of
					proc,types,null : exptype := nil;
					consts : with idrecs[fid] do
						  begin
(*kvmod*)                                       if idtype <> nil then
						  stackconstant(val, idtype^.desc);
						  exptype := idtype;
						  end;
					     vars,
					     field   : begin
						  selector(fsymbols, fid);
						  exptype := vartype
						  end;
					func    : callproc(fsymbols, fid);
					     end
					     end;
					intconst    : begin
					     stackconstant(constant, intdesc);
					     exptype := inttype;
					     insymbol;
					
					     end;
					realconst   : begin
					     stackconstant(constant, realcompiletimetype^.desc);{issue 11}
					     exptype := realcompiletimetype;{issue 11}
					     insymbol;
					
					     end;
					charconst   : begin
					     stackconstant(constant, chardesc);
					     exptype := chartype;
					     insymbol;
					
					     end;
					stringconst : begin
					     exptype := newstring;
					     stackconstant(constant, stringdesc);
					     insymbol
					     end;
					leftparent  : begin
					     insymbol;
					     simplereln := false;
					     expression(fsymbols + [rightparent]);
					     accept(rightparent)
					     end;
					notsy       : begin
					     insymbol;
					     factor(fsymbols);
					     checkmonadicoperand(scalarlogical, exptype, restype);
					     if restype <> nil
						  then negate(scalarlogical);
					     exptype := restype
					     end;
					leftbracket : begin
					  insymbol;
					  if symbol = rightbracket
					    then begin
					    insymbol;
					    exptype := settype;
					    stackvariable(emptyset, setdesc)
					    end
					  else begin
				     sconst := false;
					    svar := false;
					    for i := 1 to 16 do
					      constset[i] := [];
					    endloop := false;
					    setype := nil;
					    repeat
					     expression(gfsymbols + [ddot]);
					     if exptype <> nil then
					       begin
						if exptype^.desc.kind <> ordinal then
						  error(67);
					       if exptype^.desc.typename
							<> ccintbasictype then
						  xxconvaregmode(
							topstackentry,0,inttype);
					       if setype = nil
					       then begin
					       setype := exptype;
						   releaseregister(a,false);
					       ftype := newtype(sets);
					       with ftype^ do
						    begin
						setpacked := packedset;
						    basetype := exptype;
                                                   getdescriptor(ftype,nullsymbn
ame);
                                                   xxstaticstoreallocation
                                                    (nullsymbname,desc.typename,
0,tlname);
						xxsetaregmode(desc.typename);
                                                   plantname(load,a,choosetlclit
(desc.typename));
						 plantname(store,a,tlname)
						    end
						  end
					       end
					     else if not comptypes(setype,exptype)
					       then error(60);
					     if symbol = ddot
						  then begin
						  insymbol;
						  expression(gfsymbols);
						if exptype^.desc.kind <> ordinal then
						  error(67);
                                                 if exptype^.desc.typename <> cc
intbasictype
                                                    then xxconvaregmode(topstack
entry,0,inttype);
   						releaseregister(a,false);
                                                 stackintconstant(ftype^.desc.si
ze-1);
						  if comptypes(exptype, setype)
						       then rangeset(tlname,ftype^.desc.typename)
						  else error(60)
						  end
					     else if (exptype <> nil) and (setype <> nil)
						  then singletonset(tlname,ftype^.desc.typename);
					     if symbol = comma
						  then insymbol
					     else endloop := true
					until endloop;
					accept(rightbracket);
				if svar then
				  begin
				  xxsetaregmode(cc128basictype);
				  plantname(load,a,worksettlname);
				  plantname(store,a,tlname)
				  end;
				if sconst then begin
					i := ftype^.desc.size div 8;
				if i = 16 then begin
				   releaseregister(d,false);
				   xxsetaregmode(cc64basictype);
				   plantname(loadref,d,tlname);
				   plantname(selfld,d,0);
				   tlclits(cc64basictype,addbound(constset[1],8));
				   plantname(load,a,0);
				   plantname(orstore,a,ccitemreferenced);
				   plantname(loadref,d,tlname);
				   plantname(selfld,d,1);
				   tlclits(aregmode,addbound(constset[9],8));
				   plantname(load,a,0);
				   plantname(orstore,a,ccitemreferenced)
				   end
				else begin
					xxsetaregmode(ftype^.desc.typename);
					tlclits(aregmode,addbound(constset[17-i],i));
					plantname(load,a,0);
					plantname(orstore,a,tlname)
				end
				end;
					stackvariable(tlname,ftype^.desc);
					exptype := ftype
					end
				   end
					end;
					checkpossiblesymbols(fsymbols, facbegsys)
					end
			      until symbol in fsymbols;

			      end; {factor}
			
			
			 		     begin { term }
			 ltsymbols := tsymbols + [mulop];
			 factor(ltsymbols);
			 if symbol = mulop then loadfirstfac;
			 while symbol = mulop do
			      begin
			      ttype := exptype;
			      top := operator;
			      insymbol;
			      factor(ltsymbols);
			      case top of
			 mul   : getsimpleop(ttype, exptype,operation);
			      idiv,
				   rdiv,
			      modop  : operation := scalararithmetic;
			 andop : operation := scalarlogical
			      end;
			      checkdyadicoperands(operation, top, ttype, exptype, restype);
			      if restype <> nil
				   then performoperation(operation, top, restype);
			      exptype := restype
			      end
			 end; { term }
		
		    		  begin { simpleexpression }
		    if (symbol = addop) and (operator in [plus, minus])
			 then begin
			 signed := true;
			 neg := (operator = minus);
			 insymbol
			 end
		    else signed := false;
		    lssymbols := ssymbols + [addop];
		    term(lssymbols);
		    if signed
			 then begin
			 checkmonadicoperand(scalararithmetic, exptype, restype);
			 if (restype <> nil) and neg
			      then negate(scalararithmetic);
			 exptype := restype
			 end;
		    if symbol = addop then loadfirstfac;
		    while symbol = addop do
			 begin
			 stype := exptype;
			 sop := operator;
			 insymbol;
			 term(lssymbols);
			 case sop of
			 plus,
			 minus : getsimpleop(stype, exptype,operation);
		    orop  : operation := scalarlogical
			 end;
			 checkdyadicoperands(operation, sop, stype, exptype, restype);
			 if restype <> nil
			      then performoperation(operation, sop, restype);
			 exptype := restype
			 end
		    end; { simpleexpression }
	
	       		  function getop( t: typentry):typentry;{189}
		    begin
		    case t^.form of
		    scalars,
		    subranges : operation := scalarcomparison;
	       pointers  : begin
		operation := pointercomparison;
		if not(eop in [eqop,neop]) then error(62)
		end;
	       sets      : operation := setcomparison;
	       arrays,records,files    : if isstring(t)
			 then operation := strcomparison
		    else begin
			 error(111);
			 t := nil;
			 operation := scalarcomparison
			 end
		    end;
	getop := t
		    end;
	
	       	       begin { expression }
	       simpleexpression(esymbols + [relop]);
	       if symbol = relop
		    then begin
		     if exptype <> nil then
		    if exptype^.form = arrays then
			if exptype^.desc.size = -1 then
			else loadfirstfac
		    else loadfirstfac;
		    etype := exptype;
		    eop := operator;
		    insymbol;
if eop = inop then releaseregister(a,false);
		    simpleexpression(esymbols);
		    if eop = inop then operation := inset
		    else if etype <> nil
			 then etype :=getop(etype)
		    else if exptype <> nil
			 then exptype := getop(exptype)
		    else operation := scalarcomparison;
		    checkdyadicoperands(operation, eop, etype, exptype, restype);
		    if restype <> nil
			 then performoperation(operation, eop, restype);
		    exptype := booltype
		    end
		else simplereln := false
	       end; { expression }
	
	  	       procedure assignment(id : identry);{190}
	       var
			 desttype, restype : typentry;
		    op : optype;
		    operation : opkind;
		
	       function getassignop( t : typentry):typentry;{191}
		    begin
		    case t^.form of
		    scalars,
		    subranges : operation := scalarassignment;
	       pointers  : operation := pointerassignment;
	       arrays    : if isstring(t)
			 then operation := stringassignment
		    else if t^.desc.size = -1 then
			operation := confassignment
			else operation := structassignment;
	       sets      : operation := setassignment;
	       records   : operation := structassignment;
		    files     : begin
			 operation := scalarassignment;
			 error(75);
			 t := nil
			 end
		    end;
getassignop := t
		    end;
	
	       begin { assignment }
	       op := notop;
	      with idrecs[id] do
		if class = vars then
		  if varkind = normalvar then
		    if textlevel < level then assigned := true;
		if idrecs[id].class = func then
		   if not idrecs[id].notyetdefined then
			error(34);
			with idrecs[id] do
			if class = vars then
			if varkind = normalvar then
			if not canassign then error(116);
	       selector(lstatsymbols + [becomes], id);
	       desttype := vartype;
	       if symbol = becomes
		    then begin
		    insymbol;
		    freedreg := true;
		    expression(lstatsymbols);
		    freedreg := false;
		    if desttype <> nil
			 then desttype :=getassignop(desttype)
		    else if exptype <> nil
			 then exptype := getassignop(exptype)
		    else operation := scalarassignment;
		      if exptype <> nil then
		   if desttype <> nil then
		      if checking and (desttype^.form in [scalars, subranges, sets]) then
			 check(desttype^.desc);
		    checkdyadicoperands(operation, op, desttype, exptype, restype);
		    if restype <> nil
			 then performoperation(operation, op, restype)
		    end
	       else error(23)
	       end; { assignment }
	
	  procedure compoundstatement;{192}
	       var
			 csymbols : setofsymbols;
	       begin
	       csymbols := statsymbols + [semicolon, endsy];
	       repeat
		    insymbol;
		    statement(csymbols)
	       until symbol <> semicolon;
	       accept(endsy)
	       end;
	
	  procedure ifstatement;{193}
	       var
			 falsecondlabelname, nextstatlabelname : mutlname;
	       begin
	       insymbol;
	      xxlabelspecification(nullsymbname, cccompilerlabel, falsecondlabelname);
	       condexpression(lstatsymbols + [thensy],falsecondlabelname);
	       accept(thensy);
	       statement(statsymbols + [elsesy]);
	       if symbol = elsesy
		    then begin
		    xxlabelspecification(nullsymbname, cccompilerlabel, nextstatlabelname);
		    xxplant(uncondjump, nextstatlabelname);
		    tllabel(falsecondlabelname);
		    insymbol;
		    if symbol = intconst then
			begin
				allowedlabel := labelroot;
			while allowedlabel<>nil do
			    begin
			    with allowedlabel^.labl^ do
			      begin
			      if jumpto then
				nottobedefined := true;
			      if defined then nottobeused := true
			      end;
				    allowedlabel := allowedlabel^.next
			    end
			end;
		    statement(statsymbols);
		    tllabel(nextstatlabelname)
		    end
	       else tllabel(falsecondlabelname)
	       end;
	
	  	       procedure casestatement;{194}
(*$S4*)
		type casentry = ^caserec;
			 caserec = record
					constval : integer;
					labelname : mutlname;
					next : casentry
					end;
	       var
		     indexdesc : descriptor;
		    checkbound,endouterloop,
			errorused,  endinnerloop, otherwisespecified : boolean;
		    i, low, high, mincase, maxcase, val : integer;
		 thislabelname,
		    startcaselabelname, errorlabelname: mutlname;
		    caseroot,thiscase,lastcase,newcase : casentry;
		endcaselabelname,constlisttlname:mutlname;
		    consttype, indextype : typentry;
		    c : constrec;
		    csymbols : setofsymbols;
	       begin
	       errorused := false;
	       otherwisespecified := false;
	       csymbols := lstatsymbols + [comma, colon];
	       insymbol;
	       ordinalexpression(csymbols + [ofsy]);
		if topstackentry^.kind = reference then
		  releaseregister(d,false)
		else if topstackentry^.kind = data then
		begin
		  releaseregister(b,false);
		releaseregister(a,false)
		end;
	       indextype := exptype;
	       low := 0;
	       high := 0;
		caseroot := nil;
	       if indextype <> nil
		    then begin
		    if indextype = inttype
			 then begin
			 checkbound := false;
			 low := mincaseconstant;
			 high := maxcaseconstant
			 end
		    else begin
			 checkbound := true;
			 getbounds(indextype, low, high)
			 end;
		     indexdesc := indextype^.desc
		    end
		else indexdesc := intdesc;
	       xxlabelspecification(nullsymbname, cccompilerlabel, endcaselabelname);
		xxlabelspecification(nullsymbname, cccompilerlabel, startcaselabelname);
		xxplant(uncondjump,startcaselabelname);
	       {create empty case table}
	       xxstaticstoreallocation(nullsymbname,cclabelpointer, -1, constlisttlname
);
	       accept(ofsy);
	       endouterloop := false;
	       repeat {for each statement in case}
		    xxlabelspecification(nullsymbname, cccompilerlabel, thislabelname);
		    tllabel(thislabelname);
		    endinnerloop := false;
		    repeat {for each label in one list}
			 inconstant(csymbols, consttype, c);
			 if comptypes(consttype, indextype)
			      then begin
			      val := constval(c);
				if checkbound then
			      if (val < low) or (val > high)
				   then error(107);
			   new(newcase);
			   newcase^.constval := val;
			   newcase^.labelname := thislabelname;
			   if caseroot = nil then
			      begin
			      caseroot := newcase;
			      newcase^.next := nil;
			      maxcase := val
			      end
			   else begin
			      thiscase := caseroot;
			      lastcase := nil;
			      while thiscase <> nil do
				if thiscase^.constval = val then
				  begin
				  error(84);
				  thiscase := nil
				  end
				else if thiscase^.constval < val then
				  begin
				  lastcase := thiscase;
				  thiscase := thiscase^.next;
				  if thiscase = nil then
				    begin
				    lastcase^.next := newcase;
				    newcase^.next := nil;
				    maxcase := val
				    end
				  end
				else begin
				  if lastcase = nil then
				    caseroot := newcase
				  else lastcase^.next := newcase;
				  newcase^.next := thiscase;
				  thiscase := nil
				  end
			      end;
			  mincase := caseroot^.constval
			      end
			 else error(76);
			 if symbol = comma
			      then insymbol
			 else endinnerloop := true
		    until endinnerloop; {no more labels}
		    accept(colon);
		    if symbol = intconst then
			begin
			allowedlabel := labelroot;
			while allowedlabel <> nil do
			begin
			with allowedlabel^.labl^ do
			    begin
			if jumpto then
			    nottobedefined := true;
			    if defined then nottobeused := true
			    end;
			allowedlabel := allowedlabel^.next
			end
			end;
		    statement(statsymbols + [semicolon, otherwisesy]);
		    xxplant(uncondjump, endcaselabelname);
		    if symbol = semicolon
			 then insymbol
		    else if symbol = otherwisesy
			 then begin
(*kvadd                  extension;     kvadd*)
			 xxlabelspecification(nullsymbname, cccompilerlabel, thislabelname);
			 tllabel(thislabelname);
			 insymbol;
			 statement(statsymbols + [semicolon]);
			 xxplant(uncondjump,endcaselabelname);
			 if indextype = inttype then
			   writeln('>>>** warning. otherwise with integer type');
			 otherwisespecified := true;
			 if mincase < low then low := mincase;
			 if maxcase > high then high := maxcase;
			 accept(endsy);
			 endouterloop := true
			 end
		    else if symbol <> endsy {faulty case}
			 then begin
			 if symbol in statsymbols
			      then begin
			      endouterloop := true;
			      error(28)
			      end;
			 error(20)
			 end
	       until endouterloop or (symbol = endsy); {until no more statements in cas
e}
		if not otherwisespecified then
		  begin
		  low := mincase;
		  high := maxcase
		  end;
		tllabel(startcaselabelname);
		indexdesc.min := low;
		indexdesc.max := high;
		if checking then check(indexdesc);
		if indextype <> nil then
		  plantentry(load,b,topstackentry);
		if low <> 0 then
		  plantintconstant(add,b,-low);
		plantname(loadref,d,constlisttlname);
		plantname(selel,d,0);
		xxplant(uncondjump,ccitemreferenced);
		if otherwisespecified then
		  errorlabelname := thislabelname
		else xxlabelspecification(nullsymbname,cccompilerlabel,errorlabelname);
	       tlass(constlisttlname, -1); {fill in case table for mutl}
		val := low;
		thiscase := caseroot;
		while thiscase <> nil do
		  begin
		  if thiscase^.constval > val then
		    begin
		    errorused := true;
		    tlassvalue(errorlabelname,thiscase^.constval - val)
		    end;
		  tlassvalue(thiscase^.labelname,1);
		val := thiscase^.constval + 1;
		lastcase := thiscase;
		thiscase := thiscase^.next;
		dispose(lastcase)
		end;
		if high > val then
		begin
		 errorused := true;
		  tlassvalue(errorlabelname,high-val)
		  end;
	       tlassend;
(*kvmod*)       if errorused and (not otherwisespecified) then
		  begin
		  tllabel(errorlabelname);
		  runtimeerror(2048)
		  end;
		tllabel(endcaselabelname);
	       if (symbol = endsy) and not otherwisespecified
		    then insymbol
	       end;
	
	  	       procedure forstatement;{195}
(*$S5*)
	       var
		    finalentry, initentry : stackentry;
			 controlid : identry;
		    controltype : typentry;
		    increasing : boolean;
		    fsymbols : setofsymbols;
		    inittlname, contvartlname,
		typname : mutlname;
	       begin
	       fsymbols := [tosy, dosy];
	       insymbol;
	       if symbol = ident
		    then begin {check control variable}
		    controlid := searchid([vars]);
		    controltype := idrecs[controlid].idtype;
		    if levelfound <> level
			 then error(82);
		    if idrecs[controlid].varkind <> normalvar then error(82)
			else if not idrecs[controlid].canassign
					or idrecs[controlid].assigned then
			error(116)
			else idrecs[controlid].canassign := false;
		    if controltype <> nil
			 then if controltype^.desc.kind = ordinal
			 then begin
			contvartlname := idrecs[controlid].tlname;
			typname := controltype^.desc.typename
			end
		    else begin
			 error(65);
			 controltype := nil;
			 typname := ccint;
			 contvartlname := 0
			 end
		    else contvartlname := 0;
		    insymbol
		    end
	       else begin
		    error(2);
		    skip(fsymbols + [becomes])
		    end;
	       if symbol = becomes
		    then begin {initial control variale vaue}
		    insymbol;
		    expression(fsymbols);
		    if not comptypes(exptype, controltype)
			 then error(60)
		    else if exptype <> nil then
			if exptype^.desc.typename <> typname then
			   xxconvaregmode(topstackentry,0,controltype);
		initentry := unstack;
		    with initentry^ do
			if not(kind in [variable,konstant]) then
			begin
		    plantentry(load,a,initentry);
		    releaseregister(a,false)
			end
		    end
	       else begin
		    stackdefault;
		    initentry := unstack;
		    error(23);
		    skip(fsymbols)
		    end;
	       if symbol = tosy
		    then begin
		    increasing := (operator = plus);
		    insymbol; {final control variable val}
		    expression(fsymbols - [tosy]);
		    if not comptypes(exptype, controltype)
			 then error(60)
		    else if exptype<>nil then
			if exptype^.desc.typename <> typname then
			  xxconvaregmode(topstackentry,0,controltype)
		    end
	       else begin
		    increasing := true;
		    error(27);
		    skip(fsymbols - [tosy])
		    end;
	       accept(dosy); {generate code to perform loop}
		inittlname := operandtlname(initentry);
		freestack(initentry);
		with topstackentry^ do
		  if kind = variable then
		    if tlname = contvartlname then
		      plantentry(load,a,topstackentry);
{issue 11}if putcode then 		tlcvcycle(contvartlname,inittlname,2-ord(increasing)
);
		finalentry := unstack;
		{issue 11} if putcode then tlcvlimit(operandtlname(finalentry));
		freestack(finalentry);
	       statement(statsymbols);
		idrecs[controlid].canassign := true;
	       {issue 11} if putcode then tlrepeat;
	       end;
	
	  procedure whilestatement;{196}
	       var
			 condlabelname, endlooplabelname : mutlname;
	       begin
	       xxlabelspecification(nullsymbname, cccompilerlabel, condlabelname);
	       xxlabelspecification(nullsymbname, cccompilerlabel, endlooplabelname);
	       tllabel(condlabelname);
	       insymbol;
	       condexpression(lstatsymbols + [dosy],endlooplabelname);

	       accept(dosy);
	       statement(lstatsymbols);
	       xxplant(uncondjump, condlabelname);
	       tllabel(endlooplabelname)
	       end;
	
	  procedure repeatstatement;{197}
	       var
			 startlooplabelname : mutlname;
	       begin
	       xxlabelspecification(nullsymbname, cccompilerlabel, startlooplabelname);
	       tllabel(startlooplabelname);
	       repeat
		    insymbol;
		    statement(statsymbols + [semicolon, untilsy])
	       until symbol <> semicolon;
	       if symbol = untilsy
		    then begin
		    insymbol;
		    condexpression(lstatsymbols,startlooplabelname);

		    end
	       else error(25)
	       end;
	
	  procedure gotostatement;{198}
	       var
			 entry : labelentry;
	       begin
	       insymbol;
	       if symbol = intconst
		    then begin
		    entry := searchlabel(entry);
		    if entry^.nottobeused then error(117);
		    entry^.jumpto := true;
		    xxplant(uncondjump, entry^.reftlname);
		    insymbol
		    end
	       else error(15)
	       end;
	
	  procedure withstatement;{199}
	       var
		    savelevel : integer;
			 saveid, tempentry, id : identry;
		    base : stackentry;
	       begin
	       insymbol;
	       if symbol = ident
		    then begin
		    id := searchid([vars, field]);
		    insymbol
		    end
	       else begin
		    error(2);
		    id := -1
		    end;
	       selector(lstatsymbols + [comma, dosy], id);
	       openscope(withst);
		scopenumber := scopenumber - 1;
	       openwithstatement; base := topstackentry;
	       if vartype <> nil
		    then if vartype^.form = records
		    then with display[top] do
		    begin
		    idscope := vartype^.fieldscope;
		    tempentry := idscope;
		    withbase := base
		    end
	       else begin tempentry := -1; error(60) end;
	       saveid := tempentry;
		if tempentry <> -1 then
		  begin
		  savelevel := idrecs[tempentry].textlevel;
	       while (idrecs[tempentry].class <= field)
				and (tempentry <= topid) do
		  begin
		  if idrecs[tempentry].textlevel = savelevel then
		  idrecs[tempentry].textlevel := top;
		  tempentry := tempentry + 1
		  end;
		  end;
	       if symbol = comma
		    then withstatement
	       else begin
		    accept(dosy);
		    statement(statsymbols)
		    end;
	       closewithstatement;
	       while tempentry > saveid do
	       begin
	       tempentry := tempentry -1;
		if idrecs[tempentry].textlevel = top then
	       idrecs[tempentry].textlevel := savelevel
	       end;
	       closescope
	       end;
	
	  	    begin { statement }

(*$S1*)
	  assigntype := 0;
	  packedset := false;
	   aregmode := 0;
	  lstatsymbols := statsymbols + statbegsys;
	  if symbol = intconst {label}
	       then begin
	       labentry := searchlabel(labentry);
	       with labentry^ do
		    if defined
		    then error(91)
	       else begin
		    if nottobedefined then error(117);
		    if levelfound <> level then error(110);
		    tllabel(labeltlname);
		    defined := true
		    end;
	       insymbol;
	       accept(colon)
	       end;
	  if not (symbol in lstatsymbols + [ident])
	       then begin
	       error(2);
	       skip(lstatsymbols)
	       end;
while symbol in (statbegsys + [ident]) do
   begin
	labelroot := nil;
	thislabel := display[level].labelroot;
	while thislabel <> nil do
	  begin
	  if not (thislabel^.defined or thislabel^.nottobedefined) then
	    begin
	    if thislabel^.jumpto then
	      thislabel^.nottobedefined := true;
	    new(allowedlabel);
	    allowedlabel^.labl := thislabel;
	    allowedlabel^.next := labelroot;
	    labelroot := allowedlabel
	    end;
	  thislabel := thislabel^.next
	  end;
	       openstatement;
	       case symbol of
	       ident    : begin
		    id := searchid([vars, field, func, proc]);
		    insymbol;
		    if idrecs[id].class = proc
			 then callproc(statsymbols, id)
		    else if misused then skip(statsymbols)
		else assignment(id)
		    end;
	  beginsy  : compoundstatement;
	  casesy   : casestatement;
	  forsy    : forstatement;
	  gotosy   : gotostatement;
	  ifsy     : ifstatement;
	  repeatsy : repeatstatement;
	  whilesy  : whilestatement;
	  withsy   : withstatement
	       end;
	       while labelroot <> nil do
		 with labelroot^.labl^ do
		 begin
		 if defined then
		     nottobeused := true;
		 nottobedefined := false;
		 allowedlabel := labelroot;
		 labelroot := labelroot^.next;
		 dispose(allowedlabel)
		 end;
	       closestatement;
	       if symbol in statbegsys
		    then error(14)
	       else if not (symbol in statsymbols - blockbegsys)
		    then begin
		    error(6);
		    skip(lstatsymbols)
		    end
	       end
	  end; { statement }

     	 begin { body }
     endbody := false;
     openbody;
     repeat
	  if symbol = beginsy
	       then insymbol;
	  endloop := false;
	  repeat {until no more statements in block}
	       statement(blocksymbols + [semicolon, endsy]);
	       if symbol = semicolon
		    then insymbol
	       else endloop := true
	  until endloop; {no more statements in block}
	  if symbol = endsy
	       then begin
	       insymbol;
	       if symbol = endblocksymbol
		    then endbody := true
	       end;
	  if not endbody
	       then begin
	       error(6);
	       skip(blocksymbols + statbegsys + [endsy])
	       end
     until endbody or (symbol in blocksymbols)
     end; { body }

      begin { block }
lblocksymbols := blockbegsys + statbegsys - [casesy];
domainroot := nil;
initidchain(display[top].filechain);
repeat
     forwardref := false;
     endtypedefinition := false;
     if symbol = labelsy
	  then labeldeclaration;
     if symbol = constsy
	  then constdefinition;
     if symbol = typesy
	  then typedefinition;
     endtypedefinition := true;
     if symbol = varsy
	  then vardeclaration;
     while symbol in [procsy, funcsy] do
	  procdeclaration;
     if symbol <> beginsy
	  then if symbol in blockbegsys
	  then error(18)
     else if symbol in statbegsys
	  then error(17)
(*kvrm *)     else begin
(*kvrm *)          error(18);
(*kvrm *)          skip(lblocksymbols)
(*kvrm *)          end
(*kvadd  else if (not eof(intxt)) then
(*kvadd       begin
(*kvadd          error(18);
(*kvadd          skip(lblocksymbols)
(*kvadd       end
(*kvmod*)until (symbol in statbegsys) (*kvadd or eof(intxt) kvadd*);
(*kvmod*) if (outerleveltest = 0) and
(*kvadd    eof(intxt) and               kvadd*)
(*kvmod*)    (not programcomp) then
(*kvmod*) begin
(*kvmod*)    symbol := period;
(*kvmod*) end else
(*kvmod*) begin
	     body;
(*kvmod*) end;
(*kvmod*)
releasefiles(display[top].filechain.head);
labroot := display[level].labelroot;
while labroot <> nil do
   begin
   if not labroot^.defined then
	writeln('>>>**  label not defined ...  ', labroot^.val);
   labroot := labroot^.next
   end
end; { block }

   begin { programm }
inpnotdecl := true;
outpnotdecl := true;
settypename :=  cc32basictype;
apsymbols := [comma, rightparent];
bpsymbols := blockbegsys + [semicolon];
permfileroot := nil;
initidchain(pfileidchain);
(*kvmod*) programcomp := true;
(*kvmod*)if (symbol = programsy) or (symbol = modulesy){program/module statement
}
     then begin
(*kvmod*) if symbol = modulesy then
(*kvmod*) begin
(*kvmod*)    extension;
(*kvmod*)    programcomp := false;
(*kvmod*) end;
     insymbol;
     if symbol = ident
	  then begin
	  writeln(' compiling ',idname);
	  insymbol
	  end
     else error(2);
     if symbol = leftparent {start of list of permanent files}
	  then begin
	  repeat
	       insymbol;
	       if symbol = ident

		    then begin
		    if idname = 'OUTPUT      ' then outpnotdecl := false
		      else if idname = 'INPUT       ' then inpnotdecl := false;
		    fileentry := permfileroot;
		    while fileentry <> nil do
			begin
			if fileentry^.length = idnamelength then
			    if equal(fileentry^.name, idindex, idnamelength) then
					error(32);
				fileentry := fileentry^.next
			end;
		    new(fileentry);
		    with fileentry^ do
			 begin
			 name := idindex;
			 length := idnamelength;
			 idindex := idindex + idnamelength;
			 next := permfileroot;
			 insymbol;
			 if (symbol = relop) and (operator = eqop) then
			    begin
			    extension;
			    while ch <= space do
			    newch;
			    mussequiv := idindex;
			    repeat
			    idindex := idindex+1;
			    idarray[idindex] := ch;
			    newch;
			    until (ch <= space) or (ch = ',') or (ch = ')');
			    length := idindex - mussequiv;
			    insymbol
			    end
			 else mussequiv := name
			 end;
		    permfileroot := fileentry
		    end

	       else error(2);
	       checkpossiblesymbols(apsymbols, bpsymbols)
	  until symbol <> comma; {end of list of files}
	  accept(rightparent)
	  end;
     accept(semicolon)
     end
else error(3);
openscope(bloc);
repeat
     block(blockbegsys, period, -1)
until symbol = period; {end of program}
releasefiles(pfileidchain.head);
disposescope
end; { programm }
      procedure initlisting;{200}

(*$S1*)
var i : hashno;
     begin
     writeln;
(*kvrm *)   write('MUSS Pascal issue 11 on ');    (* kvrm*)
(*kvadd write('ks900-pascal issue 1 on ');  kvadd*)
     outdate;
     write('  at  ');
     outtime;
     writeln;
     currentlineno := 1 ;currentpageno := 1 ;{issue 11}
     errorsdiscovered := 0;
     totalerrorsdiscovered := 0;
     erroroverflow := false;
(*kvrm *)     listsource := false;    (* kvrm*)
(*kvadd   listsource := true;   kvadd*)
     listerrors := true;
     checking:=false;
     iso := true;
	putcode := true;
	printpar := 0;
     trace := false;
     export := false;
{issue 11}in16 := initin16;
simplereln := false;
     ch := space;
chval := sspace;
errorindex := 1;
withtop := -1;
for i := 0 to 511 do
   hashtable[i] := -1;
     end;

      procedure initcodegeneration;{201}

     procedure basicdescriptors;{202}
	  begin
     ccrealbasictype := %c;
	  with intdesc do
	       begin
	       size := 0;
	       packname := ccintbasictype;
	       typename := ccintbasictype;
	       vector := false;
	       kind := ordinal;
	       min := - maxint;
     min := min -1;{issue 11}
	       max := maxint
	       end;
	  with booldesc do
	       begin
	       size := 0;
	       packname := ccboolbasictype;
	       typename := ccboolbasictype;
	       vector := false;
	       kind := ordinal;
	       min := 0;
	       max := 1
	       end;
	  with chardesc do
	       begin
	       size := 0;
	       packname := cccharbasictype;
	       typename := cccharbasictype;
	       vector := false;
	       kind := ordinal;
	       min := 0;
	       max := 127
	       end;
	  with realdesc do
	       begin
	       size := 0;
	        packname := ccrealbasictype;
	       typename := ccrealbasictype;
	       vector := false;
	       kind := reals
	       end;
	  with pointerdesc do
	       begin
	       size := 0;
	       packname := ccpointerbasictype;
	       typename := ccpointerbasictype;
	       vector := false;
	       kind := defpointer;
	       bounded := true
	       end;
	  with setdesc do
	       begin
	       size := 0;
	       packname := cc32basictype;
              typename:=cc32basictype;
	       vector := false;
	       kind := sett;
	       min := 0;
	       max := 127

	       end;
	  with stringdesc do
	       begin
	       size := 0;
	       vector := true;
	       packname := cccharbasictype;
	       typename := cccharbasictype;
	       kind := struct
	       end;
	  with filedesc do
		begin
		size := 0;
		packname := filetypename;
		typename := filetypename;
		vector := false;
		kind := struct
		end;
	  with defaultdesc do
	       begin
	       size := 0;
	       packname := ccintbasictype;
	       typename := ccintbasictype;
	       vector := false;
	       kind := ordinal;
	       min := 0;
	       max := 1
	       end
	  end;

     procedure basictlnames;{203}
	  var
		    c : char;
	       b : boolean;
	       i, noofsetelems, settypename : integer;
	  begin
	  tlclit32(ccintbasictype, 0);
	  xxnameclit(zerotlname);
         tlclit32(cc32basictype,0);
         xxnameclit(emptyset);
         tlclit32(cc32basictype,1);
         xxnameclit(singleset);
	  end;


           begin { initcodegeneration }
    if in16 then ccintbasictype := ccint16basictype
     else ccintbasictype := ccint32basictype;
     tlnamecount := 1;
(*kvmod*)   insymbol;
(*kvadd    idstr^ := 'pascal-10.0 ';
{issue 11}  if symbol = programsy then
{issue 11}  begin
(*kvadd     tl(1,pstrtrunc(idstr),-1);  kvadd*)
{issue 11}     programcomp := true;
{issue 11}  end else
(*kvadd  begin                       kvadd*)
(*kvadd     tl(3,pstrtrunc(idstr),-1);  kvadd*)
{issue 11}     programcomp := false;
(*kvadd  end;                        kvadd*)
(*kvmod*)     tlmodule;
(*kvmod*)     xxtlinitialisation;
     if in16 then ccintbasictype := ccint16basictype
     else ccintbasictype := ccint32basictype;
     basicdescriptors;
     basictlnames
     end; { initcodegeneration }

      procedure initsyntax;{204}

     procedure basicsetofsymbols;{205}
	  var
		    constsys : setofsymbols;
	  begin
	  blockbegsys := [labelsy, constsy, typesy, varsy, procsy, funcsy, beginsy];
	  constsys := [nilsy, charconst, intconst, realconst, stringconst, ident];
	  constbegsys := constsys + [addop];
	  simptypebegsys := constbegsys + [leftparent];
	  facbegsys := constsys + [leftparent, leftbracket, notsy];
	  parambegsys := [procsy, funcsy, varsy, ident];
	  statbegsys := [beginsy, casesy, forsy, gotosy, ifsy, repeatsy, whilesy, withs
y];
	  typedeclsys := [arraysy, setsy, recordsy, filesy];
	  typebegsys := simptypebegsys + typedeclsys + [arrow, packedsy];
	  selectsys := [arrow, period, leftbracket]
	  end;

     procedure initcharsymbol;{206}
	  var
		    c : char;
	       i : integer;
	  begin
	  charsymbol[sat].symb := arrow;
	  charsymbol[scolon].symb := colon;
	  charsymbol[sscolon].symb := semicolon;
	  charsymbol[soparen].symb := leftparent;
	  charsymbol[sclparen].symb := rightparent;
	  charsymbol[sopbracket].symb := leftbracket;
	  charsymbol[sclbracket].symb := rightbracket;
	  charsymbol[scomma].symb := comma;
	  charsymbol[sdot].symb := period;
	  charsymbol[sarrow].symb := arrow;
       charsymbol[slt].symb := relop;
       charsymbol[sgt].symb := relop;
       charsymbol[seq].symb := relop;
	  charsymbol[slt].op := ltop;
	  charsymbol[seq].op := eqop;
	  charsymbol[sgt].op := gtop;
	  with charsymbol[splus] do
	       begin
	       symb := addop;
	       op := plus
	       end;
	  with charsymbol[sminus] do
	       begin
	       symb := addop;
	       op := minus
	       end;
	  with charsymbol[smul] do
	       begin
	       symb := mulop;
	       op := mul
	       end;
	  with charsymbol[sslash] do
	       begin
	       symb := mulop;
	       op := rdiv
	       end
	  end;

     	 procedure initdelimiters;{207}
	  var
		    i : integer;
	  begin
	  for i := 1 to nodelimiters do
	       delimiter[i].op := notop;
	  with delimiter[1] do
	       begin
	       name := 'IF          ';
	       signature := 216;
	       symb := ifsy
	       end;
	  with delimiter[2] do
	       begin
	       name := 'DO          ';
	       signature := 215;
	       symb := dosy
	       end;
	  with delimiter[3] do
	       begin
	       name := 'OF          ';
	       signature := 228;
	       symb := ofsy
	       end;
	  with delimiter[4] do
	       begin
	       name := 'TO          ';
	       signature := 247;
	       symb := tosy;
	       op := plus
	       end;
	  with delimiter[5] do
	       begin
	       name := 'IN          ';
	       signature := 224;
	       symb := relop;
	       op := inop
	       end;
	  with delimiter[6] do
	       begin
	       name := 'OR          ';
	       signature := 240;
	       symb := addop;
	       op := orop
	       end;
	  with delimiter[7] do
	       begin
	       name := 'END         ';
	       signature := 500;
	       symb := endsy
	       end;
	  with delimiter[8] do
	       begin
	       name := 'FOR         ';
	       signature := 520;
	       symb := forsy
	       end;
	  with delimiter[9] do
	       begin
	       name := 'VAR         ';
	       signature := 556;
	       symb := varsy
	       end;
	  with delimiter[10] do
	       begin
	       name := 'DIV         ';
	       signature := 504;
	       symb := mulop;
	       op := idiv
	       end;
	  with delimiter[11] do
	       begin
	       name := 'SET         ';
	       signature := 554;
	       symb := setsy
	       end;
	  with delimiter[12] do
	       begin
	       name := 'AND         ';
	       signature := 484;
	       symb := mulop;
	       op := andop
	       end;
	  with delimiter[13] do
	       begin
	       name := 'NOT         ';
	       signature := 554;
	       symb := notsy
	       end;
	  with delimiter[14] do
	       begin
	       name := 'MOD         ';
	       signature := 534;
	       symb := mulop;
	       op  := modop
	       end;
	  with delimiter[15] do
	       begin
	       name := 'NIL         ';
	       signature := 534;
	       symb := nilsy
	       end;
	  with delimiter[16] do
	       begin
	       name := 'THEN        ';
	       signature := 1176;
	       symb := thensy
	       end;
	  with delimiter[17] do
	       begin
	       name := 'ELSE        ';
	       signature := 1091;
	       symb := elsesy
	       end;
	  with delimiter[18] do
	       begin
	       name := 'WITH        ';
	       signature := 1228;
	       symb := withsy
	       end;
	  with delimiter[19] do
	       begin
	       name := 'GOTO        ';
	       signature := 1131;
	       symb := gotosy
	       end;
	  with delimiter[20] do
	       begin
	       name := 'CASE        ';
	       signature := 1031;
	       symb := casesy
	       end;
	  with delimiter[21] do
	       begin
	       name := 'TYPE        ';
	       signature := 1257;
	       symb := typesy
	       end;
	  with delimiter[22] do
	       begin
	       name := 'FILE        ';
	       signature := 1073;
	       symb := filesy
	       end;
	  with delimiter[23] do
	       begin
	       name := 'BEGIN       ';
	       signature := 2116;
	       symb := beginsy
	       end;
	  with delimiter[24] do
	       begin
	       name := 'UNTIL       ';
	       signature := 2542;
	       symb := untilsy
	       end;
	  with delimiter[25] do
	       begin
	       name := 'WHILE       ';
	       signature := 2481;
	       symb := whilesy
	       end;
	  with delimiter[26] do
	       begin
	       name := 'ARRAY       ';
	       signature := 2243;
	       symb := arraysy
	       end;
	  with delimiter[27] do
	       begin
	       name := 'CONST       ';
	       signature := 2266;
	       symb := constsy
	       end;
	  with delimiter[28] do
	       begin
	       name := 'LABEL       ';
	       signature := 2214;
	       symb := labelsy
	       end;
	  with delimiter[29] do
	       begin
	       name := 'REPEAT      ';
	       signature := 4858;
	       symb := repeatsy
	       end;
	  with delimiter[30] do
	       begin
	       name := 'RECORD      ';
	       signature := 4812;
	       symb := recordsy
	       end;
	  with delimiter[31] do
	       begin
	       name := 'DOWNTO      ';
	       signature := 4695;
	       symb := tosy;
	       op := minus
	       end;
	  with delimiter[32] do
	       begin
	       name := 'PACKED      ';
	       signature := 4642;
	       symb := packedsy
	       end;
(*kvmod*) with delimiter[33] do
(*kvmod*)      begin
(*kvmod*)      name := 'MODULE      ';
(*kvmod*)      signature := 4833;
(*kvmod*)      symb := modulesy
(*kvmod*)      end;
(*kvmod*) with delimiter[34] do
	       begin
	       name := 'PROGRAM     ';
	       signature := 10111;
	       symb := programsy
	       end;
(*kvmod*) with delimiter[35] do
	       begin
	       name := 'FUNCTION    ';
	       signature := 19168;
	       symb := funcsy
	       end;
(*kvmod*) with delimiter[36] do
	       begin
	       name := 'PROCEDURE   ';
	       signature := 20164;
	       symb := procsy
	       end;
(*kvmod*) with delimiter[37] do
	     begin
	     name := 'OTHERWISE   ';
	       signature := 20129;
	     symb := otherwisesy
	     end;
  for i := 0 to maxidentlength do
     begin
     delimstart[i] := 1;
     delimend[i] := 0
     end;
	  delimstart[2] := 7;
	  delimstart[3] := 16;
	  delimstart[4] := 23;
	  delimstart[5] := 29;
(*kvmod*) delimstart[6] := 34;
(*kvmod*) delimstart[7] := 35;
(*kvmod*) delimstart[8] := 36;
	   delimend[1] :=  6;
	   delimend[2] := 15;
	   delimend[3] := 22;
	   delimend[4] := 28;
(*kvmod*)  delimend[5] := 33;
(*kvmod*)  delimend[6] := 34;
(*kvmod*)  delimend[7] := 35;
(*kvmod*)  delimend[8] := 36;
	  end;

           procedure stdprochousekeeping;{208}
	  var
		    n : standprocs;
	  begin
	  lengthofstandproc[closep] := 5;
	  lengthofstandproc[getp] := 3;
	  lengthofstandproc[putp] := 3;
	  lengthofstandproc[resetp] := 5;
	  lengthofstandproc[rewritep] := 7;
	  lengthofstandproc[readp] := 4;
	  lengthofstandproc[writep] := 5;
	  lengthofstandproc[readlnp] := 6;
	  lengthofstandproc[writelnp] := 7;
	  lengthofstandproc[pagep] := 4;
	  lengthofstandproc[newp] := 3;
	  lengthofstandproc[disposep] := 7;
	  lengthofstandproc[packp] := 4;
	  lengthofstandproc[unpackp] := 6;
	  lengthofstandproc[absf] := 3;
	  lengthofstandproc[oddf] := 3;
	  lengthofstandproc[sqrf] := 3;
	  lengthofstandproc[sqrtf] := 4;
	  lengthofstandproc[cosf] := 3;
	  lengthofstandproc[sinf] := 3;
	  lengthofstandproc[tanf] := 3;
	  lengthofstandproc[logf] := 3;
	  lengthofstandproc[ordf] := 3;
	  lengthofstandproc[chrf] := 3;
	  lengthofstandproc[coshf] := 4;
	  lengthofstandproc[sinhf] := 4;
	  lengthofstandproc[tanhf] := 4;
	  lengthofstandproc[succf] := 4;
	  lengthofstandproc[predf] := 4;
	  lengthofstandproc[eolnf] := 4;
	  lengthofstandproc[roundf] := 5;
	  lengthofstandproc[truncf] := 5;
	  lengthofstandproc[arccosf] := 6;
	  lengthofstandproc[arcsinf] := 6;
	  lengthofstandproc[arctanf] := 6;
	  lengthofstandproc[lnf] := 2;
	  lengthofstandproc[expf] := 3;
	  lengthofstandproc[eoff] := 3;
	  nameofstandproc[closep] := 'CLOSE       ';
	  nameofstandproc[getp] := 'GET         ';
	  nameofstandproc[putp] := 'PUT         ';
	  nameofstandproc[resetp] := 'RESET       ';
	  nameofstandproc[rewritep] := 'REWRITE     ';
	  nameofstandproc[readp] := 'READ        ';
	  nameofstandproc[writep] := 'WRITE       ';
	  nameofstandproc[readlnp] := 'READLN      ';
	  nameofstandproc[writelnp] := 'WRITELN     ';
	  nameofstandproc[pagep] := 'PAGE        ';
	  nameofstandproc[newp] := 'NEW         ';
	  nameofstandproc[disposep] := 'DISPOSE     ';
	  nameofstandproc[packp] := 'PACK        ';
	  nameofstandproc[unpackp] := 'UNPACK      ';
	  nameofstandproc[absf] := 'ABS         ';
	  nameofstandproc[oddf] := 'ODD         ';
	  nameofstandproc[sqrf] := 'SQR         ';
	  nameofstandproc[sqrtf] := 'SQRT        ';
	  nameofstandproc[cosf] := 'COS         ';
	  nameofstandproc[sinf] := 'SIN         ';
	  nameofstandproc[tanf] := 'TAN         ';
	  nameofstandproc[logf] := 'LOG         ';
	  nameofstandproc[ordf] := 'ORD         ';
	  nameofstandproc[chrf] := 'CHR         ';
	  nameofstandproc[coshf] := 'COSH        ';
	  nameofstandproc[sinhf] := 'SINH        ';
	  nameofstandproc[tanhf] := 'TANH        ';
	  nameofstandproc[succf] := 'SUCC        ';
	  nameofstandproc[predf] := 'PRED        ';
	  nameofstandproc[eolnf] := 'EOLN        ';
	  nameofstandproc[roundf] := 'ROUND       ';
	  nameofstandproc[truncf] := 'TRUNC       ';
	  nameofstandproc[arccosf] := 'ARCCOS      ';
	  nameofstandproc[arcsinf] := 'ARCSIN      ';
	  nameofstandproc[arctanf] := 'ARCTAN      ';
	  nameofstandproc[lnf] := 'LN          ';
	  nameofstandproc[expf] := 'EXP         ';
	  nameofstandproc[eoff] := 'EOF         ';
	  {file handling procedures}
	  for n := closep to eolnf do
	       groupofstandproc[n] := filehandling;
	  for n := newp to disposep do
	       groupofstandproc[n] := dynamstore;
	  for n := packp to unpackp do
	       groupofstandproc[n] := transf;
	  for n := absf to tanhf do
	       groupofstandproc[n] := maths;
	  for n := succf to predf do
	       groupofstandproc[n] := ordinals;
	  for n := ordf to roundf do
	       groupofstandproc[n] := conv;
	  for n := resetp to eolnf do
	       fileoperation[n] := inp;
	  for n := rewritep to pagep do
	       fileoperation[n] := outp;
	  {maths functions}
	  ccmfncode[absf] := 0;
	  ccmfncode[oddf] := 13;
	  ccmfncode[sqrtf] := 13;
	  ccmfncode[sinf] := 14;
	  ccmfncode[cosf] := 15;
	  ccmfncode[lnf] := 16;
	  ccmfncode[expf] := 17;
	  ccmfncode[logf] := 18;
	  ccmfncode[tanf] := 19;
	  ccmfncode[arcsinf] := 20;
	  ccmfncode[arccosf] := 21;
	  ccmfncode[arctanf] := 22;
	  ccmfncode[sinhf] := 25;
	  ccmfncode[coshf] := 26;
	  ccmfncode[tanhf] := 27;
	  end;

           procedure otherinitialisations;{209}
	  var
	cht : chtype;
		    i : integer;
	       symb : symboltype;
	       op : optype;
            c : char;
	  begin
	  linefeed := chr(ilinefeed);
	
	  with defaulconstant do
	       begin
	       kind := intkind;
	       ival := 0
	       end;
(*kvmod*)  for cht := d0 to d9 do
(*kvmod*)         valchs[cht] := chr(ord(cht)+ord('0'));
(*kvmod*)  valchs[sundersc] := '_';
(*kvmod*)  for cht := la to lz do
(*kvmod*)      valchs[cht] := chr(ord(cht)-ord(la)+ord('A'));
  for c := chr(0) to chr(127) do
      chvals[c] := sothers;
  cht := d0;
  for c := '0' to '9' do
      begin
      chvals[c] := cht;
      cht := succ(cht)
      end;
(*kvmod*)chvals['_'] := cht;
(*kvmod*)cht := succ(cht);
  for c := 'A' to 'Z' do
      begin
      chvals[c] := cht;
      cht := succ(cht)
      end;
  cht := la;
  for c := 'a' to 'z' do
      begin
      chvals[c] := cht;
      cht := succ(cht)
      end;
  chvals['{'] := soparen;
  chvals['}'] := squestion;
  chvals[''''] := squote;
  chvals['('] := soparen;
  chvals[':'] := scolon;
  chvals['.'] := sdot;
  chvals['<'] := slt;
  chvals['>'] := sgt;
  chvals['*'] := smul;
  chvals['!'] := sshriek;
  chvals['"'] := sdquote;
  chvals['#'] := spound;
  chvals['$'] := sdollar;
  chvals['&'] := sand;
  chvals['='] := seq;
(*kvrm *)  chvals[' '] := sbslash;          (* kvrm*)
(*kvadd   chvals[chr(8)] := sbslash;  kvadd*)
  chvals['@'] := sat;
  chvals['['] := sopbracket;
  chvals['+'] := splus;
  chvals[';'] := sscolon;
  chvals['-'] := sminus;
  chvals['^'] := sarrow;
  chvals[')'] := sclparen;
  chvals['`'] := sgrave;
  chvals['~'] := stilda;
  chvals['|'] := sbar;
  chvals[']'] := sclbracket;
  chvals[','] := scomma;
  chvals['/'] := sslash;
  chvals['?'] := squestion;
  chvals[' '] := sspace;
  chvals[linefeed] := snewline;
  chvals['%'] := spercent;
	
	  for symb := ident to ddot do
	       missingsymbolerrorcode[symb] := 6;
          missingsymbolerrorcode[programsy]:=3;
          missingsymbolerrorcode[rightparent]:=4;
          missingsymbolerrorcode[colon]:=5;
          missingsymbolerrorcode[ofsy]:=8;
          missingsymbolerrorcode[leftparent]:=9;
          missingsymbolerrorcode[leftbracket]:=11;
          missingsymbolerrorcode[rightbracket]:=12;
          missingsymbolerrorcode[endsy]:=13;
          missingsymbolerrorcode[semicolon]:=14;
          missingsymbolerrorcode[relop]:=16;
          missingsymbolerrorcode[beginsy]:=17;
          missingsymbolerrorcode[comma]:=20;
          missingsymbolerrorcode[mulop]:=21;
         missingsymbolerrorcode[thensy]:=24;
         missingsymbolerrorcode[untilsy]:=25;
         missingsymbolerrorcode[dosy]:=26;
         missingsymbolerrorcode[tosy]:=27;
         missingsymbolerrorcode[ifsy]:=28;
         missingsymbolerrorcode[filesy]:=29;
	    missingsymbolerrorcode[ddot] := 118;

	  {initialisation of reverse operators}
	  for op := mul to notop do
	       oppoperator[op] := op;
	  oppoperator[rdiv] := revrdiv;
	  oppoperator[idiv] := revidiv;
	  oppoperator[minus] := revminus;
	  oppoperator[revminus] := minus;
	  oppoperator[ltop] := gtop;
	  oppoperator[leop] := geop;
	  oppoperator[geop] := leop;
	  oppoperator[gtop] := ltop;
	  ccjumpop[ltop] := ifgetr;
	  ccjumpop[leop] := ifgttr;
	  ccjumpop[geop] := iflttr;
	  ccjumpop[gtop] := ifletr;
	  ccjumpop[neop] := ifeqtr;
	  ccjumpop[eqop] := ifnetr;
	  {pointers}
	  ccitempointer[false] := ccunboundeditempointer;
	  ccitempointer[true] := ccboundeditempointer;
	  {initialisation of operator mutl names}
	  ccopcode[andop] := logicaland;
	  ccopcode[orop] := logicalor;
	  ccopcode[plus] := add;
	  ccopcode[minus] := subtract;
	  ccopcode[revminus] := revsubtract;
	  ccopcode[mul] := multiply;
	  ccopcode[rdiv] := divide;
	  ccopcode[idiv] := divide;
	  ccopcode[revrdiv]:=revdivide;
	  ccopcode[revidiv]:=revdivide;
         ccsetopcode[mul]:=logicaland;
         ccsetopcode[plus]:=logicalor;
         ccsetopcode[neop]:=comp;
         ccsetopcode[eqop]:=comp;
	
	  cctregstate[leop] := tregle;
	  cctregstate[ltop] := treglt;
	  cctregstate[neop] := tregne;
	  cctregstate[eqop] := tregeq;
	  cctregstate[geop] := tregge;
	  cctregstate[gtop] := treggt;
	
	  ccregname[b] := breg;
	  ccregname[a] := areg;
	  ccregname[d] := dreg;
	
	  ccregfunccode[b] := bregfunccode;
	  ccregfunccode[a] := aregfunccode;
	  ccregfunccode[d] := dregfunccode;
	
	  retainentry := true;
	  defauldeclaration := false;
	  createidentry := true;
	  usebreg := false;
	
	  aregmode := 0;
	  lastfreeid := -1;
	  topid := 0;
     idindex := 1;
	  nullsymbname := topid;
     topid := topid + 1;
	  worksymbname := topid;
	  with idrecs[nullsymbname] do
	begin
	iindex := 0;
	length := 0
	end;
	  new(stringelement)
	
	
	  end;

        begin { initsyntax }
     basicsetofsymbols;
     initcharsymbol;
     initdelimiters;
     stdprochousekeeping;
     otherinitialisations
     end; { initsyntax }

   procedure initsemantic;{210}

     procedure initscope;{211}
	  begin
	  top := 0;
	  level := 0;
	  with display[0] do
	       begin
	       scope := bloc;
	       initialtlname := tlnamecount;
	       idscope := -1;
	       typeroot := nil;
	       labelroot := nil
	       end
	  end;

     procedure standtypentries;{212}
	
	  function newstandtypentry( entry : typentry): typentry;{213}
	       begin
	       new(entry, scalars, standard);
	       with entry^ do
		    begin
		    form := scalars;
		    scalarkind := standard
		    end;
newstandtypentry := entry
	       end;
	
	  begin  {standtypentries}
	  booltype :=newstandtypentry(booltype);
	  booltype^.desc := booldesc;
	  chartype :=newstandtypentry(chartype);
	  chartype^.desc := chardesc;
	  inttype := newstandtypentry(inttype);
	  inttype^.desc := intdesc;
	  real32type :=newstandtypentry(real32type);
	  real32type^.desc := realdesc;
	  real64type := newstandtypentry(real64type);
	  real64type^.desc := realdesc;
	  real64type^.desc.typename := %1c;
	{issue 11}if rlit32 then realcompiletimetype := real32type
				else realcompiletimetype := real64type;
	  new(pointertype, pointers);
	  with pointertype^ do
	       begin
	       desc := pointerdesc;
	       form := pointers;
	       domaintype := nil
	       end;
	  new(settype, sets);
	  with settype^ do
	       begin
	       desc := setdesc;
	       form := sets;
	       basetype := nil
	       end;
	  new(texttype, files);
	  with texttype^ do
	       begin
	       desc := filedesc;
	       form := files;
	       componenttype := chartype;
	       bufalt := 0;
	       sequence := chars
	       end
	  end;

           procedure standidentries;{214}
	  var
		    entry, lastentry : identry;
	       klass : idclass;
	       stdproc : standprocs;
	
    { new proc to add standard identifiers to identifier list }
     procedure standid(name:identname;length : identlength);
	var i : integer;
	begin
	for i := 1 to length do
	  begin
	  idarray[idindex + i] := name[i]
	  end;
	idname := name;
	idnamelength := length
	end;

	  procedure newboolconstid(name : identname; length : identlength; val1 : boole
an);{215}
	       begin
	       standid(name,length);
	       entry := newid(consts);
	       with idrecs[entry], val do
		    begin
		    notyetdefined := false;
		    next := lastentry;
		    idtype := booltype;
		    kind := boolkind;
		    bval := val1
		    end
	       end;
	
	  procedure newtypeid(name : identname;length : identlength; entrytype : typent
ry);{216}
	       var
			 entry : identry;
	       begin
	       standid(name,length);
	       entry := newid(types);
	       idrecs[entry].notyetdefined := false;
	       idrecs[entry].idtype := entrytype
	       end;
	
	  procedure newstandfile(name : identname; length : identlength; var entry : id
entry);{217}
	       begin
	       standid(name,length);
	       entry:= newid(vars);
	       with idrecs[entry] do
		    begin
		    idtype := texttype;
		    varkind := filevar;
		    end;
	       end;
	
	  procedure newextproc(name : identname; length : integer; var proctlname : mut
lname);{218}
	       var
inlib : boolean;
			 entry : identry;
	       begin
	       idname := name;
	       standid(name,length);
	       idnamelength := length;
inlibrary(entry,false,inlib);
	       if inlib
		    then proctlname := idrecs[entry].tlname
	       else begin
		    writeln( '>>>**   external proc ', idname,' used by compiler not found');
		    proctlname := 0
		    end
	       end;
	
	        begin { standidentries }
	  defauldeclaration := true;
	  standid('MAXINT      ', 6);
	  entry := newid(consts);
	  with idrecs[entry] do
	       begin
		notyetdefined := false;
	       idtype := inttype;
		val.kind := intkind;
	       val.ival := maxint
	       end;
	  lastentry := -1;
	  newboolconstid('TRUE        ', 4, true);
	  lastentry := entry;
	  newboolconstid('FALSE       ', 5, false);
	  booltype^.constidroot := entry;
	  newtypeid('BOOLEAN     ', 7, booltype);
	  newtypeid('CHAR        ', 4, chartype);
	  newtypeid('INTEGER     ', 7, inttype);
	  newtypeid('REAL        ', 4, real32type);
	  realid := topid;
	  newtypeid('TEXT        ', 4, texttype);
	  newstandfile('INPUT       ', 5,infileid);
	  newstandfile('OUTPUT      ', 6, outfileid);
	 nilconst.kind := pointerkind;
	  for stdproc := newp to readlnp do
	       begin
	       standid(nameofstandproc[stdproc], lengthofstandproc[stdproc]);
	       entry := newid(proc);
	       with idrecs[entry] do
		    begin
		    kind := standard;
		    index := stdproc
		    end
	       end;
	  for stdproc := eoff to tanhf do
	       begin
	       standid( nameofstandproc[stdproc], lengthofstandproc[stdproc]);
	       entry := newid(func);
	       with idrecs[entry] do
		    begin
		    kind := standard;
		    index := stdproc
		    end
	       end;
	  standid('DEFAULT     ',7);
	 idname := 'DEFAULT     ';
	  for klass := types to func do
	       begin
	       idname[8] := chr(ord(klass)+ ord('0'));
	       standid(idname,8);
	       defaultid[klass] :=newid(klass);
	       end;
	  newextproc('setelem     ', 7, setelemtlname);
	  newextproc('setrange    ', 8, setrangetlname);
	  newextproc('outlineno   ', 9, outlinenotlname);
{issue11}
	  newextproc('selectinput ', 11, sitlname);
	  newextproc('selectoutput', 12, sotlname);
{issue11}
	  newextproc('ienq        ', 4, ienqtlname);
{issue11}
	  newextproc('inch        ', 4, inchtlname);
	  newextproc('inbackspace ', 11, ibstlname);
	  newextproc('skipline    ', 8, sltlname);
	  newextproc('outch       ', 5, outchtlname);
	  newextproc('ini         ', 3, initlname);
	  newextproc('outint      ', 6, outitlname);
	  newextproc('outreal     ', 7, outrealtlname);
	  newextproc('outbool     ', 7, obooltlname);
	  newextproc('spaces      ', 6, sptlname);
	  newextproc('newlines    ', 8, nltlname);
	  newextproc('outstring   ', 9, outstrtlname);
	  newextproc('inbool      ', 6, inbooltlname);
	  newextproc('inreal      ', 6, inrealtlname);
	  newextproc('instring    ', 8, instrtlname);
	newextproc('entertrap   ',9,traptlname);
	newextproc('movearray   ',9,movearraytlname);
newextproc('initpio     ', 7, inittlname);
newextproc('makeheap    ', 8, maketlname);
newextproc('removeheap  ', 10, removetlname);
	newextproc('pget        ',4,pgettlname);
	newextproc('pclosefile  ',10,pclosetlname);
{issue 11}newextproc('nextch      ',6,nextchtlname);
{issue 11}newextproc('pbuffvar    ',8,pbuffvtlname);
	  defauldeclaration := false
	  end; { standidentries }

     begin { initsemantic }
     initscope;
     standtypentries;
     standidentries
     end; { initsemantic }

   procedure endlisting;{219}
     begin
     writeln;
     writeln;
     writeln('compilation completed');
write(' ' : 5, 'with');
     if totalerrorsdiscovered = 0
	  then writeln('out any error')
     else writeln(' ', totalerrorsdiscovered, ' error(s)')
     end;

procedure endcodegeneration;{220}
     begin

     tlendmodule(totalerrorsdiscovered);
     if par3 mod %400 = par3 mod %800 then
     tlend;
	writeln
     end;

procedure errormessage;{221}
var errorstring : packed array[1..30] of char;
begin
case code of
1 : errorstring := 'error in simple type          ';
2: errorstring := 'identifier expected           ';
3: errorstring := '''program'' expected            ';
4: errorstring := ''')'' expected                  ';
5: errorstring := ''':'' expected                  ';
6: errorstring := 'illegal symbol                ';
7: errorstring := 'error in parameter list       ';
8: errorstring := '''of'' expected                 ';
9: errorstring := '''('' expected                  ';
10: errorstring := 'error in type                 ';
11: errorstring := '''['' expected                  ';
12: errorstring := ''']'' expected                  ';
13: errorstring := '''end'' expected                ';
14: errorstring := ''';'' expected                  ';
15: errorstring := 'integer expected              ';
16: errorstring := '''='' expected                  ';
17: errorstring := '''begin'' expected              ';
18: errorstring := 'error in declaration part     ';
19: errorstring := 'error in field-list           ';
20: errorstring := '''.'' expected                  ';
21: errorstring := '''*'' expected                  ';
22: errorstring := 'error in constant             ';
23: errorstring := ''':='' expected                 ';
24: errorstring := '''then'' expected               ';
25: errorstring := '''until'' expected              ';
26: errorstring := '''do'' expected                 ';
27: errorstring := '''to''/''downto'' expected        ';
28: errorstring := '''if'' expected                 ';
29: errorstring := '''file'' expected               ';
30: errorstring := 'error in factor               ';
31: errorstring := 'error in variable             ';
32: errorstring := 'identifier declared twice     ';
33: errorstring := 'low bound>high bound          ';
34: errorstring := 'wrong identifier class        ';
35: errorstring := 'identifier not declared       ';
36: errorstring := 'sign not allowed              ';
37: errorstring := 'number expected               ';
38: errorstring := 'incompatible subrange types   ';
39: errorstring := 'file not allowed here         ';
40: errorstring := 'type must not be real         ';
41: errorstring := 'tagfield type must be ordinal ';
42: errorstring := 'incomptible with tagfield type';
43: errorstring := 'index type must not be real   ';
44: errorstring := 'index type must be ordinal    ';
45: errorstring := 'base type must not be real    ';
46: errorstring := 'base type must be ordinal     ';
47: errorstring := 'standard proc param type error';
48: errorstring := 'unsatisfied forward reference ';
49: errorstring := 'illegal forward ref. type     ';
50: errorstring := 'repetition of param list      ';
51: errorstring := 'illegal result type           ';
52: errorstring := 'file value param not allowed  ';
53: errorstring := 'repetition of result type     ';
54: errorstring := 'result type missing           ';
55: errorstring := 'e-format for real only        ';
56: errorstring := 'standard fn. param type error ';
57: errorstring := 'no. params not as declared    ';
58: errorstring := 'illegal parameter substitution';
59: errorstring := 'result type not as declared   ';
60: errorstring := 'type conflict                 ';
61: errorstring := 'expression not of set type    ';
62: errorstring := 'tests on equality allowed only';
63: errorstring := 'strict inclusion not allowed  ';
64: errorstring := 'file comparison not allowed   ';
65: errorstring := 'illegal type of operand(s)    ';
66: errorstring := 'operand type must be boolean  ';
67: errorstring := 'set element must be ordinal   ';
68: errorstring := 'setelement types incompatible ';
69: errorstring := 'type of variable is not array ';
70: errorstring := 'index type not as declared    ';
71: errorstring := 'variable type is not record   ';
72: errorstring := 'file or pointer allowed only  ';
73: errorstring := 'negative mod operand          ';
74: errorstring := 'illegal type of expression    ';
75: errorstring := 'file assignment not allowed   ';
76: errorstring := 'incompatible case label type  ';
77: errorstring := 'subrange bounds must be scalar';
78: errorstring := 'integer index type not allowed';
79: errorstring := 'no such field in this record  ';
80: errorstring := 'type error in read            ';
81: errorstring := 'actual param must be variable ';
82: errorstring := 'control variable must be local';
83: errorstring := 'real/string tag not allowed   ';
84: errorstring := 'multi-defined case label      ';
85: errorstring := 'too many cases                ';
86: errorstring := 'no variant corresponds        ';
87: errorstring := 'declared before: not forward  ';
88: errorstring := 'declared forward before       ';
89: errorstring := 'missing variant in declaration';
90: errorstring := 'standard proc/func not allowed';
91: errorstring := 'multi-defined label           ';
92: errorstring := 'multi-declared label          ';
93: errorstring := 'undeclared label              ';
95: errorstring := 'error in base set             ';
96: errorstring := 'undeclared external file      ';
97: errorstring := 'prog heading: "input" missing ';
98: errorstring := 'prog heading: "output" missing';
99: errorstring := 'digit expected                ';
100: errorstring := 'string exceeds source line    ';
101: errorstring := 'constant out of range         ';
102: errorstring := 'too many nested ident scopes  ';
103: errorstring := 'too many nested procs/funcs   ';
104: errorstring := 'division by zero              ';
105: errorstring := 'no case for this value        ';
106: errorstring := 'index expression out of bounds';
107: errorstring := 'value out of bounds           ';
108: errorstring := 'element out of range          ';
109: errorstring := 'too many identifiers          ';
110: errorstring := 'label declared at outer level ';
111: errorstring := 'comparison not allowed here   ';
112: errorstring := 'constant must not be "nil"    ';
113: errorstring := 'conformant array size unknown ';
114: errorstring := 'space required after number   ';
115: errorstring := 'component of packed type      ';
116: errorstring := 'assignment to control variable';
117: errorstring := 'jump into for/case/if etc.    ';
118: errorstring := '".." expected                 ';
119,120,
121,122,123,124,125
   : errorstring := 'implementation restriction    ';
126: errorstring := 'only text files allowed here  ';
127: errorstring := 'not allowed on standard file  '
end;
writeln(errorstring)
end;





   begin { pascal }
(*kvrm *) initpio; (* kvrm*)
{issue 11}for i := firstcompwsseg to firstcompwsseg + nocompwssegs -1 do
begin
  releasesegment(i);
  createsegment(i,0)
end;{issue 11}
scopenumber := 0;
maxtop := 0;
(*kvrm *) ci := currentinput; (* kvrm*)
(*kvrm *) progstream := defineinput(-1,prog,%80); {issue11} (* kvrm*)
(*kvrm *) selectinput(progstream); (* kvrm*)
(*kvrm *)
if par3 mod %800 = par3 mod %1000 then
   tl(par3,resfile,par4);
(* kvrm*)
freeregisters;
new(idstr);
(*kvadd  kvinit;  kvadd*)
(*kvmod*) outerleveltest := 0;
initstagepassed := false;
initlisting;
(*kvadd  initextprocs;  kvadd*)
initsyntax;
initcodegeneration;
initsemantic;
(*kvadd  dispose(extprocpoint);  kvadd*)
initstagepassed := true;
(*kvmod*)if programcomp then
(*kvmod*)begin
(*kvmod*)   xxplant(stkl, inittlname);
(*kvmod*)   xxendproccallseq(0);
(*kvmod*)end;
idrecs[infileid].tlname := inpfiletlname;
idrecs[outfileid].tlname := outpfiletlname;
programm;
printsourceline;
1 : (*kvrm *) selectinput(ci); (* kvrm*)
(*kvrm *) endinput(progstream,0); (* kvrm*)
if (par3 div 4) mod 2 = 0 then
(*kvmod*)if programcomp then
  begin
  (*mu6g*)tlclit32(ccint,0);
  xxplant(stkl,removetlname);
  stacknamedparam(0,ccint);
  stacknamedparam(0,ccint);
  xxplant(enter,0)
  end;
endlisting;
endcodegeneration;
{issue 11} for i := firstcompwsseg to firstcompwsseg + nocompwssegs -1 do
  releasesegment(i);
end; { pascal }
begin
(*kvadd  prog := nil;                      kvadd*)
(*kvadd  resfile := nil;                   kvadd*)
(*kvadd  par3 := 1;                        kvadd*)
(*kvadd  par4 := -1;                       kvadd*)
(*kvadd  pascal(prog,resfile,par3,par4);   kvadd*)
end.
