home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB20.ZIP / TURBXREF.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-05-14  |  7.1 KB  |  258 lines
  1. { Modified for TURBO Pascal 1.00a (MS-DOS Ver.) }
  2. { By: J.W.Kindschi Jr.      February 25, 1984   }
  3.  
  4. Program crossref(Input,Output);
  5. Const
  6.       c1 = 10;
  7.       c2 = 10;
  8.       c3 =  6;
  9.       c4 = 9999;
  10.       reserved = 86;
  11.       form_feed = 12;
  12. Type
  13.      name = String[14];
  14.      cmd  = (r,w);
  15.      alpha = Packed Array[1..c1] Of Char;
  16.      wordref = ^word;
  17.      itemref = ^item;
  18.      word = Record
  19.               key        : alpha;
  20.               first,last : itemref;
  21.               left,right : wordref;
  22.             End;
  23.      item = Packed Record
  24.               line_no    : 0..c4;
  25.               next       : itemref;
  26.             End;
  27. Var
  28.     root   : wordref;
  29.     k,k1   : byte;
  30.     result : Integer;
  31.     ptr,n,i: Integer;
  32.     id,a   : alpha;
  33.     uid    : alpha;
  34.     f,g    : Text;
  35.     ch     : Char;
  36.     line   : String[135];
  37.     source,
  38.     dest   : name;
  39.     flag   : Boolean;
  40.     keys   : Packed Array[0..reserved] Of String[c1];
  41.  
  42.  
  43.  
  44. Procedure uppercase(Var str:alpha);
  45. Var i : Integer;
  46. Begin
  47.   For i := 1 To length(str) Do str[i] := upcase(str[i]);
  48. End;
  49.  
  50.  
  51. Procedure search(Var w1:wordref);
  52. Var
  53.   w: wordref;
  54.   x: itemref;
  55. Begin
  56.   w := w1;
  57.   If w=Nil Then
  58.     Begin
  59.       New(w);
  60.       New(x);
  61.       With w^ Do
  62.         Begin
  63.           key := id;
  64.           left := Nil;
  65.           right := Nil;
  66.           first := x;
  67.           last := x;
  68.         End;
  69.       x^.line_no := n;
  70.       x^.next := Nil;
  71.       w1 := w;
  72.     End
  73.   Else
  74.     If id<w^.key Then
  75.       search(w^.left)
  76.   Else
  77.     If id>w^.key Then
  78.       search(w^.right)
  79.   Else
  80.     Begin
  81.       New(x);
  82.       x^.line_no := n;
  83.       x^.next := Nil;
  84.       w^.last^.next := x;
  85.       w^.last := x;
  86.     End;
  87. End;
  88.  
  89.  
  90. Procedure printtree(w:wordref);
  91.  
  92. Procedure printword(w:word);
  93. Var
  94.     l: Integer;
  95.     x: itemref;
  96. Begin
  97.   Write(g,' ',w.key);
  98.   x := w.first;
  99.   l := 0;
  100.   Repeat
  101.     If l=c2 Then
  102.       Begin
  103.         Writeln(g);
  104.         l := 0;
  105.         Write(g,' ':c1+1);
  106.       End;
  107.     l := l+1;
  108.     Write(g,x^.line_no: c3);
  109.     x := x^.next;
  110.   Until x=Nil;
  111.   Writeln(g);
  112. End;
  113.  
  114.  
  115. Begin
  116.   If w<>Nil Then
  117.     Begin
  118.       printtree(w^.left);
  119.       printword(w^);
  120.       printtree(w^.right);
  121.     End;
  122. End;
  123.  
  124. Procedure initkeys;
  125. Begin
  126.   keys[00] := 'ABS       '; keys[01] := 'AND       '; keys[02] := 'ARCTAN    ';
  127.   keys[03] := 'ARRAY     '; keys[04] := 'BEGIN     '; keys[05] := 'BOOLEAN   ';
  128.   keys[06] := 'CASE      '; keys[07] := 'CHAR      '; keys[08] := 'CHR       ';
  129.   keys[09] := 'CONST     '; keys[10] := 'COS       '; keys[11] := 'DISPOSE   ';
  130.   keys[12] := 'DIV       '; keys[13] := 'DOWNTO    '; keys[14] := 'ELSE      ';
  131.   keys[15] := 'END       '; keys[16] := 'EOF       '; keys[17] := 'EOLN      ';
  132.   keys[18] := 'EXP       '; keys[19] := 'FALSE     '; keys[20] := 'FILE      ';
  133.   keys[21] := 'FOR       '; keys[22] := 'FORWARD   '; keys[23] := 'FUNCTION  ';
  134.   keys[24] := 'GET       '; keys[25] := 'GOTO      '; keys[26] := 'IF        ';
  135.   keys[27] := 'IN        '; keys[28] := 'INPUT     '; keys[29] := 'INTEGER   ';
  136.   keys[30] := 'LABEL     '; keys[31] := 'LN        '; keys[32] := 'MAXINT    ';
  137.   keys[33] := 'MOD       '; keys[34] := 'NEW       '; keys[35] := 'NIL       ';
  138.   keys[36] := 'NOT       '; keys[37] := 'ODD       '; keys[38] := 'OF        ';
  139.   keys[39] := 'OR        '; keys[40] := 'ORD       '; keys[41] := 'OUTPUT    ';
  140.   keys[42] := 'PACK      '; keys[43] := 'PACKED    '; keys[44] := 'PAGE      ';
  141.   keys[45] := 'PRED      '; keys[46] := 'PROCEDURE '; keys[47] := 'PROGRAM   ';
  142.   keys[48] := 'PUT       '; keys[49] := 'READ      '; keys[50] := 'READLN    ';
  143.   keys[51] := 'REAL      '; keys[52] := 'RECORD    '; keys[53] := 'REPEAT    ';
  144.   keys[54] := 'RESET     '; keys[55] := 'REWRITE   '; keys[56] := 'ROUND     ';
  145.   keys[57] := 'SET       '; keys[58] := 'SIN       '; keys[59] := 'SQR       ';
  146.   keys[60] := 'SQRT      '; keys[61] := 'STRING    '; keys[62] := 'SUCC      ';
  147.   keys[63] := 'TEXT      '; keys[64] := 'THEN      '; keys[65] := 'TO        ';
  148.   keys[66] := 'TRUE      '; keys[67] := 'TRUNC     '; keys[68] := 'TYPE      ';
  149.   keys[69] := 'UNPACK    '; keys[70] := 'VAR       '; keys[71] := 'WHILE     ';
  150.   keys[72] := 'WITH      '; keys[73] := 'WRITE     '; keys[74] := 'WRITELN   ';
  151.   keys[75] := 'UNTIL     '; keys[76] := 'DO        '; keys[77] := '          ';
  152.   keys[78] := '          '; keys[79] := '          '; keys[80] := '          ';
  153.   keys[81] := '          '; keys[82] := '          '; keys[83] := '          ';
  154.   keys[84] := '          '; keys[85] := '          '; keys[86] := 'END.      ';
  155. End;
  156.  
  157. Function exists(filename : name; func : cmd):Boolean;
  158. Begin
  159.   If func = r Then assign(f,filename) Else assign(g,filename);
  160.   {$I-}
  161.   If func = r Then Reset(f) Else Rewrite(g);
  162.   {$I+}
  163.   If ioresult <> 0 Then exists := False Else exists := True;
  164. End;
  165.  
  166.  
  167.  
  168. Begin
  169.   initkeys;
  170.   flag := False;
  171.   root := Nil;
  172.   n := 0;
  173.   k1 := c1;
  174.   clrscr;
  175.   lowvideo;
  176.   gotoxy(0,3);
  177.   writeln('This Program will read a Pascal Text File, and Write it to a Destination');
  178.   writeln('File along with a Cross Reference List of all words except those that');
  179.   writeln('are classed as being RESERVED, or those listed as STANDARD in the book');
  180.   writeln('titled "The Pascal Handbook" (c) by "SYBEX", also those words on the same');
  181.   writeln('line enclosed within comment braces or quotes are not considered.');
  182.   writeln;
  183.   writeln('By: John W. Kindschi Jr. (c) 1984');
  184.   Repeat
  185.     lowvideo;
  186.     gotoxy(5,12);
  187.     Write(Output,'Source File ? ');
  188.     clreol;
  189.     highvideo;
  190.     Readln(Input,source);
  191.   Until exists(source,r);
  192.   Repeat
  193.     lowvideo;
  194.     gotoxy(5,14);
  195.     Write(Output,'Destination File ? ');
  196.     clreol;
  197.     highvideo;
  198.     Readln(Input,dest);
  199.   Until exists(dest,w);
  200.   Readln(f,line);
  201.   While Not Eof(f) Do
  202.   Begin
  203.     If n=c4 Then n := 0;
  204.     n := n+1;
  205.     Write(g,n:c3);
  206.     Write(g,': ');
  207.     ptr := 1;
  208.     While (ptr <= length(line)) Do
  209.     Begin
  210.       If (line[ptr] In ['A'..'Z','a'..'z','^']) Then
  211.       Begin
  212.         k := 0;
  213.         Repeat
  214.           If k < c1 Then
  215.           Begin
  216.             k := k + 1;
  217.             a[k] := line[ptr];
  218.           End;
  219.           ptr := ptr + 1;
  220.         Until Not (line[ptr] In ['A'..'Z','a'..'z','_','^','.','0'..'9'])
  221.           Or (ptr > length(line));
  222.         If k >= k1 Then
  223.         k1 := k
  224.         Else
  225.         Repeat
  226.           a[k1] := ' ';
  227.           k1 := k1 - 1;
  228.         Until k1 = k;
  229.         id := a;
  230.         uid := a;
  231.         uppercase(uid);
  232.         For i := 0 To reserved Do
  233.         If uid = keys[i] Then flag := True;
  234.         If Not flag Then search(root);
  235.         flag := False;
  236.       End
  237.       Else
  238.       Begin
  239.         If line[ptr] = '{' Then
  240.         Repeat
  241.           ptr := ptr + 1;
  242.         Until line[ptr] = '}';
  243.         If line[ptr] = '''' Then
  244.         Repeat
  245.           ptr := ptr + 1;
  246.         Until line[ptr] = '''';
  247.         ptr := ptr + 1;
  248.       End;
  249.     End;
  250.     Writeln(g,line);
  251.     Readln(f,line);
  252.   End;
  253.   Write(g,chr(12));
  254.   printtree(root);
  255.   close(f);
  256.   close(g);
  257. End.
  258.