! File:   LSTPKG.BLI
!
Module LSTPKG =
Begin

Require 'Bliss';

External Routine
	XSORTENTER;

! GENERAL LIST-MANIPULATION ROUTINES
!----------------------------------------

!	LISTS ARE DOUBLY-LINKED AND HOMOGENEOUS AND ONE-LEVEL. THE
!	FORMAT OF A LIST HEADER IS:
!		0:  LLINK,,RLINK
!		1:  REMOVE,,ENTER
!	THE REMOVE FIELD IS AN INDEX INTO A TABLE OF VARIOUS TYPES OF ITEMS
!	THAT MIGHT BE SUSPENDED FROM A PARTICULAR LIST.  AT THE TIME
!	OF THIS WRITING THERE ARE FOUR:
!		0: BASIC LIST -- ALL ITEMS OF SIZE 2
!		1: BOGUS-POINTER LIST -- EACH ITEM POINTS TO A BOGUS-TYPE
!		     NODE AND IS ITSELF OF SIZE 2
!		2: ITERSECT LIST -- SIZE OF ITEM IS IN "ITEMSIZEF" FIELD
!		3: RHO LIST -- ALL ITEMS OF SIZE 3
!	THE ENTER  FIELD IS THE ADDRESS OF THE ROUTINE WHICH COMPUTES THE
!	POSITION IN A LIST WHERE AN ITEM IS TO BE ENTERED.
!	SORTED LISTS ARE ARRANGED IN DESCENDING (FROM RLINK) ORDER
!	ACCORDING TO THE VALUE OF WORD #1 IN ITEM.

!REMOVES ITEM A FROM LIST TO WHICH IT IS APPENDED

Global Routine DELINK(A : Ref ITEM) =
Begin
    Local
	P		: Ref ITEM;

    p = .A[itm_llink];
    p[itm_rlink] = .A[itm_rlink];
    p = .A[itm_rlink];
    p[itm_llink] = .A[itm_llink];
    A[itm_rlink] = .A;
    A[itm_llink] = .A;
    Return .A
End;

!INSERTS ITEM A INTO A LIST IMMEDIATELY AFTER THE ITEM TOO

Global Routine LINK(A : Ref ITEM,TOO : Ref ITEM) =
Begin
    Local
	P		: Ref ITEM;

    p = .A[itm_llink];
    p[itm_rlink] = .TOO[itm_rlink];
    p = .TOO[itm_rlink];
    p[itm_llink] = .A[itm_llink];
    A[itm_llink] = .TOO;
    TOO[itm_rlink] = .A;
    Return .A
End;

! REMOVES ITEM A FROM ITS PRESENT LIST AND INSERTS IT AFTER TOO
!
! note: items are normally initialized such that they are a list
!	in themselves.  thus this routine will work if 'A' is on
!	no particular list

Routine RELINK(A : Ref ITEM,TOO : Ref ITEM) =
Begin
    Return LINK(DELINK(.A),.TOO)
End;

! PREDICATE INDICATING EMPTY LIST

Global Routine EMPTY(L : Ref LSTHDR) =
Begin
    Return .L[itm_rlink] Eql .L
End;

!
! RETURNS ADDRESS OF ITEM TO THE RIGHT OF WHICH ITEM A SHOULD
! BE ENTERED ON SORTED LIST L.
!
Routine SORTENTER(L : Ref LSTHDR,A : Ref ITEM) =
Begin
    Local
	I		: Ref ITEM,
	N		: Integer;

    I = .L[itm_rlink];
    N = .A[itm_data(1)];
    While .I Neqa .L Do
	Begin
	If .N Geq .I[itm_data(1)] Then
	    Exitloop;
	I = .I[itm_rlink]
    End;
    Return .I[itm_llink]
End;

!
! LIKE SORTENTER EXCEPT LIFO DISCIPLINE
!

Routine LIFOENTER(L : Ref LSTHDR,A : Ref ITEM) =
Begin
    Return .L
End;

! ENTER ITEM A ON LIST L ACCORDING TO THE INSERTION DISCIPLINE
! EVOKED BY L'S ENTER ROUTINE

Global Routine ENLST(L : Ref LSTHDR,A : Ref ITEM) =
Begin
    Own
	ENTER		: Vector[3,Long] Preset(
				[0] = LIFOENTER,
				[1] = SORTENTER,
				[2] = XSORTENTER);

    Return RELINK(.A,Bliss(.ENTER[.L[hdr_enter]],.L,.A))
End;

! MAKES UP A LIST ITEM OF SIZE N+1 WORDS (N DATA ITEMS) INITIALIZED
! TO POINT TO ITSELF

Global Routine MAKITEM =
Begin
    Local
	N		: Integer,
	P		: Ref ITEM;
    Builtin
	ACTUALCOUNT,
	ACTUALPARAMETER;

    N = ACTUALCOUNT();
    P = GETSPACE(SZ_ITEM(.N));
    Incr i From 1 To .N Do
	P[itm_data(.i)] = ACTUALPARAMETER(.i);
    P[itm_rlink] = .P;
    P[itm_llink] = .P;
    Return .P
End;

! MAKES UP A LIST HEADER WITH REMOVE AND ENTER ROUTINES R AND E
! RESPECTIVELY

Global Routine MAKHDR(R : Integer,E : Integer) =
Begin
    Return MAKITEM(.R^32+.E)
End;

!
! MAKES UP AN INTERSECT-TYPE LIST OF ITEMS SIZED "SIZE+2"
! WHOSE FIRST DATA ENTRIES COME FROM OLD AND SUSPENDS THIS NEW
! LIST FROM NEW.
! INTDATITEM:
!	0: LLINK,,RLINK
!	1: FORMAL-PARENT,,#-OF-ENTRIES
!	2: ENTRY #1
!	    .........
!	SIZE+1: ENTRY #SIZE
!
! CONCLUDES BY RELEASING THE OLD LIST.
!
Global Routine MAKINTLST(SIZE,OLD : Ref LSTHDR,NEW : Ref LSTHDR) : Novalue =
Begin
    Local
	L		: Ref LSTHDR,
	CHUNK		: Ref ITEM;

    L = .OLD;
    While (L = .L[itm_rlink]) Neqa .OLD Do
	Begin
	CHUNK = GETSPACE(SZ_INT_ITEM(.SIZE));
	CHUNK[itm_rlink]       = .CHUNK;
	CHUNK[itm_llink]       = .CHUNK;
	CHUNK[itm_fparent]     = .L[itm_fparent];
	CHUNK[itm_size]        = .SIZE;
	CHUNK[itm_int_data(1)] = .L[itm_data(1)];
	ENLST(.NEW,.CHUNK)
	End;
    FreeList(.OLD)
End;

!
! RELEASES ITEM A WHOSE SIZE IS ASIZE
!

Global Routine RELITEM(A : Ref ITEM,ASIZE : Integer) : Novalue =
Begin
    RELEASESPACE(DELINK(.A),.ASIZE)
End;

!
! RELEASES ALL ITEMS (AND HEADER) OF LIST HEADED BY HDR
! S IS THE TABULAR COMPUTATION DESCRIBED AT THE HEAD OF THE
! FILE FOR DETERMINING THE SIZE OF A LIST'S ITEMS.
!
Global Routine FreeList(HDR : Ref LSTHDR) : Novalue =
Begin
    Local
	N		: Integer,
	I		: Ref ITEM,
	J		: Ref ITEM;

    If .HDR Eql 0 Then
	Return;
    I = .HDR[itm_rlink];
    While .I Neqa .HDR Do
	Begin
	J = .I[itm_rlink];
	Case .HDR[hdr_remove] From 0 To 4 Of Set
	  [0]:
		N = SZ_ITEM(1);
	  [1]: 
		Begin
		RELEASESPACE(.I[itm_rdata(1)],SZ_NODE(0));
		N = SZ_ITEM(1)
		End;
	  [2]:
		N = SZ_INT_ITEM(.I[itm_size]);
	  [3]:
		N = SZ_RHO_ITEM;
	   [4]:
		N = SZ_FLSTK_ITEM
	Tes;
	RELEASESPACE(.I,.N);
	I = .J
	End;
    RELEASESPACE(.HDR,SZ_LSTHDR)
End;

! INSERT DATA WORD OF ITEM NEW INTO N-TH ENTRY OF ITERSECT-ITEM
! TOO

Macro
	ADDTOINTITEM(N,TOO,NEW)=
		Begin
		TOO[itm_int_data(.N)] = .NEW[itm_data(1)]
		End %;

!
! COMPUTES THE FORMAL INTERSET OF RESHDR AND NXTHDR AND LEAVES
! RESULT IN RESHDR.  (I.E. RESHDR = .RESHDR /\ .NXTHDR). N IS A
! COUNT OF THE NUMBER OF ITERATIONS.  ALL FORMAL INTERSECTS OF
! THE FORM: R  =  N1 /\ N2 /\ N3 /\ ... /\ NK ARE COMPUTED AS:
!	MAKINTLST(K,R,N1);
!	INCR I FROM 2 TO K DO
!	  SORTFINT(I,R,N[I]);
!
Global Routine SORTFINT(N,RESHDR : Ref LSTHDR,NXTHDR : Ref LSTHDR) : Novalue =
Begin
    Local
	PRES		: Ref ITEM,
	PNXT		: Ref ITEM,
	VALRES		: Ref GT,
	VALNXT		: Ref GT,
	t		: Ref ITEM;

    Macro
	UDRES=(
		PRES = .PRES[itm_rlink];
		VALRES = .PRES[itm_fparent]) %;

    Macro
	UDNXT=(
		PNXT = .PNXT[itm_rlink];
		If .PNXT Eqla .NXTHDR Then
		    VALNXT = 0
		Else
		    VALNXT = .PNXT[itm_fparent]) %;

    PRES = .RESHDR;
    PNXT = .NXTHDR;
    UDRES;
    UDNXT;
    While .PRES Neq .RESHDR Do
	Begin
	If .VALRES Eql .VALNXT Then
	    Begin
	    ADDTOINTITEM(N,PRES,PNXT);
	    UDNXT;
	    UDRES
	    End
	Else If .VALRES Gtr .VALNXT Then
	    Begin
	    Do
		Begin
		t = .PRES;
		UDRES;
		RELITEM(.t,SZ_INT_ITEM(.t[itm_size]));
		If .PRES Eqla .RESHDR Then
		    Exitloop
		End
	    Until .VALRES Leq .VALNXT;
	    End
	Else
	    Begin
	    Do
		UDNXT
	    Until .VALNXT Leq .VALRES
	    End
	End;
    FreeList(.NXTHDR);
    Return .RESHDR
End;

! CALLS ROUT(X,.CONST) WHERE X IS THE FIRST REAL ELEMENT OF EACH LIST ELEMENT

Global Routine PULSELIST(ROUT,LIST : Ref LSTHDR,TYPE,CONST) : Novalue =
Begin
    Local
	I		: Ref ITEM,
	X		: Boolean;

    LIST = .LIST;
    X = .TYPE Neq T_CHI And .TYPE Neq T_RHO;
    I = .LIST[itm_rlink];
    While .I Neqa .LIST Do
	Begin
	Bliss(.ROUT,.I[itm_int_rdata(.X)],.CONST);
	I = .I[itm_rlink]
	End
End;

! SPECIAL KIND OF PULSELIST, CURRENTLY USED ONLY IN DELAY ON RHO LISTS

Global Routine RHOPULSE(ROUT,LIST : Ref LSTHDR,CONT) : Novalue =
Begin
    Local
	I		: Ref ITEM;

    I = .LIST[itm_rlink];
    While .I Neqa .LIST Do
	Begin
	Bliss(.ROUT,.I[itm_int_rdata(0)],.CONT);
	Bliss(.ROUT,.I[itm_int_rdata(1)],.CONT);
	I = .I[itm_rlink]
	End
End;

! TURN OFF MUSTGENCODE BITS ON ALL ALPHA, OMEGA NODES.
!
! this routine is called by the delay routines for IF and CASE.
! it turns off the MUSTGENCODE bit so that only the pulse
! routines in TNBIND and CODE will process them.

Global Routine OLDFIXLIST(LIST : Ref LSTHDR) : Novalue =
Begin
    Local
	I		: Ref ITEM,
	NODE		: Ref GT;

    I = .LIST;
    While (I = .I[itm_rlink]) Neqa .LIST Do
	Begin
	Incr J From 1 To .I[itm_size] Do
	    Begin
	    NODE = .I[itm_int_rdata(.J)];
	    NODE[gt_v_mustgencode] = FALSE
	    End
	End
End;

! SETS REGF'S OF ALL CSPARENTS OF A NODE
!
! called by BINDLST in TNBIND
!
! list is either an Alpha or Omega list.
! TNBIND has pulsed the list, assigning tempnames 
! to the first node in each Alpha/Omega list entry.
! this routine copies that assigned tempname to all
! the other occurences in each entry.
 
Global Routine FIXLIST(LIST : Ref LSTHDR) : Novalue =
Begin
    Local
	I		: Ref ITEM,
	REGVAL		: Integer,
	NODE		: Ref GT,
	N		: Integer;

    I = .LIST[itm_rlink];
    N = .I[itm_size];
    While .I Neqa .LIST Do
	Begin
	NODE = .I[itm_int_rdata(1)];
	REGVAL = .NODE[gt_reg];
	Incr J From 2 To .N Do
	    Begin
	    NODE = .I[itm_int_rdata(.J)];
	    NODE = .NODE[gt_csparent];
	    NODE[gt_reg] = .REGVAL
	    End;
	I = .I[itm_rlink]
	End
End;

! same as above but for Rho lists
!
! called by LPBINDLST

Global Routine FIXRHOLIST(LIST : Ref LSTHDR) : Novalue =
Begin
    Local
	I		: Ref ITEM,
	REGVAL		: Integer,
	NODE		: Ref GT;

    I = .LIST;
    While (I = .I[itm_rlink]) Neqa .LIST Do
	Begin
	NODE = .I[itm_int_rdata(0)];
	REGVAL = .NODE[gt_reg];
	NODE = .I[itm_int_rdata(1)];
	NODE = .NODE[gt_csparent];
	NODE[gt_reg] = .REGVAL
	End
End;

End
Eludom