COMMENT ⊗   VALID 00006 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY RREAD
C00005 00003	SIMPROC SETFLD(INTEGER TYPPOINTER FLDINTEGER VAL)
C00007 00004	STRING SIMPROC CVASTR(INTEGER WD)
C00009 00005	PROCEDURE ARRRD(POINTER FIXUPINTEGER CHN)
C00011 00006	INTERNAL RPTR(ANY_CLASS) PROCEDURE RREAD(INTEGER CHNBOOLEAN PROCEDURE PRED)
C00015 ENDMK
C⊗;
ENTRY RREAD;

BEGIN "RECIN"

REQUIRE "PROLOG.HDR[SYS,PDQ]" SOURCE_FILE;
REQUIRE "LIB.HDR[SYS,PDQ]" SOURCE_FILE;

DEFINE RING=⊂INTEGER⊃;

EXTERNAL RECORD_CLASS $CLASS(RPTR($CLASS) RECRNGS;PROCEDURE HNDLER;INTEGER RECSIZ;
				INTEGER ARRAY TYPARR;STRING ARRAY TXTARR);

EXTERNAL RPTR(ANY_CLASS) PROCEDURE $REC$(INTEGER OP;RPTR($CLASS) R);

INTEGER DISKLOC;
EXTERNAL POINTER RECCHN;
POINTER RECARR;
DEFINE BSIZ=128;

PROCEDURE DSKPOS(INTEGER CHN,ADR);
BEGIN	INTEGER_ARRAY FOO[1:BSIZ];
	INTEGER N,S;
	IF (N←ADR-DISKLOC)<4*BSIZ THEN 
	 WHILE N>0 DO 
		⊂ S←BSIZ MIN N;N←N-S;ARRYIN(CHN,FOO[1],S)⊃
	 ELSE ⊂ USETI(CHN,ADR DIV BSIZ+1);
		ARRYIN(CHN,FOO[1],ADR MOD BSIZ);⊃;
	DISKLOC←ADR;
END;
	 
SIMPROC FIXUP(RPTR(ANY_CLASS) REC;REFERENCE RPTR(ANY_CLASS) L);
 START_CODE
	LABEL AGAIN,XIT;
	DEFINE A=1,B=2,R=3;
	MOVE A,L;MOVE R,REC;HRRZM R,L;
	JUMPE A,XIT;
 AGAIN:	MOVE B,(A);MOVEM R,(A);MOVE A,B;JUMPN A,AGAIN;
 XIT:
 END;


DEFINE MEMLOC(X)=⊂MEMORY[LOCATION(X)]⊃;

DEFINE RINGHD(X)=⊂(LOCATION(X)+2)⊃;

RPTR(ANY_CLASS) SIMPLE PROCEDURE RINGRT(REFERENCE POINTER R;POINTER HD);
START_CODE LABEL XIT;
	SKIPN 1,R;
	JRST XIT;		! NULL RECORD -- RETURN(NIL);
	HRRZ 2,HD;
	HRRZ 1,-1(1);		! RING POINTER;
	CAIN 1,(2);		! POINTER TO HEAD;
	MOVEI 1,0;
XIT:	MOVEM 1,R;
END;

RPTR($CLASS) PROCEDURE FINDREC(STRING S);
 BEGIN
   POINTER CLSHD,CLSPT;
   RPTR($CLASS) CLS;
   CLSPT←CLSHD←RINGHD($CLASS);
   WHILE (CLS←RINGRT(CLSPT,CLSHD))≠NIL DO
	IF EQU($CLASS:TXTARR[CLS][0],S) THEN RETURN(CLS);
   STRIN("CAN'T FIND RECORD="&S&CRLF);
   RETURN(NIL);
 END;

SIMPROC SETFLD(INTEGER TYP;POINTER FLD;INTEGER VAL);
 START_CODE
	DEFINE SP='16,A=1,B=2,T=3,R=4,V=5,S=6;
	LABEL FX,F0,ST1,F2S,ARR,FS,STRNG;
	MOVE V,VAL;
	MOVE R,FLD;
	SKIPN S,(R);		! DON'T CLOBBER DEFINED FIELDS;
	MOVEM V,(R);		! THIS WORKS FOR SIMPLE CASES;
	JUMPE V,FX;		! NULL FIELDS NEED NO MORE WORK;
	HLRZ T,TYP;
	LSH T,-5;
	TRNE T,'20;		! ARRAY?;
	JRST ARR;		! YES, ARRAY;
	CAIN T,3;		! STRING?;
	JRST STRNG;
	CAIE T,'15;		! RECORD?;
	JRST FX;		! NO, MUST BE SIMPLE TYPE ... DONE;
	MOVE A,RECARR;		! RECORD ARRAY BASE;
	ADD A,V;		! PLUS RECORD NUMBER;
	SKIPG B,(A);	
	HRROM R,(A);		! CHAIN THE UNDEFINED RECORD POINTER;
	MOVEM B,(R);		! POINT TO DEFINED RECORD OR FIXUP CHAIN;
	JRST FX;
	
STRNG:	MOVEM V,(S);		! FIXUP INFO PLACED IN STRING DESCR;
ARR:	HRL R,T;		! PUT ARRAY (OR STRING) TYPE IN LEFT HALF;
	PUSH SP,R;		! REMEMBER LOCATION TO FIXUP (WHICH CONTAINS IOWD);
    FX:
  END;


STRING SIMPROC CVASTR(INTEGER WD);
IF WD=0 THEN RETURN(NULL)
ELSE 
BEGIN	STRING S;
	S←CVSTR(WD);
	WHILE S[∞ FOR 1]=0 DO S←S[1:∞-1];
	RETURN(S);
END;

SIMPROC STRRD(POINTER F;INTEGER CHN);
BEGIN	INTEGER I,N,FIX;
	STRING S;
	FIX←MEMORY[F];
	IF RTHALF(FIX)≠DISKLOC THEN OUTSTR("DISK ORDERING ERROR");
	START_CODE HLRE 1,FIX;MOVNM 1,N;END;
	S←NULL;
	FOR I←1 STEP 1 UNTIL N-1 DO
	 S←S&CVSTR(WORDIN(CHN));
	S←S&CVASTR(WORDIN(CHN));	! SUPPRESS TRAILING NULLS AT END OF LAST WORD;
	MEMORY[F-1]←MEMORY[LOCATION(S)-1];
	MEMORY[F]←MEMORY[LOCATION(S)];
	! COPY STRING DESCR;
	DISKLOC←DISKLOC+N;
END;

SIMPROC STARRRD(INTEGER CHN;POINTER ARR);
 BEGIN	INTEGER I,WD,XOPT,N,PT,C,SIZ;
	STRING S;
	START_CODE MOVE 1,ARR;HRRZ 1,-2(1);MOVEM 1,SIZ;END;
	XOPT←POINT(7,WD,-1);
	N←0;
	FOR I←1 STEP 2 UNTIL SIZ DO
	 BEGIN
	  S←NULL;
	  WHILE TRUE DO
	    BEGIN
		IF N=0 THEN 
		  BEGIN WD←WORDIN(CHN);N←5;PT←XOPT;DISKLOC←DISKLOC+1;END;
		C←ILDB(PT);N←N-1;
		IF C=NULL THEN DONE;
		S←S&C;
	    END;
	  MEMORY[ARR+I-2]←MEMORY[LOCATION(S)-1];
	  MEMORY[ARR+I-1]←MEMORY[LOCATION(S)];
	 END;
 END;		

PROCEDURE ARRRD(POINTER FIXUP;INTEGER CHN);
BEGIN	INTEGER I,LOC,T,N,DIM,CHNL,SIZ;
	EXTERNAL PROCEDURE ARMAK;
	POINTER ARR;
	DIM←WORDIN(CHNL←CHN);
	START_CODE 
		HLRE 1,DIM;MOVMM 1,I;HRR 1,I;MOVEM 1,N;
	END;
	
	I←2*I;
	
	DISKLOC←DISKLOC+I+1;
	START_CODE
	 DEFINE P='17;
	 LABEL AGAIN;
AGAIN:	 PUSH P,CHNL;PUSHJ P,WORDIN;PUSH P,1;	! BOUNDS;
	 SOSLE I;JRST AGAIN;
	 PUSH P,N;				! N NEGATIVE FOR STRING ARRAY;
	 PUSHJ P,ARMAK;
	 MOVEM 1,ARR;				! ALLOCATE THE ARRAY;
	 HRRZ 1,-1(1);
	 MOVEM 1,SIZ;				! NO GOOD FOR STRING ARRAYS;
	END;
	MEMORY[FIXUP]←ARR;
	T←LTHALF(FIXUP);
	IF T='41 THEN 				! RECORD ARRAY;
	 FOR I←1 STEP 1 UNTIL SIZ DO
	  	MEMORY[ARR+I-1]←MEMORY[RECARR+WORDIN(CHNL)]
	ELSE IF T='27 THEN			! STRING ARRAY;
		STARRRD(CHN,ARR)
	ELSE START_CODE 			! SIMPLE TYPE ARRAY;
		DEFINE P='17;
		PUSH P,CHNL;PUSH P,ARR;PUSH P,SIZ;PUSHJ P,ARRYIN;
	     END;
	IF T≠'27 THEN DISKLOC←DISKLOC+SIZ;
END;
	
INTERNAL RPTR(ANY_CLASS) PROCEDURE RREAD(INTEGER CHN;BOOLEAN PROCEDURE PRED);
BEGIN
	INTEGER RECNUM;
	RPTR(ANY_CLASS) HANDLE;
	INTEGER SPSAV,SPTOP;
	
	START_CODE MOVEM '16,SPSAV;END;		! REMEMBER INITIAL STRING STACK;
	
	RECNUM←WORDIN(CHN);
	DISKLOC←1;
	 BEGIN
		INTEGER I,J,NAM,SIZ,SPNUM;
		RPTR($CLASS) CLS;
		RPTR(ANY_CLASS) ARRAY RECS[0:RECNUM];
		RPTR(ANY_CLASS) REC;

		START_CODE MOVE 1,RECS;MOVEM 1,RECARR;END;
		
		FOR I←1 STEP 1 UNTIL RECNUM DO
		 BEGIN
			NAM←WORDIN(CHN);		! SIXBIT RECORD CLASS NAME;
			CLS←FINDREC(CV6STR(NAM));	! FIND RECORD CLASS;
			REC←$REC$(1,CLS);		! ALLOCATE RECORD;
			SIZ←$CLASS:RECSIZ[CLS];
			DISKLOC←DISKLOC+SIZ+1;
			
			FOR J←1 STEP 1 UNTIL SIZ DO	! READ ALL FIELDS;
			   SETFLD($CLASS:TYPARR[CLS][J],MEMLOC(REC)+J,WORDIN(CHN));

			FIXUP(REC,RECS[I]);		! FIXUP ALL FORWARD REFERENCES;
		 END;

		HANDLE←RECS[1];
				! WE NOW HAVE ALL RECORDS;
				! STRING STACK CONTAINS FIXUP INFO FOR ARRAYS AND STRINGS;
		START_CODE
		 MOVE 1,'16;SUB 1,SPSAV;HRRZM 1,SPNUM;
		END;		! DETERMINE NUMBER OF FIXUPS;

		IF SPNUM>0 THEN
		BEGIN "FIXES"
		 INTEGER_ARRAY FIXUP[1:SPNUM];
		 INTEGER L,F,I,TOTSIZ,VIRTLOC,TYP;
		 FOR I←SPNUM STEP -1 UNTIL 1 DO
		  BEGIN 
			START_CODE POP '16,F;END;	! WIND DOWN STRING STACK;
			FIXUP[I]←F;			! STORE FIXUPS;
		  END;
		 VIRTLOC←DISKLOC;
		 FOR I←1 STEP 1 UNTIL SPNUM DO
		  BEGIN	F←FIXUP[I];
			L←MEMORY[F];			! PROCESS FIXUPS;
			TYP←LTHALF(F);
			TOTSIZ←-(MEMORY[F] ASH -18);
			IF PRED(TOTSIZ,TYP) THEN
			 ⊂ MEMORY[F]←0;VIRTLOC←VIRTLOC+TOTSIZ;⊃
			ELSE 
			 BEGIN	IF VIRTLOC>DISKLOC THEN DSKPOS(CHN,VIRTLOC);
				IF TYP=3 THEN STRRD(L,CHN)
				 ELSE ARRRD(F,CHN);
				VIRTLOC←DISKLOC;
			 END;
		  END;
		END "FIXES";
	 END;
	RETURN(HANDLE);
END "RREAD";


INTERNAL RPTR(ANY_CLASS) PROCEDURE RECIN(STRING FILE;BOOLEAN PROCEDURE PRED);
 BEGIN	INTEGER CHN;
	RPTR(ANY_CLASS) REC;
	RPTR(IO) INP;
	CHN←MKIODEV(FILE);
	INP←IOCHANS[CHN];
	IO:MODE[INP]←'14;
	FILEOP("L",CHN);
	REC←RREAD(CHN,PRED);
	FILEOP("R",CHN);
	RETURN(REC);
 END;
	
END "RECIN";