COMMENT ⊗   VALID 00007 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY RECOUT
C00004 00003	INTEGER SIMPROC FLDVAL(INTEGER FLD,TYP)
C00007 00004	SIMPROC STAOUT(POINTER IOWINTEGER CHN)
C00009 00005	SIMPROC ARROUT(POINTER ARRINTEGER CHN)
C00011 00006	INTEGER SIMPLE PROCEDURE RECSW0
C00015 00007		! OUTPUT ALL STRINGS AND ARRAYS
C00017 ENDMK
C⊗;
ENTRY RECOUT;

BEGIN "RECOUT"

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

INTEGER DISKLOC;
EXTERNAL POINTER RECCHN;
POINTER RECS1,RECS1P1;
INTEGER RECNUM,TOTNUM;
DEFINE RING=⊂INTEGER⊃;

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

RPTR($CLASS) PROCEDURE RECCLS(RPTR(ANY_CLASS) R);
 START_CODE MOVE 1,R;HRRZ 1,(1);END;

INTERNAL INTEGER PROCEDURE RECLEN(RPTR(ANY_CLASS) R);
		RETURN($CLASS:RECSIZ[RECCLS(R)]);

INTERNAL STRING PROCEDURE CVRTS(RPTR(ANY_CLASS) REC);
RETURN(IF REC=NIL THEN "NIL"
	ELSE $CLASS:TXTARR[RECCLS(REC)][0]);

DEFINE MEMLOC(X)=⊂MEMORY[LOCATION(X)]⊃;
INTEGER SIMPROC FLDVAL(INTEGER FLD,TYP);
 START_CODE
	DEFINE SP='16;
	LABEL FX,F0,ST1,F2S,ARR,FS;
	SKIPN 1,FLD;
	JRST FX;		! NOTHING TO DO FOR NULL FIELD;
	HLRZ 3,TYP;
	LSH 3,-5;		! ADJUST TYPE BITS;
	TRNE 3,'20;		! ARRAY?;
	SOJA 1,ARR;		! YES;

	CAIN 3,'15;		! RECORD?;
	HLRZ 1,(1);		! GET RECORD #;
	CAIE 3,3;		! STRING?;
	JRST FX;		! NO, DONE;
	HRLI 1,-1;		! STRING POINTER HAS -1 IN LEFT HALF;
	PUSH SP,1;		! PUSH POINTER TO STRING DESC;
	HRRZ 4,-1(1);		! LENGTH OF STRING;
	ADDI 4,1;		! EXTRA NULL AT END OF STRING;
	IDIVI 4,5;
	SKIPE 5;
	ADDI 4,1;		! # WORDS FOR STRING;
	JRST FS;		! ALLOCATE SPACE;

ARR:	HRLI 1,0;		! ZERO LEFT HALF;
	CAIE 3,'27;		! COMPLICATED CASE OF ARRAY;
	AOJA 1,F0;
				! HERE WE HAVE A STRING ARRAY;
				! WE MUST COMPUTE THE SPACE IT WILL TAKE;
	HRLZ 2,-1(1);		! LENGTH;
	MOVNS 2;
	HRR 2,1;		! IOWD TO ARRAY;
	MOVEI 4,0;

ST1:	HRRZ 3,(2);		! GET LENGTH OF STRING;
	ADDI 4,1(3);		! SUM(LENGTH(I)+1);
	ADD 2,['1000001];
	AOBJN 2,ST1;

	IDIVI 4,5;		! TOTAL WORDS NEEDED FOR STRINGS;
	SKIPE 5;
	ADDI 4,1;		! +1;
	MOVE 2,4;
	HLL 2,-1(1);		! # DIMS;
	JRST F2S;		! IOWD FOR DISK VERSION OF STRING ARRAY;

F0:	CAIN 3,'41;
	HRLI 1,1;		! RECORD ARRAY - INDICATE IN LEFT HALF;
	MOVE 2,-1(1);		! #DIMS,,LENGTH;

F2S:	PUSH SP,1;		! REMEMBER POINTER TO ARRAY;
	HLRE 4,2;		! #DIMS;
	MOVMS 4;
	ADDI 4,1(4);		! 2*#DIMS+1;
	ADDI 4,(2);		! TOTAL LENGTH OF OUTPUT;

FS:	MOVN 1,4;
	MOVSS 1;
	HRR 1,DISKLOC;		! RETURN IOWD TO ARRAY ON DISK;
	ADDM 4,DISKLOC;		! ACCUMULATE ARRAY LENGTHS;
    FX:
  END;


SIMPROC STAOUT(POINTER IOW;INTEGER CHN);
! OUTPUT A STRING ARRAY;
BEGIN	INTEGER XOPT,WD,CHNL;
	XOPT←POINT(7,WD,-1);
	CHNL←CHN;
	START_CODE
		LABEL NW,NC,DC,STX,NXT,NXTS,NCEND;
		DEFINE A=1,OPT=2,PT=3,N=4,C=5,P='17;
		MOVE A,IOW;			! IOWD TO LIST OF STRINGS;
		MOVE OPT,XOPT;

	NXTS:	MOVE PT,(A);			! STRING POINTER;
		HRRZ N,-1(A);			! LENGTH;
	NCEND:	PUSH P,A;
NW:	NC:	 JUMPLE N,STX;
		 ILDB C,PT;
 	DC:	 IDPB C,OPT;
		 TLNE OPT,'760000;
		 SOJA N,NC;		! WORD FILLED;
		 PUSH P,N;
		 PUSH P,PT;
		 PUSH P,CHNL;
		 PUSH P,WD;
		 PUSHJ P,WORDOUT;	! OUTPUT THE WORD;
		 POP P,PT;
		 POP P,N;
		 MOVE OPT,XOPT;
		 SOJA N,NW;
		 
	 STX:	 JUMPL N,NXT;
		 MOVEI C,0;
		 SOJA N,DC;		! END WITH A NULL CHAR;

	 NXT:	 POP P,A;
		 ADD A,['2000002];
		 JUMPL A,NXTS;		! AGAIN WITH NEXT STRING;
		 MOVEI N,3;
		 MOVEI PT,0;
		 TLNN A,-1;
		 JRST NCEND;		! DEPOSIT 4 NULLS TO FLUSH LAST WORD;

	END;
END "STAOUT";

SIMPROC STOUT(POINTER ST;INTEGER CHN);
! OUTPUT A SINGLE STRING;
 START_CODE MOVEI 1,-2;HRLM 1,-2('17);JRST STAOUT;END;

SIMPROC ARROUT(POINTER ARR;INTEGER CHN);
! OUTPUT ALL KINDS OF ARRAYS;
BEGIN
  DEFINE P='17;
  INTEGER DIM,WDS,DIMWD;
  POINTER AR,RA,IOW;
   START_CODE
	MOVE 1,ARR;
	HRRZM 1,AR;
	HLRZM 1,RA;
	MOVE 2,-1(1);		! #DIMS,,LENGTH;
	MOVEM 2,DIMWD;
	HLRE 3,2;		! #DIMS;
	MOVMS 3;
	MOVEM 3,DIM;
	HRRZM 2,WDS;
	MOVNS 2;
	HRL 1,2;
	MOVEM 1,IOW;		! IOWD TO ARRAY;
   END;

BEGIN
 INTEGER L,W;
 WORDOUT(CHN,DIMWD);
 FOR L←1 STEP 1 UNTIL DIM  DO
  BEGIN	 WORDOUT(CHN,MEMORY[W←AR-1-3*L]);	! LOWER BOUND;
	 WORDOUT(CHN,MEMORY[W+1]);	! UPPER BOUND;
  END;
END;

IF RA=1 THEN	
  START_CODE 				! OUTPUT THE RECORD ARRAY;
	LABEL L1;
	MOVE 1,IOW;			! IOWD TO ARRAY;
 L1:	MOVE 2,(1);			! ARRAY ELEMENT;
	HLRZ 2,(2);			! RECORD#;
	PUSH P,1;
	PUSH P,CHN;
	PUSH P,2;
	PUSHJ P,WORDOUT;
	POP P,1;
	AOBJN 1,L1;
  END
 
 ELSE IF DIMWD≥0 THEN			! OUTPUT SIMPLE ARRAY;
  START_CODE PUSH P,CHN;PUSH P,AR;PUSH P,WDS;PUSHJ P,ARRYOUT;END 

 ELSE STAOUT(IOW+1,CHN);		! OUTPUT STRING ARRAY;
END "ARROUT";
INTEGER SIMPLE PROCEDURE RECSW0;
! DETERMINE NUMBER OF MARKED RECORDS: LENGTH OF CHAIN;
START_CODE
	DEFINE N=1,A=2;
	LABEL L,LX;
	MOVEI N,0;
	HLRZ A,RECCHN;
L:	CAIN A,-1;	! END OF CHAIN?;
	JRST LX;	! YES, DONE;
	HLRZ A,(A);	! NO, FOLLOW CHAIN;
	AOJA N,L;
LX: END;
	

EXTERNAL PROCEDURE $RMARK;

INTERNAL PROCEDURE RECOU2(RPTR(ANY_CLASS) HANDLE;INTEGER CHN);
BEGIN
	RPTR(ANY_CLASS) R;
	POINTER LST,SPSAV,SPTOP;
	INTEGER I;

	PROCEDURE OUTREC(RPTR(ANY_CLASS) R;INTEGER CHN);
	 BEGIN
		INTEGER N,I,NAM;
		POINTER LR,LC;
		RPTR($CLASS) RCL;
		RCL←RECCLS(R);
		N←$CLASS:RECSIZ[RCL];
		NAM←CVSIX($CLASS:TXTARR[RCL][0]);
		LC←MEMLOC($CLASS:TYPARR[RCL]);	! POINTER TO TYPARR;
		LR←MEMLOC(R);			! POINTER TO RECORD;

		WORDOUT(CHN,NAM);		! OUTPUT RECORD CLASS ID;
		FOR I←1 STEP 1 UNTIL N DO
		   WORDOUT(CHN,FLDVAL(MEMORY[LR+I],MEMORY[LC+I]));	! EACH FIELD;
	 END "OUTREC";

	START_CODE
	 MOVE 1,HANDLE;HRROS (1);HRROM 1,RECCHN;! MARK ALL ACCESSIBLE FROM HANDLE;
	 MOVEM '16,SPSAV;			! REMEMBER STRING STACK POINTER;
	END;
	$RMARK;			! MARK ALL RECORDS ACCESSABLE FROM REC;
	RECNUM←RECSW0;		! DETERMINE NUMBER OF RECORDS;
				! 1ST SWEEP PASS - ASSIGN RECORD #S;
	BEGIN
	 RPTR(ANY_CLASS) ARRAY RECARR[1:RECNUM];
	 START_CODE
		DEFINE RECSIZ=3,TYPARR=4,TXTARR=5;
		DEFINE A=1,L=2,H=3,N=4,S=5,B=7;
		LABEL L1,L2,LX;
		MOVE S,RECNUM;		! SIZE←RECNUM+SUM(RECSIZ(I));
		MOVEI N,2;
		MOVE L,RECARR;
		HLRZ A,RECCHN;
		MOVE H,HANDLE;
		MOVE B,(H);		! CLASS;
		ADD S,RECSIZ(B);	! SIZE OF HANDLE;
		MOVEM H,(L);		! RECARR[1]←HANDLE;
		AOJA L,L2;

 	L1:	HLRZ A,(A);
	L2:	CAIN A,-1;
		JRST LX;		! DONE;
		CAMN A,H;		! DON'T INDEX HANDLE AGAIN;
		JRST L1;
		MOVEM A,(L);
		MOVE B,(A);		! CLASS;
		MOVE B,RECSIZ(B);	! SIZE OF RECORD;
		ADD S,B;		! ACCUMULATE RECORD SIZES;
		HLRZ B,(A);		! FOLLOW CHAIN;
		HRLM N,(A);		! INSERT RECORD INDEX;
		MOVE A,B;
		AOS L;
		AOJA N,L2;
	 LX:	MOVEI N,1;
		HRLM N,(H);		! INDEX HANDLE;
		MOVEM S,TOTNUM;
	  END;
	DISKLOC←1+TOTNUM;
	WORDOUT(CHN,RECNUM);
	FOR I←1 STEP 1 UNTIL RECNUM DO
	 OUTREC(RECARR[I],CHN);			! OUTPUT ALL RECORDS;
	! OUTPUT ALL STRINGS AND ARRAYS;
	 START_CODE
		DEFINE SP='16,P='17;
		LABEL L,LX;
		MOVEM SP,SPTOP;
		MOVE SP,SPSAV;
	 L:	CAMN SP,SPTOP;
		JRST LX;			! DONE;
		ADD SP,['1000001];
		PUSH P,(SP);
		PUSH P,CHN;
		SKIPL (SP);
		PUSHJ P,ARROUT;			! ARRAY;
		SKIPGE (SP);
		PUSHJ P,STOUT;			! STRING;
		JRST L;

	 LX:	MOVE SP,SPSAV;
	 END;

	! LAST PASS TO UNMUNG RECORD INDEX (MARK) FIELDS;
	FOR I←1 STEP 1 UNTIL RECNUM DO
	 BEGIN	R←RECARR[I];
		QUICK_CODE MOVE 1,R;HRRZS (1);END;
	 END;
    END;
END "RECOU2";


INTERNAL PROCEDURE RECOUT(RPTR(ANY_CLASS) R;STRING FILE);
BEGIN
	INTEGER CHN;
	RPTR(IO) ODEV;
	CHN←MKIODEV(FILE);
	ODEV←IOCHANS[CHN];
	IO:MODE[ODEV]←'14;
	FILEOP("E",CHN);
	RECOU2(R,CHN);
	FILEOP("R",CHN);
END;

END "RECOUT";