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, (612) 376-7290 *) (* University of Minnesota, *) (* Minneapolis, Minn. 55455 USA Copyright (c) 1979 *) (* C.B. Falconer 79/12/04 (203) 281-1438 *) (* 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 *)