_STRUCTURED PROGRAMMING COLUMN_
by Kent Porter

[LISTING 1]

   1| Program number;
   2| 
   3|   { Puts line numbers at start of each line, stores in file by same
   4|     name except extension is .NUM }
   5| 
   6| USES crt;
   7| 
   8| VAR   Filename, Newname : STRING [80];
   9|       I, O              : TEXT;
  10|       Line              : STRING [135];
  11|       Nbr, len, p       : WORD;
  12|       Num               : STRING [4];
  13| 
  14| BEGIN
  15|   Nbr := 0;
  16|   Newname := '';
  17|   IF ParamCount < 1 THEN BEGIN
  18|     Writeln ('USAGE: NUMBER <Filename.ext>');
  19|     EXIT;
  20|   END;
  21|   Filename := ParamStr (1);
  22| 
  23|   Len := pos ('.', Filename);
  24|   IF len = 0 THEN
  25|     Newname := Filename + '.NUM'
  26|   ELSE BEGIN
  27|     FOR p := 1 TO len DO
  28|       Newname := Newname + Filename [p];
  29|     Newname := Newname + 'NUM';
  30|   END;
  31|   Assign (I, Filename);
  32|   {$I-}
  33|   Reset (I);
  34|   {$I+}
  35|   IF IOResult <> 0 THEN BEGIN
  36|     Writeln ('Unable to open ', Filename);
  37|     EXIT;
  38|   END;
  39|   Assign (O, Newname);
  40|   Rewrite (O);
  41|   Writeln;
  42| 
  43|   WHILE NOT eof (I) DO BEGIN
  44|     Readln (I, Line);
  45|     INC (Nbr);
  46|     GotoXY (1, WhereY-1); Writeln (Nbr);
  47|     Str (Nbr:4, Num);
  48|     Line := Num + '| ' + Line;
  49|     Writeln (O, Line);
  50|   END;
  51|   Close (O);
  52|   Close (I);
  53|   GotoXY (1, WhereY-1); Writeln (nbr, ' lines in file');
  54|   Writeln ('Output is in ', Newname);
  55| END.
  56| 
  57| 


[LISTING 2]

Case-sensitive symbolic cross-reference for number.pas

0 (3), 15, 24, 35
1 (7), 17, 21, 27, 46, 46, 53, 53
135 (1), 10
4 (2), 12, 47
80 (1), 8
Assign (2), 31, 39
Close (2), 51, 52
crt (1), 6
eof (1), 43
EXIT (2), 19, 37
Filename (7), 8, 21, 23, 25, 28, 31, 36
GotoXY (2), 46, 53
I (6), 9, 31, 33, 43, 44, 52
IOResult (1), 35
Len (1), 23
len (3), 11, 24, 27
Line (5), 10, 44, 48, 48, 49
Nbr (5), 11, 15, 45, 46, 47
nbr (1), 53
Newname (9), 8, 16, 25, 28, 28, 29, 29, 39, 54
NOT (1), 43
Num (3), 12, 47, 48
number (1), 1
O (5), 9, 39, 40, 49, 51
p (3), 11, 27, 28
ParamCount (1), 17
ParamStr (1), 21
pos (1), 23
Program (1), 1
Readln (1), 44
Reset (1), 33
Rewrite (1), 40
Str (1), 47
STRING (3), 8, 10, 12
TEXT (1), 9
USES (1), 6
WhereY (2), 46, 53
WORD (1), 11
Writeln (7), 18, 36, 41, 46, 49, 53, 54

-- 40 symbols reported

[LISTING 3]

   1| PROGRAM Xref;
   2| 
   3| { Builds and lists a Pascal/Modula-2 symbol cross-reference report   }
   4| { Uses binary trees and doubly-linked lists to effect B-Tree         }
   5| { Command line is XREF <filename.ext> [/C|/N]                        }
   6| { /C makes xref case-sensitive                                       }
   7| { /N makes it non-case sensitive (default)                           }
   8| { Turbo Pascal 5.0 (4.0 will work, too)                              }
   9| { K. Porter, DDJ, December '88 Structured Programming Column         }
  10| 
  11| USES crt, printer;
  12| 
  13| TYPE  SymString = STRING [39];
  14|       CharSet = SET OF CHAR;
  15|       LineString = STRING [135];
  16|       XLinePtr = ^XLineNode;      { Pointer to xref line number node }
  17|       XLineNode = RECORD          { Xref line number structure (SLL) }
  18|         Line : WORD;
  19|         Next : XLinePtr;
  20|       END;
  21| 
  22|       SymTreePtr = ^SymTreeNode;       { Pointer to symbol tree node }
  23|       SymTreeNode = RECORD                 { Binary tree symbol node }
  24|         Symbol       : SymString;
  25|         UCsymbol     : SymString;
  26|         Count        : WORD;
  27|         XList        : XLinePtr;
  28|         LLink, RLink : SymTreePtr;
  29|       END;
  30| 
  31| CONST Quote =  #39;
  32|       DQuote = #34;
  33|       Eject =  #12;
  34|       SymChars : CharSet = ['0'..'9','A'..'Z','a'..'z','.','_','^'];
  35|       PComment : CharSet = ['{', '}', '(', '*', ')', Quote, DQuote];
  36|       Heading  = ' symbolic cross-reference for ';
  37| 
  38| VAR   Filepath       : STRING [80];
  39|       Case_Sensitive : BOOLEAN;
  40|       F              : TEXT;
  41|       Head, Alpha    : SymTreePtr;
  42|       CommentLevel   : WORD;
  43|       Line           : LineString;
  44|       LineNumber     : WORD;
  45|       NSymbols       : WORD;
  46| { ------------------------------------------------------------------ }
  47| 
  48| PROCEDURE FindEndOfComment (VAR line : LineString;
  49|                             VAR i    : WORD;
  50|                                 eoc  : CHAR);
  51|   { Scan until end of current comment is found }
  52| 
  53| VAR   ch        : CHAR;
  54|       Searching : BOOLEAN;
  55| 
  56| BEGIN
  57|   Searching := TRUE;
  58|   WHILE Searching DO BEGIN
  59|     WHILE i <= Length (Line) DO BEGIN
  60|       ch := Line [i];
  61|       INC (i);
  62|       IF ch = eoc THEN
  63|         CASE eoc OF
  64|           '}':    Searching := FALSE;
  65|           '*':    IF line [i] = ')' THEN BEGIN
  66|                     Searching := FALSE;
  67|                     INC (i);
  68|                   END;
  69|           Quote:  Searching := FALSE;
  70|           DQuote: Searching := FALSE;
  71|         END;
  72| 
  73|       IF Searching = FALSE THEN BEGIN
  74|         DEC (CommentLevel);
  75|         EXIT;
  76|       END;
  77|     END;
  78| 
  79|     { If we get here, the comment continues on the next line }
  80|     Readln (F, Line);
  81|     i := 1;
  82|     INC (LineNumber);
  83|   END;
  84| END;
  85| { --------------------------- }
  86| 
  87| FUNCTION UpShift (VAR Symbol : SymString) : SymString;
  88|   { Return upshifted version of passed string }
  89| 
  90| VAR   p : INTEGER;
  91|       s : SymString;
  92| 
  93| BEGIN
  94|   s := '';
  95|   FOR p := 1 TO Length (Symbol) DO
  96|     s := s + UpCase (Symbol [p]);
  97|   UpShift := s;
  98| END;
  99| { --------------------------- }
 100| 
 101| FUNCTION NewNode (VAR Symbol : SymString) : SymTreePtr;
 102|   { Allocate and set up new symbol node, return pointer }
 103| 
 104| VAR   node : SymTreePtr;
 105| 
 106| BEGIN
 107|   NEW (node);
 108|   Node^.Symbol   := Symbol;
 109|   Node^.UCSymbol := UpShift (Symbol);
 110|   Node^.Count    := 1;
 111|   Node^.XList    := NIL;
 112|   Node^.RLink    := NIL;
 113|   Node^.LLink    := NIL;
 114|   Node^.RLink    := NIL;
 115|   NewNode := node;
 116| END;
 117| { --------------------------- }
 118| 
 119| FUNCTION Token (VAR line : LineString;
 120|                 VAR i : WORD) : SymString;
 121|   { Return next symbol or keyword from line }
 122|   { Index to next char returned as a side-effect }
 123|   { Also checks for comments }
 124| 
 125| VAR   sym          : SymString;
 126|       ch, ScanChar : CHAR;
 127|       nch          : WORD;
 128| 
 129| BEGIN
 130|   { Scan for first valid alphanumeric or for comment }
 131|   ScanChar := #0;
 132|   WHILE (NOT (Line [i] IN SymChars)) AND (i <= Length (line)) DO BEGIN
 133|     ch := line [i];
 134|     INC (i);
 135|     IF ch IN PComment THEN BEGIN
 136|       CASE ch OF
 137|         Quote: BEGIN
 138|                  INC (CommentLevel);
 139|                  ScanChar := Quote;
 140|                END;
 141|         '{':   BEGIN
 142|                  INC (CommentLevel);
 143|                  ScanChar := '}';
 144|                END;
 145|         '}':   IF CommentLevel > 0 THEN
 146|                  DEC (CommentLevel);
 147|         '(':   IF line [i] = '*' THEN BEGIN
 148|                  INC (CommentLevel);
 149|                  ScanChar := '*';
 150|                  INC (i);
 151|                END;
 152|         '*':   IF line [i] = ')' THEN
 153|                  IF CommentLevel > 0 THEN BEGIN
 154|                    DEC (CommentLevel);
 155|                    INC (i);
 156|                  END;
 157|       END;
 158|       IF CommentLevel > 0 THEN
 159|         FindEndOfComment (line, i, ScanChar);
 160|     END;
 161|   END;
 162| 
 163|   { Pull out the symbol }
 164|   sym := '';
 165|   nch := 1;
 166|   IF i < Length (Line) THEN
 167|     REPEAT
 168|       ch := Line [i];
 169|       IF ch IN SymChars THEN BEGIN
 170|         IF (ch = '^') AND (nch = 1) THEN
 171|           { Skip leading pointer char }
 172|         ELSE BEGIN
 173|           sym := sym + ch;
 174|           INC (nch);
 175|         END;
 176|         INC (i);
 177|       END;
 178|     UNTIL (NOT (ch IN SymChars)) OR (i > Length (Line));
 179|   IF NOT Case_Sensitive THEN
 180|     Token := UpShift (sym)
 181|   ELSE
 182|     Token := sym;
 183| END;
 184| { --------------------------- }
 185| 
 186| FUNCTION BNode (VAR sym : SymString) : SymTreePtr;
 187|   { Find sym's node in binary tree, or add it if it doesn't exist }
 188| 
 189| VAR   Node, Parent : SymTreePtr;
 190| 
 191| BEGIN
 192|   Node := Head;
 193|   WHILE ((Node^.Symbol <> sym) AND (Node <> NIL)) DO BEGIN
 194|     Parent := Node;
 195|     IF sym < Node^.Symbol THEN
 196|       Node := Node^.LLink
 197|     ELSE
 198|       Node := Node^.RLink
 199|   END;
 200|   IF Node <> NIL THEN                  { Node exists for this symbol }
 201|     INC (Node^.Count)
 202|   ELSE BEGIN                      { Else add new node to binary tree }
 203|     Node := NewNode (sym);
 204|     IF sym < Parent^.Symbol THEN           { Update parent's pointer }
 205|       Parent^.LLink := Node
 206|     ELSE
 207|       Parent^.RLink := Node
 208|   END;
 209|   BNode := Node;
 210| END;
 211| { --------------------------- }
 212| 
 213| PROCEDURE Append (Target : SymTreePtr; LineNbr : WORD);
 214|   { Add line cross-ref to target's dependent list }
 215| 
 216| VAR    XR, Parent : XLinePtr;
 217| 
 218| BEGIN
 219|   IF Target^.XList = NIL THEN BEGIN     { First occurrence of symbol }
 220|       NEW (XR);
 221|       XR^.Line := LineNbr;
 222|       XR^.Next := NIL;
 223|       Target^.XList := XR;
 224|     END
 225|   ELSE BEGIN                        { Append to end of existing list }
 226|       XR := Target^.Xlist;
 227|       REPEAT
 228|         Parent := XR;
 229|         XR := XR^.Next
 230|       UNTIL XR = NIL;                             { Find list's tail }
 231|       NEW (XR);                                       { Append there }
 232|       XR^.Line := LineNbr;
 233|       XR^.Next := NIL;
 234|       Parent^.Next := XR;
 235|   END;
 236| END;
 237| { --------------------------- }
 238| 
 239| PROCEDURE AddToTree (VAR Symbol : SymString; LineNbr : WORD);
 240|   { Place symbol into binary tree, add line xref to dependent list }
 241| 
 242| VAR   Target : SymTreePtr;
 243| 
 244| BEGIN
 245|   IF Head = NIL THEN BEGIN          { The tree is empty, so start it }
 246|       Head := NewNode (Symbol);            { Build first binary node }
 247|       Append (Head, LineNbr);                { Build first XREF node }
 248|     END
 249|   ELSE BEGIN
 250|       Target := BNode (Symbol);
 251|       Append (Target, LineNbr);
 252|   END;
 253| END;
 254| { --------------------------- }
 255| 
 256| PROCEDURE Process (VAR Line : LineString);
 257|   { Controls parsing and construction of BTree }
 258| 
 259| VAR   Symbol  : SymString;
 260|       p, oldp : WORD;
 261| 
 262| BEGIN
 263|   p := 1;
 264|   IF Length (Line) > 0 THEN
 265|     WHILE p <= Length (Line) DO BEGIN
 266|       oldp := p;
 267|       Symbol := Token (line, p);                        { Get symbol }
 268|       IF Symbol = 'BEGIN' THEN Symbol := ''     { Weed out nuisances }
 269|       ELSE IF Symbol = 'END'     THEN Symbol := ''
 270|       ELSE IF Symbol = 'IF'      THEN Symbol := ''
 271|       ELSE IF Symbol = 'THEN'    THEN Symbol := ''
 272|       ELSE IF Symbol = 'ELSE'    THEN Symbol := ''
 273|       ELSE IF Symbol = 'DO'      THEN Symbol := ''
 274|       ELSE IF Symbol = 'WHILE'   THEN Symbol := ''
 275|       ELSE IF Symbol = 'FOR'     THEN Symbol := ''
 276|       ELSE IF Symbol = 'TO'      THEN Symbol := ''
 277|       ELSE IF Symbol = 'VAR'     THEN Symbol := ''
 278|       ELSE IF Symbol = 'INC'     THEN Symbol := ''
 279|       ELSE IF Symbol = 'DEC'     THEN Symbol := ''
 280|       ELSE IF Symbol = 'OF'      THEN Symbol := ''
 281|       ELSE IF Symbol = 'PROGRAM' THEN Symbol := ''
 282|       ELSE IF Symbol = 'END.'    THEN Symbol := '';
 283|       IF Length (Symbol) > 0 THEN
 284|         AddToTree (Symbol, LineNumber);        { Place info in BTree }
 285|       IF p = oldp THEN INC (p);              { Prevents endless loop }
 286|     END;
 287| END;
 288| { --------------------------- }
 289| 
 290| PROCEDURE Report (Node : SymTreePtr);
 291|   { Print symbol cross-reference listing }
 292|   { In-order (recursive) traversal of binary tree, printing the info
 293|       and dependent list for each node }
 294| 
 295| VAR   Col, Width : WORD;
 296|       Lnode      : XLinePtr;
 297| 
 298|   PROCEDURE NewLine;
 299|     { Control pagination }
 300|   BEGIN
 301|     Writeln (LST);
 302|     Col := 0;
 303|     INC (LineNumber);
 304|     IF LineNumber > 58 THEN BEGIN
 305|       Write (LST, Eject);
 306|       Writeln (LST, 'Continuing cross-reference for ', Filepath);
 307|       Writeln (LST);
 308|       LineNumber := 2;
 309|     END;
 310|   END;                                        { End nested procedure }
 311| 
 312| BEGIN
 313|   IF node <> NIL THEN BEGIN
 314|     Report (Node^.LLink);                    { Follow left-hand path }
 315| 
 316|     { Print info from node }
 317|     Col := 0;
 318|     Write (LST, Node^.Symbol, ' (', Node^.Count, ')');
 319|     Col := Col + Length (Node^.Symbol) + 6;
 320| 
 321|     { Print line number references }
 322|     Lnode := Node^.XList;
 323|     While Lnode <> NIL DO BEGIN
 324|       IF Col > 0 THEN
 325|         Write (LST, ', ', Lnode^.Line)
 326|       ELSE
 327|         Write (LST, '  ', Lnode^.Line);
 328|       IF Lnode^.Line < 10 THEN Width := 1
 329|         ELSE IF Lnode^.Line > 99 THEN Width := 3
 330|           ELSE Width := 2;
 331|       Col := Col + Width + 2;
 332|       IF (Col > 70) AND (Lnode^.Next <> NIL) THEN NewLine;
 333|       Lnode := Lnode^.Next;
 334|     END;
 335|     NewLine;
 336| 
 337|     Report (Node^.RLink);              { Then follow right-hand path }
 338|   END;
 339| END;
 340| { --------------------------- }
 341| 
 342| PROCEDURE Alphabetize (sym : SymTreePtr);
 343|   { Rearrange tree when case-sensitive so that upper- and lower-case
 344|     identifiers occur in alphabetic order regardless of case }
 345|   { RECURSIVE: Traverses symbol table in-order, builds alpha list }
 346| 
 347|   PROCEDURE Resort (sym : SymTreePtr);
 348|     { NESTED: Place new node in tree headed by Alpha pointer }
 349| 
 350|   VAR   Node, Parent : SymTreePtr;
 351|         UCsymbol     : SymString;
 352| 
 353|   BEGIN
 354|     IF Alpha = NIL THEN BEGIN       { Make first node in sorted tree }
 355|         Alpha := NewNode (sym^.symbol);
 356|         Alpha^.count    := sym^.count;
 357|         Alpha^.XList    := sym^.XList;
 358|       END
 359|     ELSE BEGIN                               { Add new node in order }
 360|         UCsymbol := UpShift (sym^.symbol);
 361|         Node := Alpha;
 362|         WHILE node <> NIL DO BEGIN            { Find insertion point }
 363|           Parent := node;
 364|           IF UCsymbol < Node^.UCsymbol THEN    { based on U/C symbol }
 365|             Node := Parent^.LLink
 366|           ELSE
 367|             Node := Parent^.RLink;
 368|         END;
 369|         Node := NewNode (sym^.symbol);                    { Add node }
 370|         Node^.Count    := sym^.count;
 371|         Node^.XList    := sym^.XList;
 372|         IF UCsymbol < Parent^.UCsymbol THEN
 373|           Parent^.LLink := node
 374|         ELSE
 375|           Parent^.RLink := node;
 376|       END;
 377|   END;
 378| 
 379| BEGIN  { Body of Alphabetize }
 380|   IF sym <> NIL THEN BEGIN
 381|     Alphabetize (sym^.LLink);                     { Do nodes to left }
 382|     Resort (sym);                          { Realphabetize this node }
 383|     Alphabetize (sym^.RLink);                { Now do nodes to right }
 384|     Dispose (sym);                         { All thru with this node }
 385|   END;
 386| END;
 387| { --------------------------- }
 388| 
 389| PROCEDURE Count (Node : SymTreePtr);
 390|   { Count nodes in tree }
 391| BEGIN
 392|   IF node <> NIL THEN BEGIN
 393|     Count (Node^.LLink);
 394|     INC (NSymbols);
 395|     Count (Node^.RLink);
 396|   END
 397| END;
 398| { --------------------------- }
 399| 
 400| BEGIN
 401|   { Initialize }
 402|   Head := NIL;
 403|   Alpha := NIL;
 404|   CommentLevel := 0;
 405|   LineNumber := 0;
 406|   NSymbols := 0;
 407| 
 408|   { Process command line }
 409|   IF ParamCount < 1 THEN BEGIN
 410|     Writeln ('USAGE: XREF <Filename.[ext]> [/C|/N]');
 411|     EXIT;
 412|   END;
 413|   Filepath := ParamStr (1);
 414|   IF pos ('.', Filepath) = 0 THEN
 415|     Filepath := Filepath + '.PAS';          { Default is Pascal file }
 416|   Case_Sensitive := FALSE;            { Set default case sensitivity }
 417|   IF ParamCount = 2 THEN                 { or alter per command line }
 418|     IF (ParamStr (2) = '/c') OR (ParamStr (2) = '/C') THEN
 419|       Case_Sensitive := TRUE;
 420| 
 421|   { Open the file }
 422|   Assign (F, Filepath);
 423|   {$I-}
 424|   Reset (F);
 425|   {$I+}
 426|   IF IOResult <> 0 THEN BEGIN
 427|     Writeln ('Unable to open ', Filepath);
 428|     EXIT;
 429|   END;
 430| 
 431|   { Announce the program }
 432|   ClrScr;
 433|   IF Case_Sensitive THEN
 434|     Write ('Case-sensitive')
 435|   ELSE
 436|     Write ('Non-case sensitive');
 437|   Writeln (Heading, Filepath);
 438|   Writeln;
 439| 
 440|   { Process the file }
 441|   WHILE NOT eof (F) DO BEGIN
 442|     Readln (F, line);
 443|     INC (LineNumber);
 444|     GotoXY (1, WhereY-1); Writeln (LineNumber);  { Meter line number }
 445|     Process (Line);
 446|   END;
 447|   Close (F);
 448|   GotoXY (1, WhereY-1); Writeln (LineNumber, ' lines in file');
 449|   IF CommentLevel <> 0 THEN
 450|     Writeln ('Unbalanced comments detected');
 451| 
 452|   { Alphabetize tree into non-ASCII order if case-sensitive }
 453|   LineNumber := 3;
 454|   IF Case_Sensitive THEN BEGIN
 455|       Alphabetize (Head);
 456|       Writeln (LST, 'Case-sensitive', Heading, Filepath);
 457|       Writeln (LST);     
 458|       Report (Alpha);
 459|       Count (Alpha);
 460|     END
 461|   ELSE BEGIN
 462|       Writeln (LST, 'Non-case sensitive', Heading, Filepath);
 463|       Writeln (LST);
 464|       Report (Head);
 465|       Count (Head);
 466|     END;
 467|   Writeln (LST);
 468|   Writeln (LST, '-- ', NSymbols, ' symbols reported');
 469|   Write (LST, Eject);
 470| END.