CP/M/CPM_CDROM.iso/cpm/utils/asmutl/id2id.lbr/ID2ID.PZS/ID2ID.PAS

Pascal/Delphi Source File | 1986-12-28 | 25.0 KB | 667 lines

PROGRAM id2id(source, target, idpairs, output);
(* ####################################################### *)
(* ID2ID - Rename identifiers in PASCAL, C, ASSY  or SPL   *)
(*         programs.  Optional up/downshift.               *)
(*                                                         *)
(* W A R N I N G - This system is case sensitive for id's. *)
(* IN addition, if listed on uppercase only printers,      *)
(* note that many characters are lower case.  In general,  *)
(* identifiers are lowercase and reserved words are in     *)
(* upper case. Braces may map into brackets on UC printers *)
(*                                                         *)
(* James F. Miner  79/06/01                                *)
(*  Social Sciences Research Facilities Center.            *)
(* Andy Mickel     79/06/28                                *)
(*  University Computer Center,   [phone]           *)
(* University of Minnesota,                                *)
(* Minneapolis, Minn. 55455 USA   Copyright (c) 1979       *)
(* C.B. Falconer      79/12/04    [phone]           *)
(*  680 Hartfort Tpk., Hamden, Conn. 06517                 *)
(*    for SPL source and generally adapted to HP3000       *)
(*                                                         *)
(*  (Based on an earlier version by John T. Easton and     *)
(*   James F. Miner, 76/11/29, as modified by Andy         *)
(*   Mickel and Rick L. Marcus, 78/12/08)                  *)
(*                                                         *)
(* THE NAMES AND ORGANIZATIONS GIVEN MUST NOT BE DELETED   *)
(* IN ANY USE OF THIS PROGRAM                              *)
(*                                                         *)
(* See Pascal News #15 for external documentation          *)
(*                                                         *)
(*         Internal documentation                          *)
(* ID2ID reads a file of IDPAIRS and builds an AVL-        *)
(* balanced binary tree of identifiers while checking for  *)
(* duplicates.  It then reads the SOURCE program and edits *)
(* it to TARGET file by substituting identifiers found in  *)
(* the tree.  A final check is made for new identifiers    *)
(* which were already seen in the SOURCE, and REPORT may   *)
(* be generated.                                           *)
(*                                                         *)
(* Outline of modifications by C.B.F.                      *)
(* The IDPAIRS file may contain option settings, starting  *)
(* at the left of the line, of the form                    *)
(*   $OPTION   where OPTION may be:                        *)
(*       "FLIP", "SPL", "ASM", "C", "UPSHIFT", "DOWNSHIFT" *)
(* This controls the comment and string delimiters used.   *)
(* FLIP allows the action to be reversed, i.e. replace new *)
(* by old, and undo the revision.                          *)
(*                                                         *)
(* NOTE that, to preserve original line numbers, TARGET    *)
(* file should generally be a variable ascii file on the   *)
(* HP3000 system.  This will allow the editor to recover   *)
(* and reformat the file records as desired.  Lines        *)
(* beginining with "E" or "e" in column 1 may confuse the  *)
(* system when using front numbered files, and lines with  *)
(* alphabetical characters in the last column will also    *)
(* cause confusion when using rear-numbered files.         *)
(*                                                         *)
(* The revised system allows for the use of indentation    *)
(* codes in the source file, where an indentation code is  *)
(* the ascii DLE character, followed by chr(ord(' ')+n)    *)
(* where n is the number of spaces desired.                *)
(*                                                         *)
(* Other languages may usually be handled by suitable      *)
(* chars. for string delimiters and for "fillers".  The    *)
(* cases added are for 8080 and similar assembly language  *)
(* (almost Intel specs), C and SPL (an ALGOL like language *)
(* for the HP3000).                                        *)
(*                                                         *)
(* 1.7 - option $ASM8080 changed to $ASM. (this parameter  *)
(*       handles 8080, Z80, 8086 source).  Added options   *)
(*       $C, $DOWNSHIFT.  $ASM, $C allow for ' or " string *)
(*       delimiters.  86/2/21 cbf                          *)
(* 1.6 - added linenumber for unclosed string error        *)
(*       normal input operation, check source exists 84/4  *)
(* 1.5 - added option "UPSHIFT", Feb. 1982                 *)
(* ####################################################### *)

  (* =================== *)

  CONST
    signon      = 'ID2ID (source, target, idpairs, output) Ver. 1.7 ';
    maxlength   = 25;
    blanks      = '                         ';
    (* must be maxlength long *)
    debug       = false;         (* enable symbol dumps *)
    growthflag  = false;         (* enable dump on growth *)

  (* =================== *)

  TYPE
    idlength    = 1..maxlength;
    string      = RECORD
      name        : PACKED ARRAY[idlength] OF char;
      length      : 0..maxlength;  (* 0 allows for empty string *)
      END;

    chtype      = (digit, letter, under, lparen, lbrace,
                   indent, ltsy, semi, slash, prime, quote,
                   blank, special, other);
    (* so <= under is allowable in id's *)

    balance     = (lefthigh, even, ritehigh);
    nodeptr     = ^node;
    node        = RECORD
      id          : string;
      left, right : nodeptr;
      bal         : balance;
      idisnew     : boolean;
      CASE idisold: boolean OF
  true:  (newptr      : nodeptr);
  false: (seeninsource : boolean);
      END;  (* node RECORD *)

  (* ================== *)

  VAR
    idtable     : nodeptr;       (* symbol table *)

    idpairs,
    source,
    target      : text;

    downshift,
    upshift,                     (* input text *)
    fatal       : boolean;       (* abort on fatal errors *)

    depth       : integer;       (* monitor table depth *)

    (* string delimiters for language *)
    delim1,                      (* usually single quote *)
    delim2      : char;          (* usually double quote *)
    language    : (pascal, spl, asm8080, c);  (* available languages *)

    dle         : char;          (* signals indentation codes *)
    underch     : char;          (* filler character in ids *)

    upshiftwd   : string;
    downshftwd  : string;
    splwd       : string;
    asm8080wd   : string;
    cwd         : string;
    flipwd      : string;
    cmntwd      : string;
    cmntwdl     : string;      (* in lower case *)

  (* 1-----------------1 *)

  PROCEDURE initialize;

    BEGIN (* initialize *)
    depth := 0; dle := chr(16);  (* data link escape *)
    underch := '_';
    delim1 := ''''; delim2 := '"';  (* default pascal strings *)
    language := pascal;
    splwd.name       := 'SPL                      ';
    asm8080wd.name   := 'ASM                      ';
    cwd.name         := 'C                        ';
    flipwd.name      := 'FLIP                     ';
    cmntwd.name      := 'COMMENT                  ';
    cmntwdl.name     := 'comment                  ';
    upshiftwd.name   := 'UPSHIFT                  ';
    downshftwd.name  := 'DOWNSHIFT                ';
    (*                 1234567890123456789012345' *)
    splwd.length := 3; upshiftwd.length := 7;
    asm8080wd.length := 3; flipwd.length := 4;
    cmntwd.length := 7; cmntwdl.length := 7;
    downshftwd.length := 9; cwd.length := 1;
    (* names padded to maxlength with blanks *)
    (* options must be in upper case *)
    writeln(signon);
    fatal := false; (* no fatal error yet *)
    upshift := false; downshift := false;
    END; (* initialize *)

  (* 1-----------------1 *)

  PROCEDURE dumptable(base : nodeptr);

    (* 2-----------------2 *)

    PROCEDURE writecontent(item : nodeptr);

      BEGIN (* writecontent *)
      IF debug THEN
        WITH item^ DO BEGIN
          write(output, ' ' : 2 * depth, ord(bal) - 1 : 2,
                        ' ', id.name : id.length);
          IF idisnew THEN write(' *NEW* ');
          IF idisold THEN BEGIN
            write(' *OLD* --> ');
            IF newptr <> item THEN WITH newptr^.id DO BEGIN
              write(name : length); END
            ELSE write(' itself!!'); END;
          END; (* WITH item^ *)
        writeln;
      END; (* writecontent *)

    (* 2-----------------2 *)

    BEGIN  (* dumptable *)
    IF debug THEN
      IF base <> NIL THEN BEGIN
        depth := succ(depth);
        dumptable(base^.left);
        writecontent(base);
        dumptable(base^.right);
        depth := pred(depth); END; (* base <> NIL *)
    END; (* dumptable *)

  (* 1-----------------1 *)

  FUNCTION chclass(ch : char) : chtype;
  (* May be incorrect for non-ASCII character sets,  *)
  (* however all these dependencies are collected    *)
  (* here, and a set of char is not required         *)

    BEGIN (* chclass *)
    IF (ch >= 'A') AND (ch <= 'Z') THEN chclass := letter
    ELSE IF (ch >= 'a') AND (ch <= 'z') THEN chclass := letter
    ELSE IF (ch >= '0') AND (ch <= '9') THEN chclass := digit
    ELSE IF ch = delim1 THEN chclass := prime
    ELSE IF ch = delim2 THEN chclass := quote
    ELSE IF ch = '(' THEN chclass := lparen
    ELSE IF ch = '{' THEN chclass := lbrace
    ELSE IF ch = '/' THEN chclass := slash
    ELSE IF ch = ' ' THEN chclass := blank
    ELSE IF ch = underch THEN chclass := under
    ELSE IF ch = '<' THEN chclass := ltsy (* allow for SPL comments *)
    ELSE IF ch = ';' THEN chclass := semi (* for 8080 comments *)
    ELSE IF ch = dle THEN chclass := indent (* multi-blanks *)
    ELSE IF (ch = '@') OR (ch = '.') THEN BEGIN
      IF language = ASM8080 THEN chclass := letter
      ELSE chclass := other END
    ELSE chclass := other;
    END; (* chclass *)

  (* 1-----------------1 *)

  PROCEDURE readid(VAR infile : text; VAR ident : string);

    CONST
      ucnvt = -32; (* ord('A') - ord('a') *)

    VAR
      ch    : char;

    BEGIN (* readid *)
    WITH ident DO BEGIN
      name := blanks; length := 0;
      REPEAT
        length := succ(length); read(infile, ch);
        IF upshift THEN
          IF ch IN ['a'..'z'] THEN name[length] := chr(ord(ch) + ucnvt)
          ELSE name[length] := ch
        ELSE IF downshift THEN
          IF ch IN ['A'..'Z'] THEN name[length] := chr(ord(ch) - ucnvt)
          ELSE name[length] := ch
        ELSE name[length] := ch;
      UNTIL eoln(infile) OR
            (chclass(infile^) > under) OR
            (length = maxlength);
      END; (* WITH ident *)
    END; (* readid *)

  (* 1---------------1 *)

  PROCEDURE readidpairsandcreatesymboltable;

    LABEL 97, 98; (* for fatal errors *)

    TYPE
      idkind      = (oldkind, newkind);

    VAR
      xtraid,
      oldid,
      newid       : string;
      link        : nodeptr;     (* remember newid pointer *)
      linenum     : integer;
      flipflag,                  (* to reverse action of idpairs *)
      incrhgt     : boolean;

    (* 2---------------2 *)

    PROCEDURE error;

      BEGIN (* error *)
      writeln('on line number ' : 29, linenum : 1,
            ' of "idpairs" file.');
      END; (* error *)

    (* 2---------------2 *)

    PROCEDURE enter(VAR identifier : string; kind : idkind;
                    VAR p : nodeptr; VAR higher : boolean);

      (* ################################################# *)
      (* enter uses an avl-balanced tree search algorithm  *)
      (* by Miklaus Wirth.  See section 4.4.7 in           *)
      (* "ALGORITHMS+DATA STRUCTURES = PROGRAMS"           *)
      (* ################################################# *)

      LABEL 99; (* for fatal error exit *)

      VAR
        p1, p2      : nodeptr;

      BEGIN (* enter *)
      IF p = NIL THEN BEGIN (* id not found in tree, insert it *)
        new(p); higher := true;
        WITH p^ DO BEGIN
          id := identifier;
          idisnew := kind = newkind;
          idisold := kind = oldkind;
          left := NIL; right := NIL; bal := even;
          IF idisnew THEN BEGIN
            link := p; seeninsource := false; END
          ELSE newptr := link; END;
        END
      ELSE IF identifier.name < p^.id.name THEN BEGIN
        enter(identifier, kind, p^.left, higher);
        IF fatal THEN GOTO 99;
        IF higher THEN  (* left branch has grown higher *)
          CASE p^.bal OF
  ritehigh: BEGIN
            p^.bal := even; higher := false;
            END;
      even: p^.bal := lefthigh;
  lefthigh: BEGIN                (* rebalance *)
            p1 := p^.left;
            IF p1^.bal = lefthigh THEN BEGIN (* single ll rotation *)
              p^.left := p1^.right; p1^.right := p;
              p^.bal := even; p := p1; END
            ELSE BEGIN          (* double lr rotation *)
              p2 := p1^.right; p1^.right := p2^.left;
              p2^.left := p1; p^.left := p2^.right;
              p2^.right := p;
              IF p2^.bal = lefthigh THEN p^.bal := ritehigh
              ELSE p^.bal := even;
              IF p2^.bal = ritehigh THEN p1^.bal := lefthigh
              ELSE p1^.bal := even;
              p := p2; END; (* double lr rotation *)
            p^.bal := even; higher := false; END;
          END; (* case *)
        END (* identifier.name < p^.id.name *)
      ELSE IF identifier.name > p^.id.name THEN BEGIN
        enter(identifier, kind, p^.right, higher);
        IF fatal THEN GOTO 99;
        IF higher THEN  (* right branch has grown *)
          CASE p^.bal OF
  lefthigh: BEGIN
            p^.bal := even; higher := false;
            END;
      even: p^.bal := ritehigh;
  ritehigh: BEGIN                (* rebalance *)
            p1 := p^.right;
            IF p1^.bal = ritehigh THEN BEGIN (* single rr rotation *)
              p^.right := p1^.left; p1^.left := p;
              p^.bal := even; p := p1; END
            ELSE BEGIN          (* double rl rotation *)
              p2 := p1^.left; p1^.left := p2^.right;
              p2^.right := p1; p^.right := p2^.left;
              p2^.left := p;
              IF p2^.bal = ritehigh THEN p^.bal := lefthigh
              ELSE p^.bal := even;
              IF p2^.bal = lefthigh THEN p1^.bal := ritehigh
              ELSE p1^.bal := even;
              p := p2; END;
            p^.bal := even; higher := false; END;
          END; (* case *)
        END (* identifier.name > p^.id.name *)
      ELSE BEGIN                (* identifier is already in tree *)
        higher := false;
        WITH p^ DO  BEGIN
          IF idisold THEN
            IF kind = oldkind THEN BEGIN (* duplicate oldid's *)
              writeln('*** duplicate OLDID encountered: ',
                      identifier.name);
              error; fatal := true; GOTO 99; END
            ELSE BEGIN
              idisnew := true; link := p; END
          ELSE IF kind = newkind THEN BEGIN
            writeln('--- warning+  ', identifier.name,
                  ' has also appeared as another newid');
            error; link := p; END
          ELSE BEGIN
            idisold := true; newptr := link; END
          END; (* WITH *)
        END; (* identifier already in tree *)
  99: END; (* enter *)

    (* 2---------------2 *)

    PROCEDURE truncate(VAR ident : string);

      BEGIN (* truncate *)
      writeln('---WARNING: truncation for identifier, ',
            ident.name);
      writeln('Extra chapacters ignored.' : 39);
      error;
      REPEAT
        get(idpairs);
      UNTIL chclass(idpairs^) > under;
      END; (* truncate *)

    (* 2---------------2 *)

    BEGIN (* readidpairsandcreatesymboltable *)
    IF exists(idpairs) THEN BEGIN
      idtable := NIL; linenum := 1;
      incrhgt := false; flipflag := false;
      WHILE NOT eof(idpairs) DO BEGIN
        WHILE (idpairs^ = ' ') AND NOT eoln(idpairs) DO get(idpairs);
        IF chclass(idpairs^) = letter THEN BEGIN
          readid(idpairs, oldid);
          IF chclass(idpairs^) <= under THEN truncate(oldid);
          WHILE NOT eoln(idpairs)
                AND (  (idpairs^=' ')
                    OR (idpairs^=',') ) DO get(idpairs);
          IF chclass(idpairs^) = letter THEN BEGIN
            readid(idpairs, newid);
            IF chclass(idpairs^) <= under THEN truncate(newid);
            IF flipflag THEN xtraid := oldid
            ELSE xtraid := newid;
            enter(xtraid, newkind, idtable, incrhgt);
            IF fatal THEN GOTO 98; (* fatal error exit *)
            IF debug THEN
              IF growthflag THEN BEGIN
                writeln;
                writeln('Entering ',xtraid.name:xtraid.length);
                dumptable(idtable); END;
            IF flipflag THEN xtraid := newid ELSE xtraid := oldid;
            enter(xtraid, oldkind, idtable, incrhgt);
            IF fatal THEN GOTO 98;  (* fatal error exit *)
            IF debug THEN
              IF growthflag THEN BEGIN
                writeln;
                writeln('Entering ', xtraid.name : xtraid.length);
                dumptable(idtable); END;
            END
          ELSE BEGIN
            writeln('---WARNING: malformed idpair'); error; END;
          END   (* chclass=letter *)
        ELSE IF idpairs^ = '$' THEN BEGIN (* possible option control *)
          get(idpairs);
          IF chclass(idpairs^) = letter THEN BEGIN
            readid(idpairs, newid);
            IF newid = splwd THEN BEGIN (* set spl options *)
              IF language <> pascal THEN GOTO 97; (* one change only *)
              underch := ''''; delim1 := '"'; delim2 := '"';
              language := spl; END
            ELSE IF newid = asm8080wd THEN BEGIN
              (* 8080 assembly options *)
              IF language <> pascal THEN GOTO 97; (* one change only *)
              delim2 := '"'; language := asm8080; END
            ELSE IF newid = cwd THEN BEGIN (* c language options *)
              IF language <> pascal THEN GOTO 97; (* one change only *)
              delim2 := '"'; language := c; END
            ELSE IF (newid = flipwd) AND NOT flipflag THEN
              flipflag := true
            ELSE IF (newid = upshiftwd) AND NOT downshift THEN
              upshift := true
            ELSE IF (newid = downshftwd) AND NOT upshift THEN
              downshift := true
            ELSE GOTO 97; (* bad option is fatal *) END (* letter *)
          ELSE BEGIN (* option error *)
97:         writeln('*** Fatal error, bad option');
            error; fatal := true; GOTO 98; END;
          END (* option control *)
        ELSE BEGIN
          writeln('---WARNING: malformed idpair'); error; END;
        readln(idpairs); linenum := succ(linenum);  END;
      END; (* idpairs exists *)
98: END; (* readidpairsandcreatesymboltable *)

  (* 1---------------1 *)

  PROCEDURE editsourcetotarget;

    LABEL 1, 2;

    VAR
      sourceid    : string;
      lineno      : integer;

    (* 2---------------2 *)

    PROCEDURE substitute(VAR identifier : string; p : nodeptr);

      (* 3---------------3 *)

      PROCEDURE writesourceid;

        BEGIN (* writesourceid *)
        WITH sourceid DO write(target, name: length);
        WHILE chclass(source^) <= under DO BEGIN
          write(target, source^); get(source); END;
        END; (* writesourceid *)

      (* 3---------------3 *)

      BEGIN (* substitute *)
      IF p = NIL THEN (* identifier not in tree, echo *)
        writesourceid
      ELSE IF identifier.name > p^.id.name THEN
        substitute(identifier, p^.right)
      ELSE IF identifier.name < p^.id.name THEN
        substitute(identifier, p^.left)
      ELSE WITH p^ DO            (* found *)
        IF idisold THEN BEGIN
          WITH newptr^.id DO  write(target, name: length);
          WHILE chclass(source^) <= under DO get(source); END
        ELSE BEGIN
          seeninsource := true; writesourceid; END;
      END; (* substitute *)

    (* 2---------------2 *)

    PROCEDURE skipstring(delim : char);

      BEGIN (* skipstring *)
      REPEAT
        write(target, source^); get(source);
      UNTIL (source^ = delim) OR eoln(source);
      IF eoln(source) THEN
        writeln('---WARNING: Unclosed string in source program line ',
                 lineno : 1);
      END; (* skipstring *)

    (* 2---------------2 *)

    PROCEDURE absorbcomment(ender : char); (* ?* ... *? *)

      BEGIN (* absorbcomment *)
      write(target, source^); get(source);
      IF source^ = '*' THEN BEGIN (* comment *)
        REPEAT
          write(target, source^); get(source);
          WHILE source^ <> '*' DO BEGIN
            IF eoln(source) THEN writeln(target)
            ELSE write(target, source^);
            get(source); END;
          write(target, source^); get(source);
        UNTIL source^ = ender;
        write(target, source^); get(source); END;
      END; (* absorbcomment *)

    (* 2---------------2 *)

    BEGIN (* editsourcetotarget *)
    reset(source); rewrite(target); lineno := 0;
    WHILE NOT eof(source) DO BEGIN
      lineno := succ(lineno);
      WHILE NOT eoln(source) DO
        CASE chclass(source^) OF
  letter,
  under:  BEGIN
          readid(source, sourceid);
          IF language = spl THEN
            IF (sourceid = cmntwd) OR (sourceid = cmntwdl) THEN BEGIN
              write(target,sourceid.name : sourceid.length);
              REPEAT
                IF eoln(source) THEN writeln(target)
                ELSE write(target,source^);
                get(source);
              UNTIL source^ = ';'; END
            ELSE substitute(sourceid, idtable)
          ELSE substitute(sourceid, idtable) END;
   digit: REPEAT
            write(target, source^); get(source);
          UNTIL (chclass(source^) <> digit)
                 AND (source^ <> '.')
                 AND (source^ <> 'E')
                 AND (source^ <> 'e');
   quote: BEGIN
          skipstring(delim2);
          IF eoln(source) THEN GOTO 2;
          write(target, source^); get(source);
          END;
   prime: BEGIN
          skipstring(delim1);
          IF eoln(source) THEN GOTO 2;
          write(target, source^); get(source);
          END;
  lbrace: BEGIN                (* stdcomment *)
          IF language <> pascal THEN GOTO 1;
          REPEAT
            IF eoln(source) THEN writeln(target)
            ELSE write(target, source^);
            get(source);
          UNTIL source^ = '}';
          write(target, source^); get(source);
          END;
   slash: BEGIN
          IF language <> c THEN GOTO 1;
          absorbcomment('/');
          END;
  lparen: BEGIN
          IF language <> pascal THEN GOTO 1;
          absorbcomment(')');
          END;
    ltsy: BEGIN (* spl comment *)
          IF language <> spl THEN GOTO 1;
          write(target, source^); get(source);
          IF source^ = '<' THEN BEGIN (* comment *)
            REPEAT
              write(target, source^); get(source);
              WHILE source^ <> '>' DO BEGIN
                IF eoln(source) THEN writeln(target)
                ELSE write(target, source^);
                get(source); END;
              write(target, source^); get(source);
            UNTIL source^ = '>';
            write(target, source^); get(source); END;
          END;
    semi: BEGIN
          IF language <> asm8080 THEN GOTO 1;
          REPEAT    (* absorb 8080 source comment line *)
            write(target, source^); get(source);
          UNTIL eoln(source);
          END;
  indent: BEGIN (* special indentation code *)
          write(target, dle); get(source);
          IF NOT eoln(source) AND (source^ >= ' ') THEN BEGIN
            write(target, source^); get(source); END;
          END;
  other,
  blank,
  special:
  1:      BEGIN
          write(target, source^); get(source);
          END;
        END; (* case, while not eoln *)
  2:  readln(source); writeln(target); END; (* while not eof *)
    END; (* editsourcetotarget *)

  (* 1---------------1 *)

  PROCEDURE checkseeninsource(p : nodeptr);

    BEGIN (* checkseeninsource *)
    IF p <> NIL THEN
      WITH p^ DO BEGIN
      checkseeninsource(left);
      IF idisnew AND NOT idisold THEN
        IF seeninsource THEN BEGIN
          writeln('---WARNING: ', id.name : id.length,
                ' was specified as a new identifier ');
          writeln(' and was also seen in the source'); END;
      checkseeninsource(right) END
    END; (* checkseeninsource *)

  (* 1---------------1 *)

  BEGIN (* id2id *)
  initialize;
  readidpairsandcreatesymboltable;
  IF NOT fatal THEN BEGIN
    IF debug THEN BEGIN
      writeln; writeln;
      writeln(' SYMBOL TABLE CONTENTS');
      dumptable(idtable);
      writeln; END; (* IF display *)
    editsourcetotarget;
    checkseeninsource(idtable); END;
  END. (* id2id *)
4░