{$M-,X+}
program pp;

include {NOLIST} 'pascal:extern.pas';
include {NOLIST} 'domain:mdep.def';
include {NOLIST} 'domain:master.def';
include {NOLIST} 'domain:pp.def';
include {NOLIST} 'domain:msub.hdr';
include {NOLIST} 'domain:eutil.hdr';
include {NOLIST} 'domain:iomsg.hdr';

{	**********************************************************

	This file contains procedures for converting between
	character strings and encoded representations for domain
	types, classes, times etc.

	All of these procedures use PASCAL type atom for their
	character strings; all procedures to convert from character
	strings are functions that return true if the conversion
	was without error

	********************************************************** }

			      
var	port_tbl,              {assigned port keywords/decimals}
	ptcl_tbl,	       {assigned protocol keywords/decimals}
        general:pptbl_ptr;     {dtype, qtype, dclass, qclass, rcodes}

function cvint( var inarg:atom;
		var outarg:integer ):boolean;

var	i,sum:integer;

begin
i:=1;
sum:=0;
while (i<=max_atom_chars) and (inarg[i] in ['0'..'9'])
do	begin
	sum:=sum*10+ord(inarg[i])-ord('0');
	i:=i+1
	end;
if (i=16) or (inarg[i]=' ')
then	begin
	cvint:=true;
	outarg:=sum
	end
else	cvint:=false

end; { cvint }


procedure ppint(     number:integer;
		 var myatom:atom );

var	i:integer;

	procedure outdig(x:integer);
	    var j:integer;
	begin
	if (x div 10)>0
	then	outdig(x div 10);
	if i>max_atom_chars
	then for j:=1 to max_atom_chars
	     do myatom[j]:='*'
	else myatom[i]:=chr(ord('0')+x mod 10);
	i:=i+1
	end; { outdig }

begin	
for i:=1 to max_atom_chars
do 	myatom[i]:=' ';

if number<0
then begin
	 myatom[i]:='-';
	 number:=-number;
	 i:=2
	 end
else i:=1;
outdig(number)

end; { ppint }


function cvtime( var inarg:atom;
		 var outarg:itime):boolean;

begin
cvtime:=cvint(inarg,outarg)
end; { cvtime }
procedure cvnnp(    dnp:node_pointer;
		  var bp:g1bpt);

{	CVDNP converts a node pointer to a string

	it increments the byte pointer as it goes }

var	ll,i,byte:integer;

begin { cvnnp }
while dnp<>NIL
do	begin
	    with dnp^.node_label
	    do	begin
		    ll:=labptr^.text[0];
		    xidpb(bp,ll);
		    for i:=1 to ll
		    do begin
		       byte:=labptr^.text[i];
		       if case_mod[i]
		       then byte:=byte+40b;
		       xidpb(bp,byte)
		       end
		end;
	    dnp:=dnp^.up_ptr
	end
end; { cvnnp }
procedure cvdnp(    dnp:dname_pointer;
		  var bp:g1bpt);

{	CVDNP converts a dname pointer to a string

	it increments the byte pointer as it goes }

var	i,ll,byte:integer;

begin { cvdnp }
while dnp<>NIL
do	begin
	    with dnp^.dlabel
	    do	begin
		    ll:=labptr^.text[0];
		    xidpb(bp,ll);
		    for i:=1 to ll
		    do begin
		       byte:=labptr^.text[i];
		       if case_mod[i]
		       then byte:=byte+40b;
		       xidpb(bp,byte)
		       end
		end;
	    dnp:=dnp^.more
	end
end; { cvdnp }
procedure ccvdnp(    dnp:dname_pointer;
		  var bp:g1bpt);

{	CCVDNP converts a dname pointer to a string
	without case i.e. upper case

	it increments the byte pointer as it goes }

var	i:integer;

begin { ccvdnp }
while dnp<>NIL
do	begin
	    with dnp^.dlabel.labptr^
	    do	for i:=0 to text[0]
		do xidpb(bp,text[i]);
 	    dnp:=dnp^.more
	end
end; { ccvdnp }
function cvdname( var iname:big_atom; 
		  var dn:exp_dname ):boolean;

type	string40=packed array[1..40] of char;

var	i:integer;
	index:integer;
	ok:boolean;
	origin:exp_dname;

	procedure error(x:string40);

	begin
	ok:=false
	end;

	function ismore:boolean;

	begin
	ismore:=index<=max_big_atom_chars
	end;

	function issep:boolean;

	begin
	issep:=(iname[index]=' ') or (iname[index]=chr(tab))
	end;

	function isdot:boolean;

	begin
	isdot:=iname[index]='.'
	end;

	function getch:integer;

	begin
	getch:=ord(iname[index]);
	index:=index+1
	end;

	procedure toss_blanks;

	var	toss:integer;

	begin
	while issep
	do	toss:=getch
	end;

begin
index:=1;
ok:=not issep;
origin.count:=1;
origin.dlabels[1].labinfo[0]:=0;

{ ***** reprinted from fload.pas ***** }
dn.count:=0;
toss_blanks;

if ismore and ok
then	begin
	while not(issep) and ismore
	do	begin
		dn.count:=dn.count+1;
		with dn.dlabels[dn.count]
		do	begin
			labinfo[0]:=0;	{ initialize label }
			while ismore and ok and not(issep) and not(isdot)
			do	if labinfo[0]<63
				then	begin
					labinfo[0]:=labinfo[0]+1;
					labinfo[labinfo[0]]:=getch;
					end
				else	error('Label length                            ');
			end;
		dlcase(dn.dlabels[dn.count]);	{ set up modifier bits }
		if issep or not(ismore)
		then	{ add origin to domain name }
			if origin.count=0
			then	error(' zero origin added to relative label    ')
			else	for i:=1 to origin.count
				do	begin
					dn.count:=dn.count+1;
					dn.dlabels[dn.count]:=origin.dlabels[i]
					end
		else	if isdot
			then	begin
				index:=index+1;	{ old csaved:=false }
				if not(ismore) or issep	{ add implied root }
				then	if (dn.count<>1)
						or
					   (dn.dlabels[1].labinfo[0]<>0)
					then	begin
						dn.count:=dn.count+1;
						dn.dlabels[dn.count].labinfo[0]:=0
						end
				end
			else	error('Label termination error                 ')
		end
	end
else	error(' error                                  ');

cvdname:=ok;

end; {cvdname}

procedure ppina(     inarg:integer;
		 var outarg:atom);

{	PPINA pretty prints an internet address
}

var	i:integer;
	outptr:integer;
	temp:integer;

	procedure outnum(x:integer);

	var	digit:integer;

	begin
	if x<>0
	then	begin
		digit:=x mod 10;
		outnum(x div 10);
		outarg[outptr]:=chr(digit+ord('0'));
		outptr:=outptr+1
		end
	end; { outnum }

begin
outptr:=1;
for i:=3 downto 0
do	begin
	temp:=band(bshift(inarg,-(i*8)),377b);
	if temp=0
	then	begin
		outarg[outptr]:='0';
		outptr:=outptr+1
		end
	else	outnum(temp);
	if i<>0
	then	begin
		outarg[outptr]:='.';
		outptr:=outptr+1
		end
	end;

if outptr<=max_atom_chars
then	for i:=outptr to max_atom_chars
	do	outarg[i]:=' '

end; { ppina }

function cvina( var inarg:atom;
		var outarg:integer):boolean;

var	inptr:integer;
	ok:boolean;
	oct:array[1..4] of integer;

	procedure getdot;

	begin
	if inptr>max_atom_chars
	then	ok:=false
	else	if inarg[inptr]='.'
		then	inptr:=inptr+1
		else	ok:=false
	end; { getdot }

	procedure getoct(which_oct:integer);

	var	sum:integer;
		more:boolean;
	begin
	if inptr>max_atom_chars
	then	ok:=false
	else	if inarg[inptr] in ['0'..'9']
		then	begin
			sum:=0;
			{accumulate number }
			repeat	more:=inptr<=max_atom_chars;
				if more
				then	more:=inarg[inptr] in ['0'..'9'];
				if more
				then	begin
					sum:=sum*10
						+ord(inarg[inptr])-ord('0');
					inptr:=inptr+1
					end
			until	not more;
			if (sum>=0) and (sum<=255)
			then	oct[which_oct]:=sum
			else	oct[which_oct]:=0
			end;
	end; { getoct }

begin
inptr:=1;	{ scan from beginning }
ok:=true;	{ presume it works }
getoct(1);
getdot;
getoct(2);
getdot;
getoct(3);
getdot;
getoct(4);
if ok
then	if inptr<=max_atom_chars
	then	ok:=inarg[inptr]=' ';
if	ok
then	outarg:=bshift(oct[1],24)+
		bshift(oct[2],16)+
		bshift(oct[3],8)+
		oct[4];
cvina:=ok

end; { cvina }

{ TABLE ACCESS ROUTINES }


function mtch_atom( inarg:atom;
		    attr:pp_types ):pp_ptr;

{ Match inarg/attr to a key/attribute entry.  Determine
  the table in which to search by the value of attr.
  Return a pointer to the table entry, or NIL if not found. }
  
var	index:integer;
	found, done:boolean;
	myatom:atom;
	ptr:pp_ptr;
	keytbl:pptbl_ptr;
	
begin  {mtch_atom}
    found:=false;

    {determine table to use}
    case attr of
	port: keytbl:=port_tbl;
	ptcl: keytbl:=ptcl_tbl;
	others: keytbl:=general;
    end;

    caseatom(inarg, myatom);  {to upper case}
    index:= ord(myatom[1]) - ord('A');
    if (index<0) or (index>25)
    then ptr:=keytbl^.table[26]  {first char not a letter}
    else ptr:=keytbl^.table[index];

    done:=(ptr=NIL);
    while not done do
    begin
	if (myatom=ptr^.key) and
	    (attr=ptr^.attribute)
	then begin
		 found:=true;
		 done:=true;
	     end
	else if ptr^.key>myatom  
	     then done:=true  {stop if successor reached}
	     else ptr:=ptr^.key_next;
        done:=done or (ptr=NIL);
    end;
 
    if found
    then mtch_atom:=ptr	
    else mtch_atom:=NIL;
end;  {mtch_atom}


function mtch_int( inarg:integer;
		   attr:pp_types ):pp_ptr;


{ Match the integer/attr given to a num/attribute.
  Determine the table in which to search by the
  type of the attribute.  Return a pointer to
  the pp_rec containing the match, or NIL if not
  found. }

var	done, found:boolean;
	ptr:pp_ptr;
	keytbl:pptbl_ptr;

begin {mtch_int}
    {determine table to use}
    case attr of
	port: keytbl:=port_tbl;
	ptcl: keytbl:=ptcl_tbl;
	others: keytbl:=general;
    end;
	
    ptr:=keytbl^.num_head;
    done:=(ptr=NIL);
    found:=false;

    while not done do
    begin	
	if attr<>ptr^.attribute  {attribute doesn't match}
	then ptr:=ptr^.num_next
	else  {now check for integer match}
	    if inarg=ptr^.num
	    then found:=true    
	    else if ptr^.num>inarg  {passed possible match already}
		 then done:=true
		 else ptr:=ptr^.num_next;
	done:=done or found or (ptr=NIL);
    end; 

    if found
    then mtch_int:=ptr
    else mtch_int:=NIL;
end;  {mtch_int}
function v_type(raw_value:integer;
		   var out_value:dtype):boolean;
begin
if (raw_value>ord(dtype_l_bound)) and (raw_value<ord(dtype_h_bound))
then begin
	 out_value:=chrtype(raw_value);
	 v_type:=true
     end
else v_type:=false
end; { v_type }

function tmatch(	mydclass:dclass;
			myqtype:qtype;
			mydtype:dtype):boolean;

{	TMATCH decides whether the type is responsive to the particular
	qtype
}
begin
if ord(mydtype)=myqtype
then	tmatch:=true
else	case myqtype of

	star:	tmatch:=true;

	maila:	tmatch:=mydtype in [md,mf];

	mailb:	tmatch:=mydtype in [mb,mg,mr];

	others:	tmatch:=false

	end { case }

end; { tmatch }
function cvtype( var inarg:atom;
		 var outarg:dtype ):boolean;

var	ptr:pp_ptr;  

begin  {cvtype}
    outarg:=dtype_h_bound;  {default return}
    ptr:=mtch_atom(inarg, dty);
    if ptr<>NIL
    then outarg:=ptr^.pp_dty;
    cvtype:=(outarg>dtype_l_bound) and (outarg<dtype_h_bound);
end; {cvtype}


procedure pptype(     inarg:dtype;
		  var outarg:atom );

var	ptr:pp_ptr;  

begin  {pptype}
    if (inarg<=dtype_l_bound) or
	(inarg>=dtype_h_bound)
    then outarg:=illegal
    else begin    
	     ptr:=mtch_int(ord(inarg), dty);
	     if ptr<>NIL
	     then outarg:=ptr^.key;
	 end;
end;  {pptype}

function cvqtype( var inarg:atom;
		  var outarg:qtype ):boolean;

var	ptr:pp_ptr;  

begin  {cvqtype}
    outarg:=0;  {default return}
    ptr:=mtch_atom(inarg, qty);
    if ptr<>NIL
    then outarg:=ptr^.pp_qty
    else begin
	     ptr:=mtch_atom(inarg, dty);
	     if ptr<>NIL
	     then outarg:=ord(ptr^.pp_dty);	 
	 end;
    cvqtype:=(outarg<>0);
end; {cvqtype}


procedure ppqtype(     inarg:qtype;
		   var outarg:atom );

var	ptr:pp_ptr;  

begin  {ppqtype}
    outarg:=illegal;  {default return}
    if (inarg <= ord(dtype_l_bound)) or
	(inarg>star) or
	( (inarg >= ord(dtype_h_bound)) and
	  (inarg<axfr) ) 
    then outarg:=illegal
    else begin	
	     if inarg>=axfr
	     then ptr:=mtch_int(inarg, qty)
	     else ptr:=mtch_int(inarg, dty);
	     if ptr<>NIL
	     then outarg:=ptr^.key;
	 end;
end; { ppqtype }
function v_class(raw_value:integer;
		   var out_value:dclass):boolean;
begin
if (raw_value>ord(dclass_l_bound)) and (raw_value<ord(dclass_h_bound))
then begin
	 out_value:=chrclass(raw_value);
	 v_class:=true
     end
else v_class:=false
end; { v_class }

function cvclass( var inarg:atom;
		  var outarg:dclass ):boolean;

var	ptr:pp_ptr;  

begin  {cvclass}
    outarg:=dclass_h_bound;  {default return}
    ptr:=mtch_atom(inarg, dcl);
    if ptr<>NIL
    then outarg:=ptr^.pp_dcl;	
    cvclass:=(outarg>dclass_l_bound) and (outarg<dclass_h_bound)
end;  {cvclass}


procedure ppclass(     inarg:dclass;
		   var outarg:atom );

var	ptr:pp_ptr;  

begin  {ppclass}
    if (inarg<=dclass_l_bound) or
	(inarg>=dclass_h_bound)
    then outarg:=illegal
    else begin	
	     ptr:=mtch_int(ord(inarg), dcl);
	     if ptr<>NIL
	     then outarg:=ptr^.key;
	 end;
end; {ppclass}

function cvqclass( var inarg:atom;
		   var outarg:qclass ):boolean;

var	ptr:pp_ptr;  

begin
    outarg:=0;  {default return}
    ptr:=mtch_atom(inarg, qcl);
    if ptr<>NIL
    then outarg:=ptr^.pp_qcl	
    else begin
	     ptr:=mtch_atom(inarg, dcl);
	     if ptr<>NIL
	     then outarg:=ord(ptr^.pp_dcl);
	 end;
    cvqclass:=(outarg<>0);
end; {cvqclass}


procedure ppqclass(     inarg:qclass;
		    var outarg:atom );

var	ptr:pp_ptr;  

begin
    if (inarg <= ord(dclass_l_bound)) or
	(inarg>star) or
	( (inarg >= ord(dclass_h_bound)) and
	  (inarg<star) )
    then outarg:=illegal
    else begin	
	     if inarg < ord(dclass_h_bound)
	     then ptr:=mtch_int(inarg, dcl)
	     else ptr:=mtch_int(inarg, qcl);
	     if ptr<>NIL
	     then outarg:=ptr^.key;
	 end;
end;  {ppqclass}
procedure pprcode(     inarg:integer;
		   var outarg:atom );

var	ptr:pp_ptr;  

begin  {pprcode}
    outarg:='bad rcode      ';  {default return}
    ptr:=mtch_int(inarg, rc);
    if ptr<>NIL
    then outarg:=ptr^.key;	
end;  {pprcode}

procedure ppopcode(    opcode:integer;
		   var outarg:atom);
begin
case opcode of
std_query:  outarg:='standard query ';
inv_query:  outarg:='inverse query  ';
cm_query:   outarg:='multi complete ';
cu_query:   outarg:='unique complete';

others:	    outarg:='Illegal opcode ';
end {case}
end; { ppopcode }

procedure ppsect(    sect:sectcode;
		 var outarg:atom);

begin
case sect of
question:   outarg:='question       ';
answer:	    outarg:='answer         ';
authority:  outarg:='authority      ';
additional: outarg:='additional     ';
others:	    outarg:='Unknown section'
end { case }
end; { ppsect }
function cvptcl( var inarg:atom;
		 var outarg:integer ):boolean;

var	ptr:pp_ptr;  

begin  {cvptcl}
    outarg:=-1;  {default return}
    ptr:=mtch_atom(inarg, ptcl);
    if ptr<>NIL
    then outarg:=ptr^.num;
    cvptcl:=(outarg<>-1);
end; {cvptcl}


procedure ppptcl(     inarg:integer;
	          var outarg:atom );

var	ptr:pp_ptr;  

begin
    if (inarg<0) or (inarg>255)
    then outarg:=illegal
    else begin	
	     ptr:=mtch_int(inarg, ptcl);
	     if ptr<>NIL
	     then outarg:=ptr^.key
	     else outarg:='UNDEFINED      ';	 
	 end;
end;  {ppptcl}

function cvport(     inarg:atom;
		     protocol:integer;  {for later use}
		 var outarg:integer ):boolean;

{ Find the corresponding decimal for the given port keyword. 
  If duplicates exist, return the lowest matching value. }

var	ptr:pp_ptr;

begin
    outarg:=-1;  {default return}
    ptr:=mtch_atom(inarg, port);  {match the string}
    if ptr<>NIL
    then begin
	     outarg:=ptr^.num;
	     cvport:=true;
	 end
    else cvport:=false;
	 
end; {cvport}


procedure ppport(     inarg:integer;
		      protocol:integer;  {for later use}
	          var outarg:atom );

var	ptr:pp_ptr;

begin  {ppport}
    if (inarg<0) or (inarg>255)
    then outarg:=illegal
    else begin	
	     ptr:=mtch_int(inarg, port);
	     if ptr<>NIL
	     then outarg:=ptr^.key
	     else outarg:='UNDEFINED      ';	 
	 end;

end;  {ppport}
	

{ FILE INPUT UTILITY ROUTINES }

procedure skip_whsp( var infile:charfile );

{ Skip white space which is identified as a
  blank, tab, or newline. }

begin  {skip_whsp}
    while ( not eof(infile) and
	    ( (infile^ = ' ') or 
	      (infile^ = '	') or
	      eoln(infile) ) ) do
	get(infile);
end;  {skip_whsp}


function pp_read( var infile:charfile;
		  var decimal:integer;
		  var buf:atom;
		  var attr:pp_types ):boolean;

{ From the file specified, retrieve a decimal number/keyword 
  pair.  Return false if a complete pair is not obtained.
  Comments are initiated by ';' and terminated by eoln.
  Lines beginning with '*' designate a change in attribute. }

var	ok, done:boolean;
	howmany:integer;

begin  {pp_read}
    decimal:=-1;
    buf[1]:=' ';

    howmany:=0;
    ok:=true;
    done:=false;

    { Ignore lead comment lines while noting attribute
      change lines. }
    while not eof(infile) and
	 ( (infile^ = ';') or
	  (infile^ = '*') ) do
    begin      
	if infile^='*'
	then attr:=succ(attr);    
	readln(infile);
    end;
	  
    { Get decimal number }
    if not eof(infile)
    then begin
	     skip_whsp(infile);
	     if not eof(infile)
	     then begin
		      read( infile, buf:howmany:[' ', '	', ';'] );
		      if infile^ = ';'  {comment precludes set completion}
		      then ok:=false	
		      else {convert string to decimal}
			  ok:=cvint(buf, decimal);
		  end;
	 end;
    
    if ok and not eof(infile)
    then begin  {get keyword}
	     skip_whsp(infile);
	     if not eof(infile)
	     then begin
		      read( infile, buf:howmany:['	', ';'] );
		      readln(infile);
		  end
	     else ok:=false;
	 end;
    pp_read:=ok and (decimal>=0) and (buf[1]<>' ');
end;  {pp_read}


function to_dtype(     inarg:integer;
		   var outarg:dtype ):boolean;

{ Convert the given integer to a valid dtype type.
  Return false if a defined value is not found. }

begin  {to_dtype}
    outarg:=dtype_l_bound;
    while (ord(outarg)<>inarg) and
	  (outarg<dtype_h_bound) do
	      outarg:=succ(outarg);
    to_dtype:=(outarg>dtype_l_bound) and (outarg<dtype_h_bound);
end;  {to_dtype}


function to_dclass(     inarg:integer;
		    var	outarg:dclass ):boolean;

{ Convert the given integer to a valid dclass type.
  Return false if a defined value is not found. }

begin  {to_dclass}
    outarg:=dclass_l_bound;
    while (ord(outarg)<>inarg) and
	  (outarg<dclass_h_bound) do
	      outarg:=succ(outarg);
    to_dclass:=(outarg>dclass_l_bound) and (outarg<dclass_h_bound);
end;  {to_dclass}


procedure pp_insert( decimal:integer;
		     string:atom;
		     attr:pp_types );

{ intbl in indexed by the ordinal value of A-Z. 
  Exceptions are place at the bottom, index=26.
  Insert a pp_rec based on the first character
  of the string.  If collision at the hash bucket,
  place in alphabetic order.  Link this entry into
  the num_head chain.  Duplicates are not supressed.
  If a problem exists with one of the entry values,
  don't insert the pp_rec. }

var	index:integer;
	ok, done:boolean;
	mydtype:dtype;
	mydclass:dclass;
	ptr, scratch:pp_ptr;
	tblptr:pptbl_ptr;

begin  {pp_insert}
    
    ok:=true;
    index:=ord(string[1]) - ord('A');    {where does the new entry belong?}
    if (index<0) or (index>25)
    then index:=26;

    { Create a new entry }
    new(ptr);
    ptr^.key:=string;
    ptr^.key_next:=NIL;
    ptr^.num:=decimal;
    ptr^.num_next:=NIL;
    ptr^.attribute:=attr;
    case attr of
	dty:  begin
		  ok:=to_dtype(decimal, mydtype);
		  if ok
		  then ptr^.pp_dty:=mydtype;    
	      end;
	
	qty:  if (decimal>=0) and (decimal<=177777b)
	      then ptr^.pp_qty:=decimal
	      else ok:=false;	 

	dcl:  begin
		  ok:=to_dclass(decimal, mydclass);
		  if ok
		  then ptr^.pp_dcl:=mydclass;
	      end;

	qcl:  if (decimal>=0) and (decimal<=177777b)
	      then ptr^.pp_qcl:=decimal
	      else ok:=false;	 
    end;

    if not ok
    then dispose(ptr)
    else begin	
	     { Choose a table to put it in }
	     case attr of
		 port:  tblptr:=port_tbl;
		 ptcl:  tblptr:=ptcl_tbl;
		 others: tblptr:=general;
	     end;

	     { Put it in the table }
	     if tblptr^.table[index] = NIL
	     then  {table empty at this index}
		 tblptr^.table[index]:=ptr	
	     else begin   {alphabetical order}
		      scratch:=tblptr^.table[index];
		      if scratch^.key>string
		      then begin  {place new entry at front of table}
			       ptr^.key_next:=scratch;
			       tblptr^.table[index]:=ptr;	 
			   end
		      else begin 
			       done:=false;
			       while not done and 
				     (scratch^.key_next<>NIL) do
			       begin	  
				   if scratch^.key_next^.key>string
				   then begin
					    ptr^.key_next:=scratch^.key_next;
					    done:=true;
					end
				   else scratch:=scratch^.key_next;
			       end;
			       scratch^.key_next:=ptr;
			   end;
		  end;
	     
	     { Link into decimal representation chain }
	     if tblptr^.num_head=NIL
	     then  {first addition}
		 tblptr^.num_head:=ptr
	     else begin
		      scratch:=tblptr^.num_head;
		      if scratch^.num>decimal
		      then begin   {new one should be first in list}
			       ptr^.num_next:=scratch;
			       tblptr^.num_head:=ptr;
			   end
		      else begin  {find where it goes}
			       done:=false;
			       while not done and
				     (scratch^.num_next<>NIL) do
			       begin	    
				   if scratch^.num_next^.num>decimal
				   then begin 	  
					    ptr^.num_next:=scratch^.num_next;
					    done:=true;
					end
				   else scratch:=scratch^.num_next;
			       end;
			       scratch^.num_next:=ptr;
			   end;
		      end;
	 end;
end;  {pp_insert}


procedure pp_init;

{ Read all decimal/string pairs from pplegals.txt
  and store in the approproate tables. }

var	decimal:integer;
	string:atom;
	attr:pp_types;
	pfile:charfile;
	myfbp:file_blk_ptr;

begin  {pp_init}
    reset(pfile,ppfile1, '/U/O/E');  
    if erstat(pfile) <> 0
    then begin
	     clreof(pfile);
	     reset(pfile,ppfile2, '/U/O/E');  
	     if erstat(pfile) <> 0
	     then begin
		      myfbp:=ofile(fatl);
		      writeln(myfbp^.fident, 'Couldn''t open pplegals.txt');
		      jsys_err(abort, -1, myfbp);  {print error msg and quit}
		  end;
	 end;
	     
    { Allocate tables }
    new(port_tbl);
    new(ptcl_tbl);
    new(general);
    attr:=dty;  {use knowlwdge of file layout to initialize}

    while not eof(pfile) do
    begin	
	if ( pp_read(pfile, decimal, string, attr) )
	then pp_insert(decimal, string, attr);
    end;
end.  {pp_init}