COMMENT Auxilliary record service routines.  
	Modified for new-style record descriptors.
	;

ENTRY;

BEGIN "RECAUX"

REQUIRE "ABBREV.SAI" SOURCE!FILE;
REQUIRE "MACROS.SAI" SOURCE!FILE;
REQUIRE "STCODE.DEF" SOURCE!FILE;
REQUIRE "SYS:RECORD.DEF" SOURCE!FILE;


DEFINE RPTR="RECORD!POINTER";

! rectype, $rectype, cvrts, bldnrc, chkrec, cpyrec, etc;

INTERNAL INTEGER SIMPLE PROCEDURE RECLEN(RPTR(ANY!CLASS) R);
	START!CODE
	LABEL	XIT;
	SKIPN	1,R;
	JRST	XIT;
	MOVE	1,(1);	! get the descriptor;
	MOVE 	1,3(1); ! the size field therefrom;
XIT:	END;

INTERNAL INTEGER SIMPLE PROCEDURE RECTYPE(RPTR (ANY!CLASS) R);
	START!CODE
	SKIPE	1,R;
	HRRZ	1,(1);
	END;

INTERNAL RPTR($CLASS) SIMPLE PROCEDURE $RECTYPE(RPTR(ANY!CLASS) R);
	START!CODE
	SKIPE	1,R;
	HRRZ	1,(1);
	END;

INTERNAL INTEGER PROCEDURE FLDTYPE(RPTR (ANY!CLASS) R;INTEGER IX);
	RETURN($CLASS:TYPARR[$RECTYPE(R)][IX] LSH -23);

INTERNAL STRING SIMPLE PROCEDURE CVRCS(RPTR($CLASS) RC);
	RETURN($CLASS:TXTARR[RC][0]);

INTERNAL STRING SIMPLE PROCEDURE CVRTS(INTEGER RT);
	START!CODE
	JRST	CVRCS;
	END;

INTERNAL INTEGER PROCEDURE FLDREF(RPTR(ANY!CLASS) R;STRING ID);
	BEGIN
	INTEGER I,N;
	RPTR($CLASS) RC;
	RC←$RECTYPE(R);
	N←$CLASS:RECSIZ[RC];
	FOR I←1 STEP 1 UNTIL N DO
		IF EQU($CLASS:TXTARR[RC][I],ID) THEN
			RETURN($CLASS:TYPARR[RC][I]+I+MEMORY[LOCATION(R)]);
	RETURN(0);
	END;

INTERNAL RPTR($CLASS) PROCEDURE CLSFND(STRING ID);
	BEGIN
	LABEL XIT;
	RPTR($CLASS) RC;
	MEMORY[LOCATION(RC)]←LOCATION($CLASS);
	WHILE TRUE DO
	 	BEGIN
		IF EQU($CLASS:TXTARR[RC][0],ID) THEN
			RETURN(RC)
		ELSE
                        START!CODE
                        MOVE 1,RC;
                        HLRZ 1,-1(1);
                        CAIN 1,$CLASS;
                        JRST    XIT;
                        MOVEM 1,RC;
                        END;
		END;
	XIT:RETURN(NULL!RECORD);
	END;

INTERNAL RECORD!POINTER(ANY!CLASS) PROCEDURE BLDNRC(INTEGER RT);
	START!CODE

	! This procedure is to be called by a procedure of the form:

	rptr(id) procedure new!id(fld1,...,fldn)
		return(bldnew(loc(id))
	;
	EXTERNAL INTEGER $RECFN;
	LABEL	L1,L2;
	SALACS;
	SKIPN	B,RT;
	JRST	4,;
	PUSH	P,[1]	; ! allocate;
	PUSH	P,RT;
	PUSHJ	P,$RECFN;
	HRRZ	C,(A);	! record class;
	MOVN	C,3(C); ! - number of subfields;
	JUMPE	C,L2;	! no subfields;
	HRRZ	B,A; ! will do pushes to copy;
	MOVE	D,(RF); ! look at caller;
	ADDI	D,-1(C); ! point at first argument;
	HRL	D,C; ! -cnt,,first arg;
L1:	PUSH	B,(D); ! copy value;
	SETZM	(D); ! sterilize it;
	AOBJN	D,L1; ! iterate;
L2:	END;

INTERNAL RPTR(ANY!CLASS) PROCEDURE CHKREC(RPTR(ANY!CLASS) R;INTEGER T);
	BEGIN
	IF T NEQ 0 AND RECTYPE(R) NEQ T THEN
		BEGIN
		USERERR(1,1,(CRLF&"RECORD ")&CVOS(MEMORY[LOCATION(R)])
				&" HAS TYPE "&CVRTS(RECTYPE(R))&
				" INSTEAD OF "&CVRTS(T));
		END;
	RETURN(R);
	END;

INTERNAL RPTR(ANY!CLASS) PROCEDURE CPYREC(RPTR(ANY!CLASS) R1,R2(NULL!RECORD));
	BEGIN
	INTEGER I;
	IF R2=NULL!RECORD THEN
		R2←$REC$(ALLOCATE!RECORD,$RECTYPE(R1))
	ELSE
		CHKREC(R2,RECTYPE(R1));
	FOR I←RECLEN(R1) STEP -1 UNTIL 1 DO
		MEMORY[MEMORY[LOCATION(R2)]+I]←MEMORY[MEMORY[LOCATION(R1)]+I];
	RETURN(R2);
	END;
! cell routines;

INTERNAL RECORD!CLASS CELL(RPTR (ANY!CLASS) CAR,CDR);

INTERNAL RPTR(CELL) PROCEDURE CONS(RPTR(ANY!CLASS) A,D);
	BEGIN
	RPTR(CELL) C;
	C←NEW!RECORD(CELL);
	CELL:CAR[C]←A;
	CELL:CDR[C]←D;
	RETURN(C);
	END;

INTERNAL RPTR(ANY!CLASS) RECURSIVE PROCEDURE SECOPY(RPTR(ANY!CLASS) C);
	BEGIN
	RPTR(CELL) L1,L2,L3;
	IF C=NULL!RECORD THEN RETURN(NULL!RECORD);
	IF RECTYPE(C) NEQ LOC(CELL) THEN RETURN(C);
	DO	BEGIN
		L3←NEW!RECORD(CELL);
		IF L1=NULL!RECORD THEN
			L2←L1←L3
		ELSE
			BEGIN
			CELL:CDR[L2]←L3;
			L2←L3;
			END;
		CELL:CAR[L2]←SECOPY(CELL:CAR[C]);
		C←CELL:CDR[C];
		END UNTIL RECTYPE(C) NEQ LOC(CELL);
	CELL:CDR[L2]←C;
	RETURN(L1);
	END;

INTERNAL BOOLEAN PROCEDURE IN!CL(RPTR(ANY!CLASS) C;RPTR(CELL) L);
	BEGIN
	WHILE L NEQ NULL!RECORD DO
		BEGIN
		IF C=CELL:CAR[L] THEN RETURN(TRUE);
		L←CELL:CDR[L];
		END;
	RETURN(FALSE);
	END;

INTERNAL RPTR(ANY!CLASS) PROCEDURE LLOP(REFERENCE RPTR(CELL) C);
	BEGIN
	RPTR(ANY!CLASS) V;
	IF RECTYPE(C) NEQ LOCATION(CELL) THEN 
		BEGIN
		USERERR(1,1,"LLOP CALLED WITH RECORD OF TYPE "&CVRTS(RECTYPE(C)));
		RETURN(NULL!RECORD);
		END;
	V←CELL:CAR[C];
	C←CELL:CDR[C];
	RETURN(V);
	END;

INTERNAL INTEGER PROCEDURE CL!LEN(RPTR(CELL) C);
	BEGIN
	INTEGER I;
	I←0;
	WHILE C NEQ NULL DO
		BEGIN
		I←I+1;
		C←CELL:CDR[C];
		END;
	RETURN(I);
	END;


INTERNAL RPTR(CELL) PROCEDURE APPEND(RPTR(CELL) ARG1, ARG2);
    BEGIN  "append"  ! Coded by RF;
    !  Appends the two lists by RPLACD on the last CDR field of ARG1;
    RPTR(CELL) P1, P2;
    IF ARG1 = NULL!RECORD THEN RETURN(ARG2);
    P1 ← ARG1;
    WHILE P1 NEQ NULL!RECORD DO
        BEGIN  ! Chain down ARG1 looking for the end;
        P2 ← P1;
        P1 ← CELL:CDR[P1];
        END;
    CELL:CDR[P2] ← ARG2;
    RETURN(ARG1);
    END "append";

INTERNAL RPTR(CELL) PROCEDURE LIST2(RPTR(ANY!CLASS) C1,C2);
	RETURN(CONS(C1,CONS(C2,NULL!RECORD)));

INTERNAL RPTR(ANY!CLASS) PROCEDURE CONSON(RPTR(ANY!CLASS) X;REFERENCE RPTR(CELL) C);
	BEGIN
	C←CONS(X,C);
	RETURN(X);
	END;
! rlist primitives;

INTERNAL RECORD!CLASS RLIST(INTEGER LEN;RPTR(CELL) FIRST,LAST);

INTERNAL PROCEDURE RLADD(RPTR(RLIST) RL;RPTR(ANY!CLASS) REC;INTEGER N);
	BEGIN
	! adds REC to RL after N;
	INTEGER I,L;
	RPTR(CELL) C1;

	L←RLIST:LEN[RL];
	IF N>L OR N<0 THEN
		BEGIN
		BUG("RLADD INDEX OUT OF RANGE:"&CVS(N));
		N←L;
		END;
	IF N=L THEN
		BEGIN
		IF N=0 THEN
			RLIST:FIRST[RL]←RLIST:LAST[RL]←CONS(REC,NULL!RECORD)
		ELSE
			BEGIN
			C1←CONS(REC,NULL!RECORD);
			CELL:CDR[RLIST:LAST[RL]]←C1;
			RLIST:LAST[RL]←C1;
			END;
		END
	ELSE IF N=0 THEN
		RLIST:FIRST[RL]←CONS(REC,RLIST:FIRST[RL])
	ELSE 
		BEGIN
		C1←RLIST:FIRST[RL];
		FOR I←2 STEP 1 UNTIL N DO C1←CELL:CDR[C1];
		CELL:CDR[C1]←CONS(REC,CELL:CDR[C1]);
		END;
	RLIST:LEN[RL]←L+1;
	END;
		
INTERNAL INTEGER PROCEDURE RLREM(RPTR(RLIST) RL;RPTR(ANY!CLASS) REC;
							INTEGER HOWMANY(1));
	BEGIN
	! Removes up to the first HOWMANY instances of REC from RL.
	  Returns the number actually removed.
	;
	INTEGER CNT;
	RPTR(CELL) C,CP;
	CNT←0;
	C←RLIST:FIRST[RL];CP←NULL!RECORD;
	WHILE C NEQ NULL!RECORD AND HOWMANY>0 DO
		BEGIN
		IF REC=CELL:CAR[C] THEN
			BEGIN
			C←CELL:CDR[C];
			IF CP NEQ NULL!RECORD THEN
				CELL:CDR[CP]←C
			ELSE
				RLIST:FIRST[RL]←C;
			RLIST:LEN[RL]←RLIST:LEN[RL]-1;
			HOWMANY←HOWMANY-1;
			CNT←CNT+1;
			IF C=NULL!RECORD THEN 
				RLIST:LAST[RL]←CP;
			END
		ELSE
			BEGIN
			CP←C;C←CELL:CDR[C];
			END;
		END;
	RETURN(CNT);
	END;

INTERNAL RPTR(ANY!CLASS) PROCEDURE RLNREM(RPTR(RLIST) RL;INTEGER N);
	BEGIN
	! removes RL[N] from RL & returns it;
	INTEGER I;
	IF 1 LEQ N LEQ RLIST:LEN[RL] THEN
		BEGIN
		RPTR(ANY!CLASS) REC;
		RPTR(CELL) C,CP;
		C←RLIST:FIRST[RL];CP←NULL!RECORD;
		FOR I←2 STEP 1 UNTIL N DO
			BEGIN
			CP←C;C←CELL:CDR[C];
			END;
		REC←CELL:CAR[C];C←CELL:CDR[C];
		IF N=1 THEN
			RLIST:FIRST[RL]←C
		ELSE
			CELL:CDR[CP]←C;
		IF C=NULL!RECORD THEN
			RLIST:LAST[RL]←CP;
		RLIST:LEN[RL]←RLIST:LEN[RL]-1;
		RETURN(REC);
		END;
	BUG("RLNREM OUT OF RANGE: "&CVS(N));
	RETURN(NULL!RECORD);
	END;

INTERNAL INTEGER PROCEDURE RLINX(RPTR(RLIST) RL;RPTR(ANY!CLASS) REC);
	BEGIN
	! returns index of REC in RL.;
	INTEGER I;RPTR(CELL) C;
	C←RLIST:FIRST[RL];
	FOR I←1 STEP 1 UNTIL RLIST:LEN[RL] DO
		BEGIN
		IF REC=CELL:CAR[C] THEN RETURN(I);
		C←CELL:CDR[C];
		END;
	RETURN(0);
	END;

INTERNAL RPTR(ANY!CLASS) PROCEDURE RLNTH(RPTR(RLIST) RL;INTEGER N);
	BEGIN
	! returns the N'th element of RL.;
	IF 1 LEQ N LEQ RLIST:LEN[RL] THEN
		BEGIN
		RPTR(CELL) C;
		C←RLIST:FIRST[RL];
		WHILE (N←N-1)>0 DO C←CELL:CDR[C];
		RETURN(CELL:CAR[C]);
		END
	ELSE
		BEGIN
		BUG("RLNTH OUT OF RANGE: "&CVS(N));
		RETURN(NULL!RECORD);
		END;
	END;

INTERNAL RPTR(RLIST) PROCEDURE RLCOPY(RPTR(RLIST) RL,RL2(NULL!RECORD));
	BEGIN
	! copies RL into RL2 & returns the copy.;
	RPTR(CELL) C;
	INTEGER L,I;
	IF RL2=NULL!RECORD THEN
		RL2←NEW!RECORD(RLIST)
	ELSE
		BEGIN
		RLIST:FIRST[RL2]←RLIST:LAST[RL2]←NULL!RECORD;
		RLIST:LEN[RL]←0;
		END;
	L←RLIST:LEN[RL]-1;
	C←RLIST:FIRST[RL];
	FOR I←0 STEP 1 UNTIL L DO
		BEGIN
		RLADD(RL2,CELL:CAR[C],I);
		C←CELL:CDR[C];
		END;
	END;

INTERNAL MATCHING RECPROC MAPRLIST(RPTR(RLIST) RL;REFERENCE RPTR(ANY!CLASS) R);
	BEGIN
	EXTERNAL RPTR(ANY!CLASS) PROCEDURE $REC$(INTEGER OP;RPTR(ANY!CLASS) R);
	RPTR(CELL) C,CP;
	RPTR(RLIST) RL1;
	PROCEDURE RL1KILL;
		BEGIN
		WHILE C NEQ NULL!RECORD DO 
			BEGIN
			CP←C;
			C←CELL:CDR[C];
			$REC$(DELETE!RECORD,C);
			END;
		RL1←RL1; ! access bug;
		$REC$(DELETE!RECORD,RL1);
		END;
	CLEANUP RL1KILL;

	RL1←RLCOPY(RL);
	C←RLIST:FIRST[RL1];
	WHILE C NEQ NULL!RECORD DO
		BEGIN
		R←CELL:CAR[C];CP←C;C←CELL:CDR[C];
		$REC$(DELETE!RECORD,CP);
		SUCCEED;
		END;
	FAIL;
	END;

END "RECAUX"