home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / AAKXREF.ZIP / WRITEID.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-04-24  |  4.9 KB  |  148 lines
  1. procedure writeid;
  2. VAR
  3.    I ,
  4.    xx : integer;
  5.   function rsvdword: boolean;
  6.     const
  7.       wordlist: array[1..reserved_count] of string[14] =
  8.         ('ABSOLUTE','ADDR','AND','ARC','ARCTAN','ARRAY','ASSIGN','AUX',
  9.          'AUXINPTR','AUXOUTPTR','BACK',
  10.          'BEGIN','BLOCKREAD','BLOCKWRITE','BOOLEAN','BYTE',
  11.          'CASE','CHAIN','CHAR','CHDIR','CHR','CIRCLE','CLEARSCREEN',
  12.          'CLOSE','CLREOL','CLRSCR','COLORTABLE','CON','CONCAT','CONINPTR',
  13.          'CONOUTPTR','CONST',
  14.          'CONSTPTR','COPY','COS','CRTEXIT','CRTINIT','CSEG','DELAY',
  15.          'DELETE','DELLINE','DISPOSE',
  16.          'DIV','DO','DOWNTO','DRAW','ELSE','END','END.','EOF','EOLN','ERASE',
  17.          'EXECUTE','EXP','EXTERNAL','FALSE','FILE','FILEPOS','FILESIZE',
  18.          'FILLCHAR','FILLPATTERN','FILLSCREEN','FILLSHAPE',
  19.          'FLUSH','FOR','FORWARD','FRAC','FREEMEM',
  20.          'FUNCTION','GETDIR','GETDOT',
  21.          'GETMEM','GETPIC','GOTO','GOTOXY',
  22.          'GRAPHBACKGROUND','GRAPHCOLORMODE',
  23.          'GRAPHMODE','GRAPHWINDOW','HALT','HEAPPTR',
  24.          'HEADING','HI','HIDETURTLE',
  25.          'HIRES','HIRESCOLOR','HOME',
  26.          'IF','IN','INLINE','INPUT','INSERT','INSLINE','INT','INTEGER','INTR',
  27.          'IORESULT','KBD','KEYPRESSED','LABEL','LENGTH','LN','LO','LOWVIDEO',
  28.          'LST','LSTOUTPTR','MARK','MAXAVAIL',
  29.          'MAXINT','MEMAVAIL','MEMW','MKDIR','MOD',
  30.          'MOVE','MSDOS','NEW','NIL','NORMVIDEO','NOSOUND',
  31.          'NOT','ODD','OF','OFS','OR','ORD','OUTPUT','OVERLAY',
  32.          'PACKED','PALETTE','PARAMCOUNT','PARAMSTR','PATTERN',
  33.          'PENDOWN','PENUP',
  34.          'PI','PLOT','PORT','POS','PRED','PROCEDURE',
  35.          'PROGRAM','PTR','PUTPIC','RANDOM','RANDOMIZE','READ','READLN','REAL',
  36.          'RECORD','RELEASE','RENAME','REPEAT','RESET',
  37.          'REWRITE','RMDIR','ROUND','SEEK','SEEKEOF','SEEKEOLN',
  38.          'SEG','SET','SETHEADING','SETPENCOLOR','SETPOSITION',
  39.          'SHL','SHOWTURTLE','SHR','SIN','SIZEOF','SOUND',
  40.          'SQR','SQRT','STR','STRING',
  41.          'SUCC','SWAP','TEXT','TEXTBACKGROUND','TEXTCOLOR','TEXTMODE',
  42.          'THEN','TO','TRM','TRUE','TRUNC',
  43.          'TURNLEFT','TURNRIGHT','TURTLETHERE','TURTLEWINDOW','TYPE',
  44.          'UNTIL','UPCASE','USR','USRINPTR','USROUTPTR','VAL','VAR',
  45.          'WHEREX','WHEREY','WHILE','WINDOW',
  46.          'WITH','WRAP','WRITE','WRITELN','XCOR','XOR','YCOR');
  47.     var
  48.       i, j, k: integer;
  49.       upid:    string[127];
  50.     begin
  51.       upid := '';
  52.       for i := 1 to length(id) do
  53.         upid := upid + upcase(copy(id,i,1));
  54.       i := 1;
  55.       j := reserved_count - 1;
  56.       repeat
  57.         k := (i+j) div 2;
  58.         if upid > wordlist[k] then i := k+1
  59.                             else j := k
  60.     until i = j;
  61.     rsvdword := (upid = wordlist[i])
  62.     end {rsvdword};
  63.  
  64.    PROCEDURE Search ( var w1 : Word_Ptr ) ;
  65.  
  66.    VAR
  67.       w : Word_Ptr;
  68.       x : Item_Ptr;
  69.  
  70.    BEGIN (* NESTED *)
  71.       w := w1 ;
  72.       if w = nil
  73.       THEN BEGIN
  74.               new(w);
  75.               new(x);
  76.               with w^ do
  77.               begin
  78.                  key   := id;
  79.                  left  := nil;
  80.                  right := nil;
  81.                  first := x ;
  82.                  last  := x ;
  83.               end ;
  84.               x^.lno := Line_Numb ;
  85.               x^.next := nil;
  86.               w1 := w
  87.            end
  88.       ELSE BEGIN
  89.               if id < w^.key
  90.               THEN search ( w^.left )
  91.               ELSE BEGIN
  92.                       IF id > w^.key
  93.                       THEN search ( w^.right )
  94.                       ELSE BEGIN
  95.                               new(x);
  96.                               x^.lno := Line_Numb ;
  97.                               x^.next := nil;
  98.                               w^.last^.next := x;
  99.                               w^.last := x
  100.                            END ;
  101.                  END ;
  102.           END ;
  103.     END ; (* NESTED SEARCH *)
  104.  
  105.  
  106.     Procedure Regular_video;
  107.     begin
  108.         TextBackground(black);
  109.         TextColor(white);
  110.     end;
  111.  
  112.     Procedure Reverse_video;
  113.     begin
  114.         TextBackground(white);
  115.         TextColor(black);
  116.     end;
  117.  
  118.   FUNCTION locase(ch:char) : char;
  119.   BEGIN
  120.    If ch in ['A'..'Z']
  121.     then locase := chr(ord(ch) or $20)
  122.     else locase := ch
  123.   END;
  124.  
  125. begin (* PROC *)
  126.    if rsvdword then
  127.         BEGIN (* RESERVED WORD *)
  128. {$V- }
  129.            Upper_Case ( Id ) ;
  130. {$V+ }
  131.            I := LENGTH ( Id ) ;
  132.            IF ( 'P' IN Switches )
  133.            THEN BEGIN
  134.                    Add_Line_Str ( Line , Empha_On + Id + Empha_Off , I ) ;
  135.                 END (* PRINTER *)
  136.            ELSE Add_Line_Str ( Line , Id , I ) ;
  137.         END
  138.    ELSE BEGIN (* NOT RESERVED WORD *)
  139.            I := LENGTH ( Id ) ;
  140.            Add_Line_Str ( Line , Id , I ) ;
  141.            If ( 'N' in switches ) then
  142.            begin
  143.               for xx := 1 to I do id [ xx ] := locase ( id [ xx ] ) ;
  144.               search ( root ) ;
  145.            end ;
  146.         end ;
  147. end {writeid};
  148.