|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 12928 (0x3280)
Types: TextFile
Names: »XREF.SRC«
└─⟦c9df7130d⟧ Bits:30005915 Pascal MT+ Release 5.2 (Jet-80)
└─ ⟦this⟧ »XREF.SRC«
(*====================================================================*)
(* PROGRAM TITLE: PASCAL CROSS-REFERENCING PROGRAM *)
(* *)
(* PROGRAM FILE: XREF.SRC *)
(* *)
(* LAST UPDATE: 09-MAR-81 by Mike Lehman *)
(* *)
(* NOTE: THIS PROGRAM WAS ORIGINALLY WRITTEN BY N. WIRTH AND *)
(* ADAPTED FOR UCSD PASCAL (I.4 - THE PUBLIC DOMAIN VERSION) *)
(* BY SHAWN FANNING (IN 1978) AND SUBSEQUENTLY ADAPTED FOR *)
(* PASCAL/MT+ BY MIKE LEHMAN (IN 1981) AND IS A PUBLIC DOMAIN *)
(* PROGRAM. IF YOU MAKE REVISIONS, ETC. PLEASE LEAVE THE AUTHOR *)
(* AND MODIFIERS NAME IN THE SOURCE FILE. THANK YOU. *)
(* *)
(* PROGRAM SUMMARY: *)
(* LD A,(IX) ;GET AMOUNT(=POS DATA:)
CP '$' ;END?
JP Z,RPEND
LD B,A ;SAVE AMOUNT
RPT0: INC HL ;CALC LAST POS.
DEC A ;MOVE=R ANY *)
(* PASCAL PROGRAM. OCCURENCES ONLY ARE LISTED. NO DISTINCTION IS *)
(* MADE BETWEEN DEFINITIONS AND REFERENCES. *)
(*====================================================================*)
PROGRAM XREF;
(*CROSS REFERENCE GENERATOR FOR PASCAL PROGRAMS. N.WIRTH, 7.5.74*)
(*'QUADRATIC QUOTIENT' HASH METHOD*)
CONST
P = 749; (*SIZE OF HASHTABLE*)
NK = 45; (*NO. OF KEYWORDS*)
ALFALEN = 8;
REFSPERLINE = 15;
REFSPERITEM = 5;
TYPE
ALFA = PACKED ARRAYÆ1..ALFALENÅ OF CHAR;
INDEX = 0..P;
ITEMPTR = ^ITEM;
WORD = RECORD
KEY: ALFA;
FIRST, LAST: ITEMPTR;
FOL: INDEX
END ;
NUMREFS = 1..REFSPERITEM;
REFTYPE = (COUNT, PTR);
ITEM = RECORD
REF : ARRAYÆNUMREFSÅ OF INTEGER;
CASE REFTYPE OF
COUNT: (REFNUM: NUMREFS);
PTR: (NEXT: ITEMPTR)
END ;
BUFFER = PACKED ARRAYÆ0..131Å OF CHAR;
VAR
TOP: INDEX; (*TOP OF CHAIN LINKING ALL ENTRIES IN T*)
I,LINECOUNT,BUFCURSOR: INTEGER; (*CURRENT LINE NUMBER*)
FF,CH: CHAR; (*CURRENT CHAR SCANNED *)
BUF,BUF1,BUF2: ^BUFFER;
T: ARRAY ÆINDEXÅ OF WORD; (*HASH TABLE*)
KEY: ARRAY Æ1..NKÅ OF ALFA; (* RESERVED KEYWORD TABLE *)
ERROR, (* ERROR FLAG *)
LISTING: BOOLEAN; (* LISTING OPTION *)
INFILE: TEXT;
LST : TEXT;
LSTFILENAME : STRING;
INPUT_LINE : STRING;
PROCEDURE INITIALIZE;
VAR
I : INTEGER;
PROCEDURE FIRSTHALF;
BEGIN
KEYÆ 1Å := 'AND ';
KEYÆ 2Å := 'ARRAY ';
KEYÆ 3Å := 'BEGIN ';
KEYÆ 4Å := 'BOOLEAN ';
KEYÆ 5Å := 'CASE ';
KEYÆ 6Å := 'CHAR ';
KEYÆ 7Å := 'CONST ';
KEYÆ 8Å := 'DIV ';
KEYÆ 9Å := 'DOWNTO ';
KEYÆ10Å := 'DO ';
KEYÆ11Å := 'ELSE ';
KEYÆ12Å := 'END ';
KEYÆ13Å := 'EXIT ';
KEYÆ14Å := 'FILE ';
KEYÆ15Å := 'FOR ';
KEYÆ16Å := 'FUNCTION';
END;
PROCEDURE SECONDHALF;
BEGIN
KEYÆ17Å := 'GOTO ';
KEYÆ18Å := 'IF ';
KEYÆ19Å := 'IN ';
KEYÆ20Å := 'INPUT ';
KEYÆ21Å := 'INTEGER ';
KEYÆ22Å := 'MOD ';
KEYÆ23Å := 'NIL ';
KEYÆ24Å := 'NOT ';
KEYÆ25Å := 'OF ';
KEYÆ26Å := 'OR ';
KEYÆ27Å := 'OUTPUT ';
KEYÆ28Å := 'PACKED ';
KEYÆ29Å := 'PROCEDUR';
KEYÆ30Å := 'PROGRAM ';
KEYÆ31Å := 'REAL ';
KEYÆ32Å := 'RECORD ';
KEYÆ33Å := 'REPEAT ';
KEYÆ34Å := 'SET ';
KEYÆ35Å := 'STRING ';
KEYÆ36Å := 'TEXT ';
KEYÆ37Å := 'THEN ';
KEYÆ38Å := 'TO ';
KEYÆ39Å := 'TYPE ';
KEYÆ40Å := 'UNTIL ';
KEYÆ41Å := 'VAR ';
KEYÆ42Å := 'WHILE ';
KEYÆ43Å := 'WITH ';
KEYÆ44Å := 'WRITE ';
KEYÆ45Å := 'WRITELN ';
END;
BEGIN (* INITIALIZE *)
WRITELN;
WRITELN('Pascal/MT+ Program Xref Utility -- Release 5.2');
WRITELN('This program is public domain');
WRITELN;
FF:=CHR(12);
NEW(BUF1);
NEW(BUF2);
BUF:=BUF1;
ERROR := FALSE;
FOR I := 0 TO P DO
TÆIÅ.KEY := ' ';
FIRSTHALF;
SECONDHALF;
LINECOUNT:= 0;
BUFCURSOR:= 0;
TOP := P;
CH := ' '
END; (* INITIALIZE *)
PROCEDURE OPENFILES;
VAR
NUMBLOCKS: INTEGER;
OPENOK: BOOLEAN;
OPENERRNUM : INTEGER;
LISTOPTION: CHAR;
FILENAME: STRING;
BEGIN (* OPEN *)
REPEAT
WRITELN;
WRITE( 'Input file ? ' );
READLN( FILENAME );
IF LENGTH(FILENAME) >0 THEN
BEGIN
ASSIGN(INFILE, FILENAME );
RESET(INFILE)
END;
OPENERRNUM := IORESULT;
OPENOK := ( OPENERRNUM <> 255 );
IF NOT OPENOK THEN
WRITELN( '*** INPUT OPEN ERROR #', OPENERRNUM );
UNTIL OPENOK;
WRITE('Output file name? ');
READLN(LSTFILENAME);
ASSIGN(LST,LSTFILENAME);
REWRITE(LST);
WRITE( 'Do you want a listing ? ' );
READ( LISTOPTION );
LISTING := NOT(LISTOPTION = 'N');
IF LISTING THEN PUTNUMBER(0);
READLN(INFILE,INPUT_LINE);
WRITELN;
END; (* OPEN *)
PROCEDURE LPWRITELN;
VAR
I : INTEGER;
BEGIN
BUF^ÆBUFCURSORÅ:=CHR(13);
BUFCURSOR:=BUFCURSOR+1;
FOR I := 0 TO BUFCURSOR-1 DO
WRITE(LST,BUF^ÆIÅ);
IF BUF = BUF1 THEN BUF:=BUF2 ELSE BUF:=BUF1;
BUFCURSOR:=0;
LINECOUNT:=LINECOUNT+1;
IF (LINECOUNT MOD 60) = 0 THEN
PAGE(LST);
END;
PROCEDURE PUTALFA(S:ALFA);
BEGIN
MOVELEFT(SÆ1Å,BUF^ÆBUFCURSORÅ,8);
BUFCURSOR:=BUFCURSOR+8;
END;
PROCEDURE PUTNUMBER(NUM: INTEGER);
VAR I,IPOT:INTEGER;
A: ALFA;
CH: CHAR;
ZAP:BOOLEAN;
BEGIN
ZAP:=TRUE;
IPOT:=10000;
AÆ1Å:=' ';
FOR I:= 2 TO 6 DO
BEGIN
CH:=CHR(NUM DIV IPOT + ORD('0'));
IF I <> 6 THEN
IF ZAP THEN
IF CH = '0' THEN
CH:=' '
ELSE ZAP:=FALSE;
AÆIÅ:=CH;
NUM:=NUM MOD IPOT;
IPOT:=IPOT DIV 10;
END;
AÆ7Å:=' ';
MOVELEFT(A,BUF^ÆBUFCURSORÅ,7);
BUFCURSOR:=BUFCURSOR+7;
END;
PROCEDURE GETNEXTCHAR;
VAR I : INTEGER;
BEGIN
IF LENGTH(INPUT_LINE) = 0 THEN
READLN(INFILE,INPUT_LINE);
IF LENGTH(INPUT_LINE) = 0 THEN
CH := ' '
ELSE
BEGIN
CH:=INPUT_LINEÆ1Å;
DELETE(INPUT_LINE,1,1)
END;
IF EOF(INFILE) THEN ERROR:=TRUE
ELSE
BEGIN
BUF^ÆBUFCURSORÅ:=CH;
BUFCURSOR:=BUFCURSOR+1;
IF LENGTH(INPUT_LINE) = 0 THEN
BEGIN
BUF^ÆBUFCURSORÅ:=CHR(13);
BUFCURSOR:=BUFCURSOR+1;
LINECOUNT:= LINECOUNT +1;
IF LISTING THEN
BEGIN
IF LSTFILENAME <> 'CON:' THEN
WRITE('.');
FOR I := 0 TO BUFCURSOR-1 DO
WRITE(LST,BUF^ÆIÅ);
IF BUF = BUF2 THEN BUF:=BUF1 ELSE BUF:=BUF2;
BUFCURSOR:=0;
PUTNUMBER(LINECOUNT);
END
ELSE
BEGIN
BUFCURSOR:=0;
WRITE('.')
END;
IF (LINECOUNT MOD 60) = 0 THEN
BEGIN
IF LISTING THEN PAGE(LST);
WRITELN(OUTPUT,'< ',LINECOUNT:4,',',MEMAVAIL:5,' >');
END;
END;
END;
END; (* GETNEXTCHAR *)
PROCEDURE SEARCH( ID: ALFA ); (*MODULO P HASH SEARCH*)
(*GLOBAL: T, TOP*)
VAR
I,J,H,D : INTEGER;
X : ITEMPTR;
F : BOOLEAN;
BEGIN
J:=0;
FOR I:= 1 TO ALFALEN DO
J:= J*10+ORD(IDÆIÅ);
H := ABS(J) MOD P;
F := FALSE;
D := 1;
REPEAT
IF TÆHÅ.KEY = ID
THEN
BEGIN (*FOUND*)
F := TRUE;
IF TÆHÅ.LAST^.REFNUM = REFSPERITEM
THEN
BEGIN
NEW(X);
X^.REFNUM := 1;
X^.REFÆ1Å := LINECOUNT;
TÆHÅ.LAST^.NEXT:= X;
TÆHÅ.LAST := X;
END
ELSE
WITH TÆHÅ.LAST^ DO
BEGIN
REFNUM := REFNUM + 1;
REFÆREFNUMÅ := LINECOUNT
END
END
ELSE
IF TÆHÅ.KEY = ' '
THEN
BEGIN (*NEW ENTRY*)
F := TRUE;
NEW(X);
X^.REFNUM := 1;
X^.REFÆ1Å := LINECOUNT;
TÆHÅ.KEY := ID;
TÆHÅ.FIRST := X;
TÆHÅ.LAST := X;
TÆHÅ.FOL := TOP;
TOP := H
END
ELSE
BEGIN (*COLLISION*)
H := H+D;
D := D+2;
IF H >= P
THEN
H := H - P;
IF D = P
THEN
BEGIN
WRITELN(OUTPUT,'TBLE OVFLW');
ERROR := TRUE
END ;
END
UNTIL F OR ERROR
END (*SEARCH*) ;
PROCEDURE PRINTWORD(W: WORD);
VAR
L: INTEGER;
X: ITEMPTR;
NEXTREF : INTEGER;
THISREF: NUMREFS;
BEGIN
PUTALFA(W.KEY);
X := W.FIRST;
L := 0;
REPEAT
IF L = REFSPERLINE
THEN
BEGIN
L := 0;
LPWRITELN;
PUTALFA(' ');
END ;
L := L+1;
THISREF := (L-1) MOD REFSPERITEM + 1;
NEXTREF := X^.REFÆ THISREF Å;
IF THISREF = X^.REFNUM
THEN
X := NIL
ELSE
IF THISREF = REFSPERITEM
THEN
X := X^.NEXT;
PUTNUMBER(NEXTREF);
UNTIL X = NIL;
LPWRITELN;
END (*PRINTWORD*) ;
PROCEDURE PRINTTABLE;
VAR
I,J,M: INDEX;
BEGIN
I := TOP;
WHILE I <> P DO
BEGIN (*FIND MINIMAL WORD*)
M := I;
J := TÆIÅ.FOL;
WHILE J <> P DO
BEGIN
IF TÆJÅ.KEY < TÆMÅ.KEY
THEN
M := J;
J := TÆJÅ.FOL
END ;
PRINTWORD(TÆMÅ);
IF M <> I THEN
BEGIN
TÆMÅ.KEY:=TÆIÅ.KEY;
TÆMÅ.FIRST:=TÆIÅ.FIRST;
TÆMÅ.LAST:=TÆIÅ.LAST;
END;
I := TÆIÅ.FOL
END
END (*PRINTTABLE*) ;
PROCEDURE GETIDENTIFIER;
VAR
J,K,I: INTEGER;
ID: ALFA;
BEGIN (* GETIDENTIFIER *)
I := 0;
ID := ' ';
REPEAT
IF I < ALFALEN
THEN
BEGIN
I := I+1;
IF ('a' <= CH) AND (CH <= 'z')
THEN
IDÆIÅ := CHR( ORD(CH) - ORD('a') + ORD('A') )
ELSE
IDÆIÅ := CH
END;
GETNEXTCHAR
UNTIL ( NOT(((CH>='A') AND (CH<='Z')) OR ((CH>='a') AND (CH<='z'))
OR ((CH>='0') AND (CH<='9')))) OR (ERROR);
I := 1;
J := NK;
REPEAT
K := (I+J) DIV 2; (*BINARY SEARCH*)
IF KEYÆKÅ <= ID
THEN
I := K+1;
IF KEYÆKÅ >= ID
THEN
J := K-1;
UNTIL I > J;
IF KEYÆKÅ <> ID THEN SEARCH(ID);
END; (* GETIDENTIFIER *)
BEGIN (* CROSSREF *)
INITIALIZE;
OPENFILES;
WHILE (NOT(EOF(INFILE))) AND (NOT( ERROR)) DO
BEGIN
IF ((CH>='A') AND (CH<='Z')) THEN
GETIDENTIFIER
ELSE
IF (CH = '''') THEN
BEGIN
REPEAT
GETNEXTCHAR;
UNTIL (CH = '''') OR (ERROR);
GETNEXTCHAR;
END
ELSE
IF CH = '(' THEN
BEGIN
GETNEXTCHAR;
IF CH = '*' THEN
BEGIN
GETNEXTCHAR;
WHILE (CH <> ')') AND (NOT(ERROR)) DO
BEGIN
WHILE (CH <> '*') AND (NOT(ERROR)) DO
GETNEXTCHAR;
GETNEXTCHAR;
END;
GETNEXTCHAR;
END;
END
ELSE
GETNEXTCHAR;
END; (* WHILE *)
PAGE(LST);
LINECOUNT := 0;
BUFCURSOR := 0;
PRINTTABLE;
PAGE(LST);
CLOSE(LST,I);
IF I = 255 THEN
WRITELN('Error closing output file')
END.
«eof»