unit udiv;

interface
uses umain;
  procedure listing(nocode:integer; modu : integer; action : integer);
  procedure list_ident(no:integer);
  procedure petcomp(coi : integer);
  procedure ttrie;

implementation
uses usp,userv,uunif;

		(********************************)
		(*	listing			*)
		(*	list_ident		*)
		(*	trie 			*)
		(*  mdiv.pas	 - prolog	*)
		(********************************)

procedure listing(nocode:integer; modu : integer; action : integer);

var	j,k,no,hsh	: integer;
	md		: integer;
	vasy		: boolean;
	oldmod		: integer;
	trouve		: boolean;
	no_code		: integer;
	ncode		: integer;
	aff		: boolean;
	listing_liste	: boolean;


procedure crossref;
var	kk,j,khsh	: integer;
	vasy		: boolean;
	nb		: integer;
	trouve		: boolean;

procedure ref(no : integer);
var	i	: integer;
	reg	: integer;

procedure verif(var reg : integer);
var	z,t	: integer;
begin
while (pcond^[cindex] <> 0) and (no<>0) do
	begin
	if pcond^[cindex] = p_nombre
	then	cindex := cindex + 3
	else	begin
		if pcond^[cindex] = k
		then	begin
			if not trouve
			then	begin
				lire_symbole(k);
				putk(symbole_lu);
				putk(' :  ');
				putint(table_symbole^[k].nbr_arg);
				putkln(' parametre(s)');
				end;
			trouve := true;
			no := 0;
			reg := 0;
			if nb = 0
			then	putk('    ');
			lire_symbole(kk);
			t:=length(symbole_lu);
			if (t>13) and (nb<>0) and (nb<>4)
			then	putkln('');
			putk(symbole_lu);
			if t>13
			then	begin
				nb:=0;
				putkln('');
				end
			else	begin
				for z:=t to 14 do
					putk(' ');
				nb:=nb+1;
				if nb=4
				then	begin
					putkln('');
					nb:=0;
					end;
				end;
			end;
		end;
	if cindex >= m_cond
	then	begin
		pcond := addr(table_fait^[ralo]^.fait[1]);
		ralo := table_fait^[ralo]^.ral_cond;
		cindex := cindex - m_cond + 1;
		end
	else	cindex := cindex + 1;
	end;
end;

begin			(* code de ref *)
while no <> 0 do
	begin
	reg := table_fait^[no]^.regle;
	cindex := 2;
	pcond := addr(table_fait^[reg]^.fait[1]);
	ralo := table_fait^[reg]^.ral_cond;
	verif(no);
	if reg > 0
	then	begin
		cindex := 1;
		pcond := addr(table_fait^[reg]^.fait[1]);
		ralo := table_fait^[reg]^.ral_cond;
		verif(reg);
		end;
	if no <> 0
	then	no := table_fait^[no]^.suivant;
	end;
end;

begin	(* code de crossref *)
trouve := false;
nb := 0;
for j:=0 to max_par do
	begin
	for khsh := 0 to max_hsh do
		begin
		kk:=premier_sym[j,khsh];
		while kk <> 0 do
			begin
			md := table_symbole^[kk].modul;
			if (md=modu) or (md=-modu) or (modu=0)
			then	begin
				no := table_symbole^[kk].premier;
				if no <> 0
				then	ref(no);
				end;
			kk:=table_symbole^[kk].suivant;
			end;
		end;
	end;
if nb <> 0
then	putkln('');
end;

procedure lister;
var	iz	: integer;

procedure affich(no:integer);
var	condi	: integer;
	xnoeud	: integer;
	xniveau	: integer;
	debut	: boolean;
	decal	: integer;
	i,vn,reg	: integer;
begin
decal := 0;
xnoeud := nnoeud;
xniveau := nniveau;
nniveau := 0;
cindex := 1;
pcond := addr(table_fait^[no]^.fait[1]);
ralo := table_fait^[no]^.ral_cond;
decomp(condi,nniveau);
ecrire(condi);
reg := table_fait^[no]^.regle;
if reg = 0
then	begin
	lsave := 0;
	putkln('.');
	end
else	begin
	putk(' ->');
	cindex := 1;
	pcond := addr(table_fait^[reg]^.fait[1]);
	ralo := table_fait^[reg]^.ral_cond;
	debut := true;
	while pcond^[cindex] <> 0 do
		begin
		decomp(condi,nniveau);
		if (noeud^[condi].code = p_else)
		or (noeud^[condi].code = p_then)
		then	if decal > 0
			then	decal := decal - 1;
		if pcond^[cindex] <> 0
		then	begin
			if debut
			then	begin
				putkln('');
				if ttyout=0
				then	write(output,'    ')
				else	putk(chr(9));
				end;
			for i := 1 to decal do
				putk('  ');
			ecrire(condi);
			lsave:=0;
			putkln(' ,');
			if ttyout = 0
			then	write(output,'    ')
			else	putk(chr(9));
			end
		else	begin
			if debut
			then	tcar(' ');
			for i := 1 to decal do
				putk('  ');
			ecrire(condi);
			end;
		debut := false;
		vn := noeud^[condi].code;
		if (vn=p_block) or (vn=p_repet0) or (vn=p_repet1)
		or (vn=p_for) or (vn=p_if) or (vn=p_else) or (vn=p_then)
		then	decal := decal + 1;
		if (vn=p_coupe1) or (vn=p_until1) or (vn=p_ffor) or (vn=p_end)
		then	if decal > 0
			then	decal := decal - 1;
		end;
	lsave := 0;
	putkln(' .');
	end;
nnoeud := xnoeud;
nniveau := xniveau;
end;

begin		(* code de lister *)
if no_code = 0
then	begin
	write(output,'     ');
	write(output,'Listing du sous-programme ');
	lire_symbole(k);
	write(output,symbole_lu);
	writeln(output);
	end;
if oldmod <> abs(md)
then	begin
	oldmod := abs(md);
	if md <> -2
	then	begin
		if save_txt <> 0
		then	putkln('main.');
		putk('module(');
		lire_symbole(oldmod);
		putk(symbole_lu);
		putkln(').');
		end
	else	putkln('main.');
	end;
if md = -modu
then	begin
	putk('define(');
	lire_symbole(k);
	putk(symbole_lu);
	putkln(').');
	end;
if table_symbole^[k].phsh_coded <> 0
then	begin
	putk('hsh_coded( ');
	lire_symbole(k);
	putk(symbole_lu);
	putk('(');
	for iz := 1 to table_symbole^[k].nbr_arg-1 do
		putk('_,');
	putkln('_) ) .');
	end;
while no <> 0 do
	begin
	affich(no);
	no := table_fait^[no]^.suivant;
	end;
if (save_txt=0) and (no_code = 0)
then writeln(output,'-------------------------------');
end;

procedure traitsp;
begin
no:=table_symbole^[k].premier;
if (no <> 0) or (action=2)
then	begin
	md := table_symbole^[k].modul;
	if (md=modu) or (md=-modu) or (modu=0)
	then	begin
		trouve := true;
		case action of
		   1:	begin	(* clear *)
			with table_symbole^[k] do
				begin
				premier := 0;
				dernier := 0;
				if phsh_coded <> 0
				then	begin
					dispose(table_coded[phsh_coded]);
					table_coded[phsh_coded] := nil;
					while (nhsh_coded > 0)
					and (table_coded[nhsh_coded]=nil) do
						begin
						nhsh_coded := nhsh_coded - 1;
						end;
					end;
				phsh_coded := 0;
				end;
			while no <> 0 do
				begin
				liber_fait(no);
				no := table_fait^[no]^.suivant;
				end;
			end;
		   0:	lister;	(* list *)
		   2:	crossref;	(* crossref *)
		   end;
		end;
	end;
end;

begin	(* code de listing *)
lsave := 0;
if nocode <> 0
then	begin
	if noeud^[nocode].code = p_point
	then	begin
		listing_liste := true;
		lire_element(nocode,ncode);
		ncode := getval(ncode);
		end
	else	begin
		listing_liste := false;
		ncode := nocode;
		end;
	if ncode = 0
	then	aff := false
	else	aff := true;
	end
else	begin
	listing_liste := false;
	aff := true;
	ncode := 0;
	end;
trouve := false;
while aff do
	begin
	if ncode <> 0
	then	no_code := noeud^[ncode].code
	else	no_code := 0;
	oldmod := -4;
	j:=-1;
	for j:=0 to max_par do
		begin
		for hsh := 0 to max_hsh do
			begin
			k:=premier_sym[j,hsh];
			(* if arret='n'
			then	onsarrete; *)
			if arret = 'o'
			then	k := 0;
			while k <> 0 do
				begin
				vasy:=false;
				if no_code = 0
				then	vasy:=true
				else	begin
					if table_symbole^[k].symbol^=
						table_symbole^[no_code].symbol^

					then	vasy:=true;
					end;
				if vasy
				then	traitsp;
				k:=table_symbole^[k].suivant;
				end;
			end;
		end;
	if listing_liste
	then	begin
		lire_element(nocode,ncode);
		ncode := getval(ncode);
		if ncode = 0
		then	aff := false;
		end
	else	aff := false;
	end;
if ((action<>1) or (narbre=1)) and (not trouve)
then	writeln(output,'Sous programme inexistant');
end;


procedure list_ident(no:integer);
var	i,j,k,nb,modu,stt	:integer;
	t,hsh			:integer;
	titre			:boolean;
	vasy			:boolean;
	ideb			:integer;

procedure affident;
var	z	: integer;
begin
if titre
then	begin
	titre:=false;
	if nb<>0	then	putkln('');
	putkln('');
	nb:=0;
	putk('     ');
	case i of
		-2	:putk('variables');
		-1	:putk('nombre');
		0   	:putk('0 parametre');
		1	:putk('1 parametre');
		2	:putk('2 parametres');
		3	:putk('3 parametres');
		4	:putk('4 parametres');
		5	:putk('5 parametres');
		end;
	putkln('');
	end;
lire_symbole(k);
t:=length(symbole_lu);
putk(symbole_lu);
if t>13
then	begin
	nb:=0;
	writeln(output);
	end
else	begin
	for z:=t to 14 do
		putk(' ');
	nb:=nb+1;
	if nb=5
	then	begin
		putkln('');
		nb:=0;
		end;
	end;
end;

begin		(* code de list_ident *)
write(output,'    ');
case no of
	0	:write(output,'Liste des identificateurs predefinis');
	1	:write(output,'Liste des identificateurs du module');
	2	:write(output,'Liste de tous les identificateurs');
	3	:write(output,'Liste des identificateurs du main');
	4	:write(output,'Liste des identificateurs non definis');
	end;
if no = 4
then	ideb := 1
else	ideb := 0;
writeln(output);
nb:=0;
for i:= ideb to max_par do
	begin
	titre:=true;
	for hsh := 0 to max_hsh do
		begin
		k:=premier_sym[i,hsh];
		while k <> 0 do
			begin
			vasy := false;
			if k > npredef
			then	begin
				modu := table_symbole^[k].modul;
				case no of
					0	:vasy:=false;
					1	:begin
						if (modu=nmodule)
						or (modu=-nmodule)
						then	vasy:=true;
						end;
					2	:begin
						if modu <> -1
						then	vasy:=true;
						end;
					3	:begin
						if (modu=-2) or (modu<-3)
						then	vasy:=true;
						end;
					4	:begin
					if (table_symbole^[k].nbr_arg>0)
					and (table_symbole^[k].premier=0)
						then	vasy := true;
					lire_symbole(k);
					if (symbole_lu='write')
					or (symbole_lu='writeln')
					or (symbole_lu='read')
					or (symbole_lu='readln')
					or (symbole_lu='put')
					or (symbole_lu='putln')
					or (symbole_lu='writewords')
					or (symbole_lu='writewordsln')
					then	vasy := false;
						end;
					end;
				end
			else	if no=0
				then	vasy := true;
			if vasy
			then	affident;
			k := table_symbole^[k].suivant;
			end;
		end;
	end;
putkln('');
end;

(*
procedure save;
var	fobjet	:file of fai;
	fsym	:file of symble;
	sy	:symble;
	rul	:fai;
	i	:integer;
	orig	:ttstring;
	fic	:ttstring;
begin
lire_symbole(noeud^[fils1].code);
orig:=symbole_lu;

sy.suivant:=nsym;
sy.nbr_arg:=nfait;

fic:=orig + '.ssy';
assign(fsym,fic);
rewrite(fsym);
write(fsym,sy);

seek(fsym,1);
write(fsym,sy);
for i:=npredef to nsym do
	begin
	sy:=table_symbole^[i];
	sy.vale:=0;
	seek(fsym,i+1);
	write(fsym,sy);
	end;
close(fsym);

fic:=orig + '.sob';
assign(fobjet,fic);
rewrite(fobjet);
write(fobjet,rul);

for i:=1 to nfait+1 do
	begin
	seek(fobjet,i);
	write(fobjet,table_fait^[i]^);
	end;
close(fobjet);
end;


procedure load;
var	fobjet	:file of fai;
	fsym	:file of symble;
	sy	:symble;
	rul	:fai;
	i	:integer;
	orig	:ttstring;
	fic	:ttstring;
	reset_ok	:boolean;
begin
reset_ok:=false;
lire_symbole(noeud^[fils1].code);
orig:=symbole_lu;

fic:=orig + '.ssy';
assign(fsym,fic);
reset(fsym);
if ioresult <> 0
then	writeln(output,'Le fichier ',fic,' n''existe pas')
else	begin
	fic:=orig + '.sob';
	assign(fobjet,fic);
	reset(fobjet);
	if ioresult <> 0
	then	begin
		writeln(output,'Le fichier ',fic,' n''existe pas');
		close(fsym);
		end
	else	reset_ok:=true;
	end;
if reset_ok
then	begin
	seek(fsym,1);
	read(fsym,sy);

	nsym:=sy.suivant;
	nfait:=sy.nbr_arg;

	for i:=npredef to nsym do
		begin
		seek(fsym,i+1);
		read(fsym,sy);
		table_symbole^[i]:=sy;
		end;
	close(fsym);

	for i:=1 to nfait+1 do
		begin
		seek(fobjet,i);
		read(fobjet,rul);
		table_fait^[i]^ := rul;
		end;
	close(fobjet);
	end;
end;
*)


procedure petcomp(coi : integer);
var	i	: integer;
	st	: tstring;
begin
if fils1_code = p_nombre
then	begin
	if coi=0
	then	begin
		if evaluation(fils1) >= evaluation(fils2)
		then	backtrack := true;
		end
	else	begin
		if evaluation(fils1) > evaluation(fils2)
		then	backtrack := true;
		end;
	end
else	begin
	i := noeud^[fils2].code;
	lire_symbole(fils1_code);
	st := symbole_lu;
	lire_symbole(i);
	if coi=0
	then	begin
		if st >= symbole_lu
		then	backtrack := true;
		end
	else	begin
		if st > symbole_lu
		then	backtrack := true;
		end;
	end;
end;

procedure ttrie;
var	sor,pre,el	:integer;
	tabletri: array[1..300] of integer;
	genre	: integer;
	genr	: integer;
	nb,i	: integer;
	al,pte	: integer;


procedure trions;
var	i,j,k	:integer;
	s1,s2	:ttstring;
	v,v1,v2,v3	:integer;
	exch	:boolean;
begin
for i:=1 to nb-1 do
	begin
	if genre = 2
	then	begin
		lire_symbole(tabletri[i]);
		s1:=symbole_lu;
		v1:=length(s1);
		end;
	if genre = 4
	then	begin
		pte := tabletri[i];
		lire_element(pte , al);
		al := getval(al);
		lire_symbole(noeud^[al].code);
		s1:=symbole_lu;
		v1 := length(s1);
		end;
	for j:=i+1 to nb do
		begin
		case genre of
			1	: begin
				if noeud^[tabletri[i]].value >
					 noeud^[tabletri[j]].value
				then	begin
					k:=tabletri[i];
					tabletri[i]:=tabletri[j];
					tabletri[j]:=k;
					end;
				end;
			3	:begin
				pte := tabletri[i];
				lire_element(pte , al);
				al := getval(al);
				pte := tabletri[i];
				lire_element(pte , el);
				el := getval(el);
				if noeud^[al].value > noeud^[el].value
				then	begin
					k:=tabletri[i];
					tabletri[i]:=tabletri[j];
					tabletri[j]:=k;
					end;
				end;
			2,4	: begin
				if genre = 2
				then	begin
					lire_symbole(tabletri[j]);
					s2:=symbole_lu;
					end
				else	begin
					pte := tabletri[j];
					lire_element(pte , al);
					al := getval(al);
					lire_symbole(noeud^[al].code);
					s2:=symbole_lu;
					end;
				v2:=length(s2);
				if v1>v2
				then	v3:=v2
				else	v3:=v1;
				v:=0;
				exch:=false;
				while v < v3 do
					begin
					v:=v+1;
					if s1[v]=s2[v]
					then	begin
						if (v1>v2) and (v=v3)
						then	exch:=true;
						end
					else	begin
						if s1[v] > s2[v]
						then	exch:=true
						else	exch:=false;
						v:=v3;
						end;
					end;
				if exch
				then	begin
					s1:=s2;
					v1:=v2;
					k:=tabletri[i];
					tabletri[i]:=tabletri[j];
					tabletri[j]:=k;
					end;
				end;
			end;
		end;
	end;
end;

begin		(* trie (liste,liste) *)
if (noeud^[fils1].code=p_point)
or (noeud^[fils2].code=p_nil)
then	begin
	ok := true;
	pre:=fils1;
	genre:=0;
	nb:=0;
	while pre <> 0 do
		begin
		lire_element(pre,el);
		el := getval(el);
		if el <> 0
		then	begin
			nb:=nb+1;
			if noeud^[el].code=p_nombre
			then	begin
				genr:=1;
				tabletri[nb]:=el;
				end
			else	begin
				if noeud^[el].code=p_point
				then	begin
					pte := el;
					lire_element(pte,al);
					al := getval(al);
					if noeud^[al].code = p_nombre
					then	genr := 3
					else	genr := 4;
					tabletri[nb] := el;
					end
				else	begin
					genr:=2;
					tabletri[nb]:=noeud^[el].code;
					end;
				end;
			if genre = 0
			then	genre := genr
			else	begin
				if genr <> genre
				then	begin
					eros;
					writeln(output,'la liste est un doux melange');
					end;
				end;
			end;
		if not ok
		then	pre:=0;
		end;
	if not ok
	then	backtrack := true
	else	begin
		if nb>=2
		then	begin
			trions;
			end;
		crevide(sor);
		for i:=1 to nb do
			begin
			case genre of
				1	:begin
					prend_noeud(el);
					noeud^[el].code:=p_nombre;
					noeud^[el].value:=noeud^[tabletri[i]].value;
					end;
				2	: begin
					prend_noeud(el);
					noeud^[el].code:=tabletri[i];
					end;
				3,4	: begin
					el := tabletri[i];
					end;
				else
				end;
			ajoute_element(el,sor);
			end;
		rend_liste(sor,2);
		end;
	end
else	backtrack:=true;
end;

end.
