DataMuseum.dk

top - download

    Length: 10880 (0x2a80)
    Types: TextFile
    Names: »CROSSREF.PAS«

└─⟦8e533ec5a⟧ Bits:30004189 COMPAS Pascal v3.02 til CR7
    └─ ⟦this⟧ »CROSSREF.PAS« 

TextFile

PROGRAM CROSSREF; (*$R-*)

(* This program will generate a cross reference map of any	*)
(* COMPAS Pascal program, i.e. a map that lists all identifiers	*)
(* used within the program as well as the line numbers of all	*)
(* lines that contain references to the identifiers. Optional-	*)
(* ly, a source listing with line numbers may be output.	*)

(* On processing the input file, all identifiers are extracted	*)
(* and compared with the reserved words of COMPAS Pascal. If an	*)
(* identifier is not a reserved word, it is entered into a	*)
(* binary tree. Each entry in the binary tree contains a poin-	*)
(* ter to the identifier, and a left node and a right node	*)
(* pointer to subsequent entries (or NIL if no entries follow).	*)
(* Furthermore, an entry contains a pointer to the first re-	*)
(* cord in a line number reference chain, and a pointer to the	*)
(* last record in that chain. When an identifier is entered	*)
(* into the tree for the first time, the program allocates both	*)
(* a new identifier record and a line number reference record.	*)
(* Subsequent references to that identifier will then expand	*)
(* the line number reference chain, provided that the line num-	*)
(* ber is not the same as that of the last reference.		*)

(* When all lines have been processed, the program traverses	*)
(* the binary tree, printing all identifiers along with the	*)
(* numbers of the lines within which they are referenced.	*)

CONST

(* Various constants.						*)

  MAXDOTS = 50;		(* Max number of dots per line on CRT *)
  NOFRWORDS = 44;	(* Number of reserved words *)
  FORMFEED = ^L;	(* Form-feed character *)

(* Table of reserved words.					*)

  RWORDS: ARRAYÆ1..NOFRWORDSÅ OF STRINGÆ9Å = (
    'AND','ARRAY','AT','BEGIN','CASE','CODE','CONST','DIV','DO',
    'DOWNTO','ELSE','END','EXOR','EXTERNAL','FILE','FOR','FORWARD',
    'FUNCTION','GOTO','IF','IN','LABEL','MOD','NIL','NOT','OF',
    'OR','OTHERWISE','PACKED','PROCEDURE','PROGRAM','RECORD',
    'REPEAT','SET','SHL','SHR','STRING','THEN','TO','TYPE','UNTIL',
    'VAR','WHILE','WITH');

TYPE

(* Identifier types. The maximum length is 64 characters.	*)

  IDENTPTR = ^IDENT;
  IDENT = STRINGÆ64Å;

(* Line record types. Each line record contains the number of a	*)
(* line, within which a given identifier is referenced, and a	*)
(* pointer to the next line record.				*)

  LINERECPTR = ^LINEREC;
  LINEREC = RECORD
	      NUMBER: INTEGER;
	      NEXT: LINERECPTR;
	    END;

(* Identifier record types. Each identifier record contains a	*)
(* pointer to the identifier string, a pointer to the first and	*)
(* the last line record in the reference chain, and a left node	*)
(* and a right node pointer to subsequent entries in the binary	*)
(* tree.							*)

  IDENTRECPTR = ^IDENTREC;
  IDENTREC = RECORD
	       ID: IDENTPTR;
	       FIRSTLINE,LASTLINE: LINERECPTR;
	       LEFT,RIGHT: IDENTRECPTR;
	     END;

(* Source line type. The maximum length of a source line is 127	*)
(* characters.							*)

  SOURCELINE = STRINGÆ127Å;

(* Reserved word table pointers type. Each element points to	*)
(* the first reserved word, that starts with the character gi-	*)
(* ven by the index.						*)

  RWORDTP = ARRAYÆ'A'..'Z'Å OF INTEGER;

VAR

(* Global variables.						*)

  LINENUMBER,		(* Current line number *)
  NOFIDENTS,		(* Number of identifiers processed *)
  POS,			(* Position within current line *)
  LINELEN: INTEGER;	(* Length of current line *)
  CH: CHAR;		(* Current character *)
  LISTING,		(* True if source listing requested *)
  ERROR: BOOLEAN;	(* Error flag *)
  LINE: SOURCELINE;	(* Current source line *)
  IDTREE: IDENTRECPTR;	(* Root of cross reference tree *)
  FIRSTRWORD: RWORDTP;	(* Pointers to reserved word table *)
  INFILE,		(* Input file *)
  OUTFILE: TEXT;	(* Output file *)

(*$A+*)

(* FREEMEM returns the number of bytes available on the heap.	*)
(* The result type is real to allow for values outside the in-	*)
(* teger range.							*)

FUNCTION FREEMEM: REAL;
BEGIN
  IF MEMAVAIL>0 THEN
  FREEMEM:=MEMAVAIL ELSE
  FREEMEM:=65536.0-MEMAVAIL;
END;

(* NEXTCH reads the next character from the input file into CH.	*)
(* If a source listing was requested, NEXTCH lists input lines	*)
(* to the output file as they are read. Otherwise, a dot is	*)
(* printed on the console for each line read. A ^Z character is	*)
(* returned on reaching the end of the input file.		*)

PROCEDURE NEXTCH;
VAR
  P,T: INTEGER;
BEGIN
  IF (POS<=LINELEN) THEN
  BEGIN
    CH:=LINEÆPOSÅ; POS:=POS+1;
    IF (CH>='a') AND (CH<='z') THEN CH:=CHR(ORD(CH)-32);
  END ELSE
  IF NOT EOF(INFILE) THEN
  BEGIN
    READLN(INFILE,LINE); LINENUMBER:=LINENUMBER+1;
    IF LISTING THEN
    BEGIN
      WRITE(OUTFILE,'<',LINENUMBER:5,'> ');
      T:=8;
      FOR P:=1 TO LEN(LINE) DO
      IF LINEÆPÅ<>^I THEN
      BEGIN
	WRITE(OUTFILE,LINEÆPÅ); T:=T-1; IF T=0 THEN T:=8;
      END ELSE
      BEGIN
	WRITE(OUTFILE,'':T); T:=8;
      END;
      WRITELN(OUTFILE);
    END ELSE
    BEGIN
      WRITE('.');
      IF LINENUMBER MOD MAXDOTS=0 THEN WRITELN;
    END;
    LINELEN:=LEN(LINE); POS:=1; CH:=' ';
  END ELSE
  CH:=^Z;
END;

(* INITIALIZE is used to initialize input and output files and	*)
(* all global variables.					*)

PROCEDURE INITIALIZE;
LABEL EXIT;
VAR
  I: INTEGER;
  MATCH: BOOLEAN;
  INNAME,OUTNAME: STRINGÆ14Å;
  LISTYN: STRINGÆ1Å;
BEGIN
  ERROR:=FALSE;
  WRITELN;
  WRITELN('    COMPAS PASCAL CROSS REFERENCE GENERATOR');
  WRITELN;
  WRITELN('                  Version 1.1');
  WRITELN;
  WRITELN('             Copyright (C) 1983 by');
  WRITELN('           Poly-Data microcenter ApS');
  WRITELN;
  WRITELN;
  WRITE('Input file name? '); READLN(INNAME);
  WRITE('Output file name (default printer)? '); READLN(OUTNAME);
  WRITE('Print source listing (Y/N)? '); READLN(LISTYN);
  WRITELN;
  ASSIGN(INFILE,INNAME); (*$I-*) RESET(INFILE) (*$I+*);
  IF IORES>0 THEN
  BEGIN
    WRITELN('INPUT FILE ERROR');
    ERROR:=TRUE; GOTO EXIT;
  END;
  IF OUTNAME='' THEN OUTNAME:='LST:';
  ASSIGN(OUTFILE,OUTNAME); (*$I-*) REWRITE(OUTFILE) (*$I+*);
  IF IORES>0 THEN
  BEGIN
    WRITELN('OUTPUT FILE ERROR');
    ERROR:=TRUE; GOTO EXIT;
  END;
  LISTING:=(LISTYN='Y') OR (LISTYN='y');
  IDTREE:=NIL;
  I:=1;
  FOR CH:='A' TO 'Z' DO
  BEGIN
    FIRSTRWORDÆCHÅ:=I; MATCH:=TRUE;
    WHILE (I<=NOFRWORDS) AND MATCH DO
    BEGIN
      MATCH:=RWORDSÆIÅÆ1Å=CH; IF MATCH THEN I:=I+1;
    END;
  END;
  LINENUMBER:=0; NOFIDENTS:=0;
  POS:=1; LINELEN:=0; NEXTCH;
  EXIT:
END;

(* PROCESSFILE processes the input file, creating a cross refe-	*)
(* rence binary tree.						*)

PROCEDURE PROCESSFILE;
VAR
  IFREE: REAL;

(* GETSYMBOL reads the next symbol from the input file. If the	*)
(* symbol is an identifier, it is processed using PROCESSIDENT	*)
(* below.							*)

PROCEDURE GETSYMBOL;
CONST
  ALPHANUMS: SET OF '0'..'Z' = Æ'0'..'9','A'..'Z'Å;
  HEXDIGITS: SET OF '0'..'F' = Æ'0'..'9','A'..'F'Å;

(* PROCESSIDENT reads an identifier and enters it into the	*)
(* cross reference binary tree, provided that it is not a re-	*)
(* served word.							*)

PROCEDURE PROCESSIDENT;
VAR
  I,MAX: INTEGER;
  NOTFOUND: BOOLEAN;
  NEWID: IDENT;
  X: LINERECPTR;

(*$A-*)

(* ENTERID enters NEWID into the cross reference binary tree.	*)
(* Note that an identifier record is allocated only if the	*)
(* identifier is not already within the tree. Also note the use	*)
(* of the ALLOCATE procedure to allocate only the required num-	*)
(* ber of bytes for the identifier instead of the full maximum	*)
(* length.							*)

PROCEDURE ENTERID(VAR ROOT: IDENTRECPTR);
BEGIN
  IF ROOT=NIL THEN
  BEGIN
    NOFIDENTS:=NOFIDENTS+1;
    NEW(ROOT);
    WITH ROOT^ DO
    BEGIN
      ALLOCATE(ID,LEN(NEWID)+1); ID^:=NEWID;
      NEW(FIRSTLINE);
      FIRSTLINE^.NUMBER:=LINENUMBER; FIRSTLINE^.NEXT:=NIL;
      LASTLINE:=FIRSTLINE;
      LEFT:=NIL; RIGHT:=NIL;
    END;
  END ELSE
  IF NEWID<ROOT^.ID^ THEN ENTERID(ROOT^.LEFT) ELSE
  IF NEWID>ROOT^.ID^ THEN ENTERID(ROOT^.RIGHT) ELSE
  WITH ROOT^ DO
  BEGIN
    IF LINENUMBER<>LASTLINE^.NUMBER THEN
    BEGIN
      NEW(X); X^.NUMBER:=LINENUMBER; X^.NEXT:=NIL;
      LASTLINE^.NEXT:=X;
      LASTLINE:=X;
    END;
  END;
END;

BEGIN (*PROCESSIDENT*)
  IF CH='_' THEN
  BEGIN
    I:=NOFRWORDS; MAX:=NOFRWORDS;
  END ELSE
  BEGIN
    I:=FIRSTRWORDÆCHÅ;
    IF CH<'Z' THEN MAX:=FIRSTRWORDÆSUCC(CH)Å ELSE MAX:=NOFRWORDS;
  END;
  NEWID:='';
  REPEAT
    NEWID:=NEWID+CH; NEXTCH;
  UNTIL NOT(CH IN ALPHANUMS);
  NOTFOUND:=TRUE;
  WHILE (I<MAX) AND NOTFOUND DO
  BEGIN
    NOTFOUND:=NEWID<>RWORDSÆIÅ; I:=I+1;
  END;
  IF NOTFOUND THEN ENTERID(IDTREE);
END;

BEGIN (*GETSYMBOL*)
  CASE CH OF
    'A'..'Z','_':
      PROCESSIDENT;
    '''':
      REPEAT
	REPEAT NEXTCH UNTIL (CH='''') OR (CH=^Z);
	NEXTCH;
      UNTIL CH<>'''';
    '$':
      REPEAT NEXTCH UNTIL NOT(CH IN HEXDIGITS);
    'æ':
      BEGIN
	REPEAT NEXTCH UNTIL (CH='å') OR (CH=^Z);
	NEXTCH;
      END;
    '(':
      BEGIN
	NEXTCH;
	IF CH='*' THEN
	BEGIN
	  REPEAT
	    REPEAT NEXTCH UNTIL (CH='*') OR (CH=^Z);
	    NEXTCH;
	  UNTIL (CH=')') OR (CH=^Z);
	  NEXTCH;
	END;
      END;
  OTHERWISE
    NEXTCH;
  END;
END;

BEGIN (*PROCESSFILE*)
  IFREE:=FREEMEM;
  WHILE (CH<>^Z) AND (FREEMEM>100.0) DO GETSYMBOL;
  IF NOT LISTING THEN
  BEGIN
    IF (LINENUMBER MOD MAXDOTS<>0) THEN WRITELN;
    WRITELN;
  END;
  IF (FREEMEM<=100.0) THEN
  BEGIN
    WRITELN('SYMBOL TABLE OVERFLOW');
    ERROR:=TRUE;
  END ELSE
  BEGIN
    WRITELN(LINENUMBER,' lines read from input file.');
    WRITELN(NOFIDENTS,' identifiers processed.');
    WRITELN(IFREE-FREEMEM:0:0,' bytes used, ',FREEMEM:0:0,' free.');
    IF LISTING THEN WRITE(OUTFILE,FORMFEED);
  END;
END;

(*$A+*)

(* PRINTXREF outputs the cross reference map.			*)

PROCEDURE PRINTXREF;
VAR
  N: INTEGER;
  X: LINERECPTR;

(*$A-*)

(* TRAVERSE traverses the binary tree from "left" to "right",	*)
(* printing all identifiers and the numbers of the lines within	*)
(* which they are referenced.					*)

PROCEDURE TRAVERSE(ROOT: IDENTRECPTR);
BEGIN
  IF ROOT<>NIL THEN
  BEGIN
    TRAVERSE(ROOT^.LEFT);
    WITH ROOT^ DO
    BEGIN
      WRITE(OUTFILE,ID^);
      X:=FIRSTLINE; N:=1;
      REPEAT
	IF N MOD 8=1 THEN WRITELN(OUTFILE);
	WRITE(OUTFILE,X^.NUMBER:8); X:=X^.NEXT; N:=N+1;
      UNTIL X=NIL;
      WRITELN(OUTFILE);
    END;
    TRAVERSE(ROOT^.RIGHT);
  END;
END;

BEGIN (*PRINTXREF*)
  TRAVERSE(IDTREE); WRITE(OUTFILE,FORMFEED);
END;

(* Main program.						*)

BEGIN
  INITIALIZE;
  IF NOT ERROR THEN PROCESSFILE;
  IF NOT ERROR THEN PRINTXREF;
END.
«eof»