COMMENT ⊗   VALID 00009 PAGES 
RECORD PAGE   DESCRIPTION
 00001 00001
 00002 00002	BEGIN "XREF"
 00005 00003	INTEGER PROCEDURE MIN(INTEGER X,Y)
 00007 00004	FIRST COMPUTE OPTIMAL NUMBER OF PASSES
 00008 00005	FOR NUM←1 STEP 1 UNTIL NUMS DO
 00009 00006	FOR NUMS←1 STEP 1 UNTIL PASSES DO
 00010 00007	INTEGER PROCEDURE LOOKUP(STRING A)
 00013 00008	INTEGER PROCEDURE LOOKUP(STRING A)
 00014 00009	DEFINE PGMRK= "'201004020101",WUN="'1000000",EXECBIT="'400000000000",
 00019 ENDMK
⊗;
BEGIN "XREF"
DEFINE GOODSWT = "NULL";
DEFINE SWTSIZ = "1";
DEFINE PROCESSOR = """XREF""";
DEFINE SRCEXT = "NULL";
DEFINE RELEXT = """XRF""";
DEFINE LSTEXT = """LST""";
DEFINE RELMODE = "0";
DEFINE SRCMODE = "0";
DEFINE LSTMODE = "0";

REQUIRE "SCNCMD[1,DCS]" SOURCE_FILE;
DEFINE ⊂ = " BEGIN ", ⊃ = " END ",! = " COMMENT ";
DEFINE OTPT="2",SLOUGH="1",IDSCAN="2",CMNT="3",EXSCAN= "4",
	CHKEOF= "IF SRCEOF THEN GO TO PASS2",LBLBIT= "'400000",
	L_HALF(X)= "((X LSH (-18))LAND '377777)", R_HALF(X)= "(X LAND '377777)";
DEFINE TAB="'11",SYMNO="4092",FORM="'14",BITS2="'400000400000";
INTEGER WASTHERE,CURLIN,L_PTR,K,NN,KK,L,SYMBOL,I,CURPAGE,EXECHK,III,
	NP,KP,L_SIZE;
STRING FOO,NEWNAM,LETS,DIGS;
INTEGER ARRAY LTAB[0:4095];
OUTSTR("HOW MUCH LIST SPACE?");
FOO← INCHWL;
L_SIZE← INTSCAN(FOO,NN);

BEGIN INTEGER ARRAY L_SPACE[2:L_SIZE+1];

LABEL L1,PASS2,L2,L3;
STRING ARRAY SYM[0:4095];

INTEGER PROCEDURE NODE(INTEGER A,B);
	⊂ L_PTR← L_PTR+2;
	IF L_PTR > L_SIZE THEN USERERR(0,0,"L_SPACE FULL");
	L_SPACE[L_PTR]← A LOR CURPAGE;
	L_SPACE[L_PTR+1]← B;
	RETURN(L_PTR)
	END;
Comment Generalized sort routine.

The input and output arrays must be (the same) 
power of two in length, starting at 0 or 0,0.  For
efficiency you may remove the arrays from the
calling sequence and replace references to INS
and OUTS by your own global variable names;




PROCEDURE SORT( STRING ARRAY INS; INTEGER ARRAY INDATA;
      INTEGER SIZE);

BEGIN "SORT"
   INTEGER BASE,GROUP,NUMS,NUM,I,J,K,L,PASSES;
   STRING ARRAY OUTS[0:SIZE-1]; 
   INTEGER ARRAY OUTDATA[0:SIZE-1];
   STRING S1,S2;
Comment the first phase sorts groups of SIZE/(2↑PASSES)
strings into alphameric order. Subsequent phases will then
merge these groups, forming larger groups. An odd number
of passes will result in the input array containing the final
result;

INTEGER PROCEDURE MIN(INTEGER X,Y);
 RETURN(IF X<Y THEN X ELSE Y);

BOOLEAN PROCEDURE STRINGLESS(STRING A,B);
BEGIN
   INTEGER CHA,CHB,I;
   IF LENGTH(B)=0 THEN RETURN(TRUE);
   IF LENGTH(A)=0 THEN RETURN(FALSE);
   FOR I←1 STEP 1 UNTIL MIN(LENGTH(A),LENGTH(B)) DO
   BEGIN
      CHA←A[I FOR 1];  CHB←B[I FOR 1];
      IF CHA<CHB THEN RETURN(TRUE);
      IF CHA>CHB THEN RETURN(FALSE);
   END;
   RETURN(IF LENGTH(A)≤LENGTH(B) THEN TRUE ELSE FALSE) 
END;


COMMENT FIRST COMPUTE OPTIMAL NUMBER OF PASSES;

J←SIZE;
FOR PASSES←-2 STEP 1 UNTIL 1000 DO
BEGIN
   J←J LSH -1;
   IF J=0 THEN DONE
END;
IF PASSES<1 THEN PASSES←1;


NUMS←2↑PASSES ; COMMENT NUMBER OF GROUPS;
GROUP←SIZE%NUMS ; COMMENT SIZE OF EACH GROUP;
BASE←0;
FOR NUM←1 STEP 1 UNTIL NUMS DO
BEGIN "SORT PHASE"
   INTEGER FLAG,I,J,K; LABEL BACK; STRING A;
   I←BASE+GROUP-1;
   K←0;

BACK:
   FLAG←FALSE;
   K←K+1;

   FOR J←BASE STEP 1 UNTIL I-K DO
   IF ¬STRINGLESS(S1←INS[J],S2←INS[J+1]) THEN
   BEGIN
      INS[J]←S2;
      INS[J+1]←S1;
      INDATA[J] ↔ INDATA[J+1];
      FLAG←TRUE
   END;

   IF FLAG THEN GO TO BACK;

   BASE←I+1

END "SORT PHASE";



FOR NUMS←1 STEP 1 UNTIL PASSES DO
BEGIN "MERGE PHASE"
INTEGER LIM;

LIM←SIZE%(2*GROUP);

FOR NUM←1 STEP 1 UNTIL LIM DO
BEGIN 
   I←2*(NUM-1)*GROUP;
   J←(2*NUM-1)*GROUP;
   K←2*NUM*GROUP;
   L←J;


   IF NUMS MOD 2 = 1 THEN
   FOR BASE←I STEP 1 UNTIL K-1 DO
   BEGIN
      IF I<L THEN S1←INS[I] ELSE S1←NULL;
      IF J<K THEN S2←INS[J] ELSE S2←NULL;
      IF J=K ∨ I≠L ∧  STRINGLESS(S1,S2) THEN 
      BEGIN
         OUTS[BASE]←S1;
         OUTDATA[BASE]←INDATA[I];
         I←I+1
      END ELSE

      BEGIN
         OUTS[BASE]←S2;
         OUTDATA[BASE]←INDATA[J];
         J←J+1
      END
   END

   ELSE
   FOR BASE←I STEP 1 UNTIL K-1 DO
   BEGIN
      IF I<L THEN S1←OUTS[I] ELSE S1←NULL;
      IF J<K THEN S2←OUTS[J] ELSE S2←NULL;
      IF J=K ∨ I≠L ∧  STRINGLESS(S1,S2) THEN 
      BEGIN
         INS[BASE]←S1;
         INDATA[BASE]←OUTDATA[I];
         I←I+1
      END ELSE

      BEGIN
         INS[BASE]←S2;
         INDATA[BASE]←OUTDATA[J];
         J←J+1
      END
   END;


   IF J≠K OR I≠L THEN BEGIN INTEGER X; X←CALL(0,"EXIT")END;

END;

   GROUP←GROUP*2
END "MERGE PHASE";

IF PASSES MOD 2 = 1 THEN
FOR I←0 STEP 1 UNTIL SIZE-1 DO
BEGIN
   INDATA[I]←OUTDATA[I];
   INS[I]←OUTS[I]
END  

END "SORT";
INTEGER PROCEDURE LOOKUP(STRING A);
BEGIN "LOOKUP"
 INTEGER H,Q,R;
 DEFINE SCON="10";

 H←CVASC(A) +LENGTH(A) LSH 6;
 R←SYMBOL←(H←ABS(H⊗(H LSH 2))) MOD (SYMNO+1);

 IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
 IF EQU(SYM[SYMBOL],NULL) THEN  RETURN(0); 

 Q←H%(SYMNO+1) MOD (SYMNO+1);
 IF (H←Q+SCON)≥SYMNO THEN H←H-SYMNO;

 WHILE (IF (SYMBOL←SYMBOL+H)>SYMNO
     THEN SYMBOL←SYMBOL-(SYMNO+1) ELSE SYMBOL)	≠R   DO
     BEGIN "LK1" 
	IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
	IF EQU(SYM[SYMBOL],NULL) THEN RETURN(0);
	IF (H←H+Q)>SYMNO THEN H←H-(SYMNO+1);
     END "LK1";
USERERR(0,0,"TABLE FULL");
END "LOOKUP";
DEFINE PGMRK= "'201004020101",WUN="'1000000",EXECBIT="'400000000000",
	CHKPAG= "IF CURLIN=PGMRK THEN CURPAGE← CURPAGE+WUN",
	CHKLIN= "IF SRCBRK<0 THEN ⊂ EXECHK← 0; CURLIN← -SRCBRK;
	CHKPAG; GO TO L1 ⊃";
L_PTR← 0;
CURPAGE← WUN;
WANTBIN← 1;
LETS← "ABCDEFGHIJKLMNOPQRSTUVWXYZ_" &
	"abcdefghijklmnopqrstuvwxyz";
DIGS← "0123456789";
SETBREAK(SLOUGH,LETS&"@",NULL,"IRE");
SETBREAK(IDSCAN,LETS&DIGS&"@",NULL,"XSN");
SETBREAK(CMNT,";",NULL,"ISE");
SETBREAK(EXSCAN,LETS&DIGS&"@¬#↑",NULL,"IRE");
COMMAND_SCAN;

! SPECIAL SCAN IF LOOKING FOR EXECS;
L1:	IF EXECHK=0 THEN GO TO L3;
L2:	FOO← INPUT(SRC,EXSCAN); CHKEOF;
	CHKLIN;
	IF SRCBRK= "@" THEN ⊂ FOO← INPUT(SRC,IDSCAN); GO TO L2 ⊃;
	IF (SRCBRK= "¬")∨(SRCBRK="#")∨(SRCBRK="↑") 
		THEN ⊂ EXECHK← 0; GO TO L3 ⊃;
! SKIP TO NEXT ID;
L3:	FOO← INPUT(SRC,SLOUGH);CHKEOF;
	CHKLIN;

! PICK UP ID;
	NEWNAM← INPUT(SRC,IDSCAN);CHKEOF;

! CHECK FOR RESERVED WORD;
	IF EQU(NEWNAM,"EXEC") THEN ⊂ EXECHK← EXECBIT; GO TO L1 ⊃;
	IF EQU(NEWNAM,"SCAN") THEN ⊂ EXECHK← 0; GO TO L1 ⊃;
	IF EQU(NEWNAM,"SG")
	∨(LENGTH(NEWNAM)=3 ∧ EQU(NEWNAM[1 FOR 2],"SG") ∧
	"0"≤ NEWNAM[3 FOR 1] ≤ "9")
		 THEN GO TO L1;
 	IF EQU(NEWNAM,"MUMBLE") THEN  ⊂ LABEL LL; LL: FOO←INPUT(SRC,CMNT);
	CHKEOF; IF SRCBRK<0 THEN ⊂ CURLIN← -SRCBRK; EXECHK← 0; CHKPAG;GO TO LL ⊃ ELSE
	GO TO L1 ⊃ ;

! LOOK UP ID;
	WASTHERE← LOOKUP(NEWNAM);
	IF WASTHERE=0 THEN ⊂ SYM[SYMBOL]← NEWNAM; LTAB[SYMBOL]←0 ⊃;

! PUT IN LIST OF OCCURANCES;
	IF LTAB[SYMBOL]=0 THEN ⊂ NN← NODE(0,CURLIN);
		LTAB[SYMBOL]← NN LOR (NN LSH 18) LOR (IF 
		SRCBRK=":" THEN LBLBIT ELSE 0) LOR EXECHK;
		GO TO L1 ⊃ ;

! SEE IF THIS IS THE DEFINING INSTANCE OF A LABEL;
	IF SRCBRK=":" THEN
	 ⊂ ! PUT AT HEAD OF THE LIST;
	NN← NODE(L_HALF("LTAB[SYMBOL]"),CURLIN);
	LTAB[SYMBOL]← R_HALF("LTAB[SYMBOL]") LOR (NN LSH 18) LOR LBLBIT ;
	GO TO L1 ⊃ ;

! PUT AT THE END OF THE LIST;
	KK← R_HALF("LTAB[SYMBOL]");
! SEE IF IT IS ALREADY THERE;
	IF (L_SPACE[KK+1]=CURLIN) ∧ ((L_SPACE[KK] LAND '377777000000)=
		CURPAGE) THEN GO TO L1;
	NN← NODE(0,CURLIN);
	L_SPACE[KK]← L_SPACE[KK] LOR NN;
	LTAB[SYMBOL]← (LTAB[SYMBOL] LAND '777777400000) LOR NN LOR EXECHK;
	GO TO L1;

PASS2:
! NOW SORT THE SYMBOL TABLE;
	SORT(SYM,LTAB,4096);

! PRODUCE THE LISTING;

	FOR III←0,1,2 DO ⊂
	OUT(OTPT,FORM);
	K←0;
	WHILE ¬EQU(SYM[K],NULL) DO
	⊂ LABEL NOTNOW;
	CASE III OF
		⊂ IF LTAB[K] LAND BITS2 THEN GO TO NOTNOW;
		IF (LTAB[K] LAND LBLBIT)=0 THEN GO TO NOTNOW;
		IF (LTAB[K] LAND EXECBIT)=0 THEN GO TO NOTNOW ⊃;
	OUT(OTPT,CRLF&SYM[K]&(IF LENGTH(SYM[K])<8 
		THEN TAB ELSE NULL));
	L← L_HALF("LTAB[K]");
	NP←1;
	NN←0;
	WHILE L≠0 DO
		⊂ IF NN>10 THEN ⊂ OUT(OTPT,CRLF&TAB&TAB); NN←0 ⊃;
		KP← L_HALF("L_SPACE[L]");
		IF KP≠NP THEN ⊂ OUT(OTPT,TAB&"/"&CVS(KP));
		NP← KP; NN← NN+1 ⊃;
		 IF NN>10 THEN ⊂ OUT(OTPT,CRLF&TAB&TAB); NN←0 ⊃;
		OUT(OTPT,TAB&CVSTR(L_SPACE[L+1]));
		L← R_HALF("L_SPACE[L]"); NN← NN+1 ⊃;
NOTNOW: 	K← K+1 ⊃ ⊃;
RELEASE(OTPT);

END

END "XREF";