Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-01 - decus/20-0002/recaux.sai
There is 1 other file named recaux.sai in the archive. Click here to see a list.
COMMENT    VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	Auxilliary record service routines.  
C00003 00003	! rectype, $rectype, cvrts, bldnrc, chkrec, cpyrec, etc
C00008 00004	! cell routines
C00012 00005	! rlist primitives
C00018 ENDMK
C;

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

ENTRY;

BEGIN "RECAUX"

REQUIRE "ABBREV.SAI[S,RHT]" SOURCEFILE;
REQUIRE "MACROS.SAI[S,RHT]" SOURCEFILE;
REQUIRE "STCODE.DEF[S,RHT]" SOURCEFILE;
REQUIRE "SYS:RECORD.DEF" SOURCEFILE;


DEFINE RPTR="RECORDPOINTER";


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

INTERNAL INTEGER SIMPLE PROCEDURE RECLEN(RPTR(ANYCLASS) R);
	STARTCODE
	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 (ANYCLASS) R);
	STARTCODE
	SKIPE	1,R;
	HRRZ	1,(1);
	END;

INTERNAL RPTR($CLASS) SIMPLE PROCEDURE $RECTYPE(RPTR(ANYCLASS) R);
	STARTCODE
	SKIPE	1,R;
	HRRZ	1,(1);
	END;

INTERNAL INTEGER PROCEDURE FLDTYPE(RPTR (ANYCLASS) 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);
	STARTCODE
	JRST	CVRCS;
	END;

INTERNAL INTEGER PROCEDURE FLDREF(RPTR(ANYCLASS) 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
                        STARTCODE
                        MOVE 1,RC;
                        HLRZ 1,-1(1);
                        CAIN 1,$CLASS;
                        JRST    XIT;
                        MOVEM 1,RC;
                        END;
		END;
	XIT:RETURN(NULLRECORD);
	END;

INTERNAL RECORDPOINTER(ANYCLASS) PROCEDURE BLDNRC(INTEGER RT);
	STARTCODE

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

	rptr(id) procedure newid(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(ANYCLASS) PROCEDURE CHKREC(RPTR(ANYCLASS) R;INTEGER T);
	BEGIN
	IF T0  RECTYPE(R)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(ANYCLASS) PROCEDURE CPYREC(RPTR(ANYCLASS) R1,R2(NULLRECORD));
	BEGIN
	INTEGER I;
	IF R2=NULLRECORD THEN
		R2_$REC$(ALLOCATERECORD,$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 RECORDCLASS CELL(RPTR (ANYCLASS) CAR,CDR);

INTERNAL RPTR(CELL) PROCEDURE CONS(RPTR(ANYCLASS) A,D);
	BEGIN
	RPTR(CELL) C;
	C_NEWRECORD(CELL);
	CELL:CAR[C]_A;
	CELL:CDR[C]_D;
	RETURN(C);
	END;

INTERNAL RPTR(ANYCLASS) RECURSIVE PROCEDURE SECOPY(RPTR(ANYCLASS) C);
	BEGIN
	RPTR(CELL) L1,L2,L3;
	IF C=NULLRECORD THEN RETURN(NULLRECORD);
	IF RECTYPE(C)LOC(CELL) THEN RETURN(C);
	DO	BEGIN
		L3_NEWRECORD(CELL);
		IF L1=NULLRECORD 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)LOC(CELL);
	CELL:CDR[L2]_C;
	RETURN(L1);
	END;

INTERNAL BOOLEAN PROCEDURE INCL(RPTR(ANYCLASS) C;RPTR(CELL) L);
	BEGIN
	WHILE LNULLRECORD DO
		BEGIN
		IF C=CELL:CAR[L] THEN RETURN(TRUE);
		L_CELL:CDR[L];
		END;
	RETURN(FALSE);
	END;

INTERNAL RPTR(ANYCLASS) PROCEDURE LLOP(REFERENCE RPTR(CELL) C);
	BEGIN
	RPTR(ANYCLASS) V;
	IF RECTYPE(C)LOCATION(CELL) THEN 
		BEGIN
		USERERR(1,1,"LLOP CALLED WITH RECORD OF TYPE "&CVRTS(RECTYPE(C)));
		RETURN(NULLRECORD);
		END;
	V_CELL:CAR[C];
	C_CELL:CDR[C];
	RETURN(V);
	END;

INTERNAL INTEGER PROCEDURE CLLEN(RPTR(CELL) C);
	BEGIN
	INTEGER I;
	I_0;
	WHILE CNULL 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 = NULLRECORD THEN RETURN(ARG2);
    P1 _ ARG1;
    WHILE P1  NULLRECORD 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(ANYCLASS) C1,C2);
	RETURN(CONS(C1,CONS(C2,NULLRECORD)));

INTERNAL RPTR(ANYCLASS) PROCEDURE CONSON(RPTR(ANYCLASS) X;REFERENCE RPTR(CELL) C);
	BEGIN
	C_CONS(X,C);
	RETURN(X);
	END;

! rlist primitives;

INTERNAL RECORDCLASS RLIST(INTEGER LEN;RPTR(CELL) FIRST,LAST);

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

	L_RLIST:LEN[RL];
	IF N>L  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,NULLRECORD)
		ELSE
			BEGIN
			C1_CONS(REC,NULLRECORD);
			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(ANYCLASS) 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_NULLRECORD;
	WHILE CNULLRECORD  HOWMANY>0 DO
		BEGIN
		IF REC=CELL:CAR[C] THEN
			BEGIN
			C_CELL:CDR[C];
			IF CPNULLRECORD 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=NULLRECORD THEN 
				RLIST:LAST[RL]_CP;
			END
		ELSE
			BEGIN
			CP_C;C_CELL:CDR[C];
			END;
		END;
	RETURN(CNT);
	END;

INTERNAL RPTR(ANYCLASS) PROCEDURE RLNREM(RPTR(RLIST) RL;INTEGER N);
	BEGIN
	! removes RL[N] from RL & returns it;
	INTEGER I;
	IF 1NRLIST:LEN[RL] THEN
		BEGIN
		RPTR(ANYCLASS) REC;
		RPTR(CELL) C,CP;
		C_RLIST:FIRST[RL];CP_NULLRECORD;
		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=NULLRECORD THEN
			RLIST:LAST[RL]_CP;
		RLIST:LEN[RL]_RLIST:LEN[RL]-1;
		RETURN(REC);
		END;
	BUG("RLNREM OUT OF RANGE: "&CVS(N));
	RETURN(NULLRECORD);
	END;

INTERNAL INTEGER PROCEDURE RLINX(RPTR(RLIST) RL;RPTR(ANYCLASS) 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(ANYCLASS) PROCEDURE RLNTH(RPTR(RLIST) RL;INTEGER N);
	BEGIN
	! returns the N'th element of RL.;
	IF 1NRLIST: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(NULLRECORD);
		END;
	END;

INTERNAL RPTR(RLIST) PROCEDURE RLCOPY(RPTR(RLIST) RL,RL2(NULLRECORD));
	BEGIN
	! copies RL into RL2 & returns the copy.;
	RPTR(CELL) C;
	INTEGER L,I;
	IF RL2=NULLRECORD THEN
		RL2_NEWRECORD(RLIST)
	ELSE
		BEGIN
		RLIST:FIRST[RL2]_RLIST:LAST[RL2]_NULLRECORD;
		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(ANYCLASS) R);
	BEGIN
	EXTERNAL RPTR(ANYCLASS) PROCEDURE $REC$(INTEGER OP;RPTR(ANYCLASS) R);
	RPTR(CELL) C,CP;
	RPTR(RLIST) RL1;
	PROCEDURE RL1KILL;
		BEGIN
		WHILE CNULLRECORD DO 
			BEGIN
			CP_C;
			C_CELL:CDR[C];
			$REC$(DELETERECORD,C);
			END;
		RL1_RL1; ! access bug;
		$REC$(DELETERECORD,RL1);
		END;
	CLEANUP RL1KILL;

	RL1_RLCOPY(RL);
	C_RLIST:FIRST[RL1];
	WHILE CNULLRECORD DO
		BEGIN
		R_CELL:CAR[C];CP_C;C_CELL:CDR[C];
		$REC$(DELETERECORD,CP);
		SUCCEED;
		END;
	FAIL;
	END;

END "RECAUX"