Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/P4MAT202.ZIP/P4MSETUP.PAS

Pascal/Delphi Source File | 1985-08-30 | 18.9 KB | 694 lines

PROGRAM p4msetup;
{----------------------------------------------------------------------------}
{
  p4mSetUp.PAS
  Author : Andy Decepida
  Written: 15-Aug-1985

  This program is a companion configuration utility to pFormat.

  p4msetup (pFormat Table Maker) will let you initialize the
  'token' array in pFormat.

  This is meant as an assistance to users who want to change
  pFormat's processing of reserved words.

  Input
     BASE.RES  ::= contains the ISO Pascal reserved words
     EXTNS.RES ::= contains the Turbo Pascal Extensions

  Output (these filenames correspond to the $Include directives
          in pFormat ... therefore, changing them here or at
          the DOS command level will impact your compilation
          of pFormat):

     TBLSIZE.INC ::= contains the VAR declaration of the array 'token'
     TOKEN.INC   ::= contains the init statements of the array 'token'
     EXTNS.INC   ::= contains the statements to handle "type-setting"
                     of reserved words (e.g., "GoToXY" instead of
                     GOTOXY | gotoxy; or ShL instead of shl | SHL)

  Optional Output (the Input files BASE.RES & EXTNS.RES may be
                   reorganized [upper_case'd and alphabetized for
                   BASE.RES and as is for EXTNS.RES]
                   into BASE.$$$ & EXTNS.$$$ respectively)
                   When you are satisfied with these output
                   files (review 'em carefully, then you can
                   copy them to BASE.RES or EXTNS.RES for your
                   next session with p4mSetUp.PAS for which you
                   might want to carry over the results of your
                   session.

  Changing Your Tables:
    Prior to running p4msetup.pas:
      - if you wanted to expand or contract the table you should
        use copies of BASE.RES & EXTNS.RES files in the current
        directory in which you'll be running p4msetup.
      - edit either BASE.RES or EXTNS.RES to suit your taste.
        Remember, these files contain the words which will
        be recognized as "reserved" words in your compiled
        version of pFormat ... at your pleasure.
}
{----------------------------------------------------------------------------}
CONST
{----------------------------------------------------------------------------}
  baseipt    = 'BASE.RES';
  extnsipt   = 'EXTNS.RES';
  varout     = 'TBLSIZE.INC';
  tokenout   = 'TOKEN.INC';
  extnout    = 'EXTNS.INC';
  newbaseout = 'BASE.$$$';
  newextnout = 'EXTNS.$$$';
  apostrophe = '''';
  semicolon  = ';';
  space      = ' ';
  nullstr    = '';
{----------------------------------------------------------------------------}
TYPE
{----------------------------------------------------------------------------}
  dtstr      = STRING[8];
  register   = RECORD
                 ax,bx,cx,dx,bp,si,di,ds,es,flags : INTEGER;
               END;
  s255  = STRING[255];
  entryptr = ^entry;
  entry = RECORD
            wordstrg : s255;
            iso      : BOOLEAN;
            next     : entryptr;
          END; {entry}
{----------------------------------------------------------------------------}
VAR
{----------------------------------------------------------------------------}
  basef,
  extnf,
  newbase,
  newextns,
  tokenf,
  extensf,
  varf : TEXT;
  headentry,
  currentry,
  preventry,
  newentry : entryptr;
  linebuf,
  currword,
  wordbuf : s255;
  date,
  time    : dtstr;
  cnt,
  arraylen: INTEGER;
  found,
  firstpass,
  greater,
  base    : BOOLEAN;
{----------------------------------------------------------------------------}
FUNCTION yes : BOOLEAN;
{----------------------------------------------------------------------------}
CONST
  bks = 8;

VAR
  c : CHAR;
BEGIN
  c := ' ';
  WRITE ('[ ]', CHR(bks), CHR(bks),' ', CHR(bks));
    REPEAT
    READ  (KBD, c);
    c := UpCase(c);
    IF NOT (c IN ['Y','N'])
    THEN
      BEGIN
      Sound (300);
      Delay (60);
      NoSound;
      Sound (950);
      Delay (100);
      NoSound
      END;
   UNTIL c IN ['Y','N'];
 yes := c = 'Y';
END;
{----------------------------------------------------------------------------}
FUNCTION getdate : dtstr;
{----------------------------------------------------------------------------}
VAR
  allregs : register;
  month, day,
  year    : STRING[2];
  i       : INTEGER;
  tstr    : dtstr;

BEGIN
  allregs.ax := $2A * 256;
  MsDos(allregs);
  Str((allregs.dx DIV 256): 2,month);
  Str((allregs.dx MOD 256): 2,day);
  Str((allregs.cx - 1900): 2,year);
  tstr := month + '-' + day + '-' + year;
  FOR i := 1 TO 8
  DO
    IF tstr[i] = ' '
    THEN
      tstr[i] := '0';
  getdate := tstr;
END;  {getdate}
{----------------------------------------------------------------------------}
FUNCTION gettime : dtstr;
{----------------------------------------------------------------------------}
VAR
  allregs : register;
  hour, minute,
  second  : STRING[2];
  i       : INTEGER;
  tstr    : dtstr;

BEGIN
  allregs.ax := $2C * 256;
  MsDos(allregs);
  Str((allregs.cx DIV 256): 2,hour);
  Str((allregs.cx MOD 256): 2,minute);
  Str((allregs.dx DIV 256): 2,second);
  tstr := hour + ':' + minute + ':' + second;
  FOR i := 1 TO 8
  DO
    IF tstr[i] = ' '
    THEN
      tstr[i] := '0';
 gettime := tstr;
END;  {gettime}
{----------------------------------------------------------------------------}
FUNCTION datime : s255;
{----------------------------------------------------------------------------}
BEGIN
  date   := getdate;
  time   := gettime;
  datime := '  (*  -- Generated by p4mSetUp on '+date+' '+time+' -- *)';
END;
{----------------------------------------------------------------------------}
FUNCTION trim (strg : s255) : s255;
{----------------------------------------------------------------------------}
VAR
  j : INTEGER;
BEGIN
  WHILE (Pos(space,strg) <> 0)
  DO
    Delete (strg,Pos(space,strg),1);
  trim := strg;
END;
{----------------------------------------------------------------------------}
FUNCTION upper (strg : s255) : s255;
{----------------------------------------------------------------------------}
VAR
  j : INTEGER;

BEGIN
  FOR j := 1 TO Length (strg)
  DO
    strg[j] := UpCase(strg[j]);
  upper := strg;
END;
{----------------------------------------------------------------------------}
FUNCTION locase (c:CHAR) : CHAR;
{----------------------------------------------------------------------------}
BEGIN
  IF c IN ['A'..'Z']
  THEN
    c := CHR(ORD(c) - ORD('A') + ORD('a'));
  locase := c
END;
{----------------------------------------------------------------------------}
FUNCTION lower (strg : s255) : s255;
{----------------------------------------------------------------------------}
VAR
  j : INTEGER;

BEGIN
  FOR j := 1 TO Length (strg)
  DO
    strg[j] := locase(strg[j]);
  lower := strg;
END;
{----------------------------------------------------------------------------}
PROCEDURE load;
{----------------------------------------------------------------------------}
PROCEDURE search;
{----------------------------------------------------------------------------}
BEGIN
  preventry := NIL;
  currentry  := headentry;
  greater  := TRUE;
  WHILE (currentry <> NIL) AND greater
  DO
    BEGIN
    IF wordbuf > currentry^.wordstrg
    THEN
      BEGIN
      preventry := currentry;
      currentry  := currentry^.next;
      END
    ELSE
      IF wordbuf = currentry^.wordstrg
      THEN
        BEGIN
        found := TRUE;
        greater := FALSE;
        END
      ELSE
        greater := FALSE;
    END;
END;
{----------------------------------------------------------------------------}
PROCEDURE insrt;
{----------------------------------------------------------------------------}
BEGIN {insrt}
  IF preventry = NIL
  THEN
    BEGIN
    newentry^.next := headentry;
    headentry := newentry;
    END
  ELSE
    IF currentry <> NIL
    THEN
      BEGIN
      preventry^.next := newentry;
      newentry^.next  := currentry;
      END
    ELSE
      BEGIN
      preventry^.next := newentry;
      newentry^.next  := NIL;
      END;
  END;
{----------------------------------------------------------------------------}
FUNCTION duplicate : BOOLEAN;
{----------------------------------------------------------------------------}
BEGIN
  found := FALSE;
  search;
  duplicate := found;
END;
{----------------------------------------------------------------------------}
PROCEDURE actual_load;
{----------------------------------------------------------------------------}
BEGIN
  NEW (newentry);
  newentry^.wordstrg := wordbuf;
  newentry^.iso := base;
  found := FALSE;
  search;
  insrt;
END;

BEGIN {load}
  wordbuf := trim(wordbuf);
  IF firstpass
  THEN
    BEGIN
    firstpass := FALSE;
    actual_load;
    END
  ELSE
    IF NOT duplicate
    THEN
      actual_load
END; {load}
{----------------------------------------------------------------------------}
FUNCTION spaces (cnt : INTEGER) : s255;
{----------------------------------------------------------------------------}
VAR
  j : INTEGER;
  s : s255;

BEGIN
  s := nullstr;
  FOR j := 1 TO cnt
  DO
    s := s + space;
  spaces := s;
END;
{----------------------------------------------------------------------------}
FUNCTION cnt2int(x : INTEGER) : s255;
{----------------------------------------------------------------------------}
VAR
  tmps : s255;
BEGIN
  Str (x:5, tmps);
  WHILE tmps[1] = space
  DO
    Delete (tmps,1,1);
  cnt2int := tmps;
END;
{----------------------------------------------------------------------------}
FUNCTION token (currs : s255) : s255;
{----------------------------------------------------------------------------}

VAR
  tmps : s255;
  tmpi : INTEGER;
BEGIN
  tmps := nullstr;
  tmps := (spaces(2)+'Token ['+cnt2int(cnt));
  tmpi := Length(tmps);
  tmps := tmps+']'+spaces(14-tmpi)+':= '+
          apostrophe+upper(currs)+apostrophe+semicolon;
  token := tmps;
END;
{----------------------------------------------------------------------------}
FUNCTION extension (currs : s255) : s255;
{----------------------------------------------------------------------------}
VAR
  tmps : s255;
  tmpi : INTEGER;
BEGIN
  tmps := nullstr;
  tmps := cnt2int(cnt)+' : Extension := ';
  tmpi := Length(tmps);
  currs[1] := UpCase(currs[1]);
  tmps := spaces(22-tmpi)+tmps+spaces(1)+
          apostrophe+currs+apostrophe+semicolon;
  extension := tmps;
END;
{----------------------------------------------------------------------------}
PROCEDURE evalio (fnam : s255);
{----------------------------------------------------------------------------}
VAR
  iores : INTEGER;
BEGIN
  iores := IOResult;
  IF iores <> 0
  THEN
    BEGIN
    WRITE (' File ',fnam,' could NOT be opened ... aborting');
    HALT
    END
END;
{----------------------------------------------------------------------------}
PROCEDURE read_iso_reserved_words;
{----------------------------------------------------------------------------}
BEGIN
  WRITE ('  ■ Loading the ISO Pascal Reserved Words from BASE.RES ');
  Assign (basef, baseipt);
  {$I-}
  RESET  (basef);
  {$I+}
  evalio (baseipt);
  { load from base }
  base := TRUE;
  headentry := NIL;
  WHILE NOT EOF(basef)
  DO
    BEGIN
    READLN (basef, linebuf);
    wordbuf := upper(Copy(linebuf,1,20));
    WRITE ('.');
    IF Length(wordbuf) <> 0
    THEN
      load;
    END;
  Close (basef);
  WRITELN;
  WRITELN;
END;
{----------------------------------------------------------------------------}
PROCEDURE read_extensions;
{----------------------------------------------------------------------------}
BEGIN
  WRITE ('  ■ Loading the Pascal Extensions from EXTNS.RES  ');
  Assign (extnf, extnsipt);
  {$I-}
  RESET  (extnf);
  {$I+}
  evalio (extnsipt);
  { load from extensions }
  base := FALSE;
  firstpass := FALSE;
  WHILE NOT EOF(extnf)
  DO
    BEGIN
    READLN (extnf, linebuf);
    wordbuf := Copy(linebuf,1,20);
    WRITE ('.');
    IF Length(wordbuf) <> 0
    THEN
      load
    END;
  Close  (extnf);
  WRITELN;
  WRITELN;
END;
{----------------------------------------------------------------------------}
PROCEDURE write_token;
{----------------------------------------------------------------------------}
BEGIN
  Assign (tokenf, tokenout);
  REWRITE(tokenf);
  base := FALSE;
  cnt := 0;
  currentry  := headentry;
  WRITE ('  ■ Writing ',tokenout);
  WRITELN (tokenf,datime);
  WHILE currentry <> NIL
  DO
    BEGIN
    currword := currentry^.wordstrg;
    cnt := cnt + 1;
    WRITELN (tokenf, token (currword));
    WRITE ('.');
    currentry := currentry^.next;
    END;
  Close (tokenf);
END;
{----------------------------------------------------------------------------}
PROCEDURE write_declaration;
{----------------------------------------------------------------------------}
BEGIN
  arraylen := cnt;
  Assign (varf, varout);
  WRITELN ('  ■ Writing ',varout);
  WRITELN ('    The Array is ',arraylen,' entries long.');
  REWRITE (varf);
  WRITELN (varf,datime);
  WRITELN (varf,'  tbl_size = ',cnt2int(arraylen),semicolon);
  Close   (varf);
END;
{----------------------------------------------------------------------------}
PROCEDURE write_extensions;
{----------------------------------------------------------------------------}
  VAR
    compstr,
    holdstr,
    tmpstr,
    currword,
    newstr : s255;
    done   : BOOLEAN;
    tmplen,
    inlen  : INTEGER;
{----------------------------------------------------------------------------}
PROCEDURE alter_extensions;
{----------------------------------------------------------------------------}
PROCEDURE query_user;
{----------------------------------------------------------------------------}
BEGIN
  WRITELN;
  WRITE (' Type in new word ,');
  WRITE ('or press <CR> to leave unchanged ',currword, ' -> ');
  newstr := '';
  done   := FALSE;
  READLN (newstr);
  newstr := trim(newstr);
  inlen  := Length(newstr);
  IF inlen <> 0
  THEN
    BEGIN {non null string}
    IF upper(currword) = upper(newstr)
    THEN
      BEGIN
      WRITE (' -- Change ',currword,' to ',newstr,' -> ');
      currword := newstr;
      done     := yes;
      IF NOT done
      THEN
        BEGIN
        newstr   := holdstr;
        currword := holdstr;
        END
      ELSE {done}
        BEGIN
        {do nothing}
        END
      END
    ELSE      {despite undue CASE & spacing influence}
      BEGIN   {the keyed-in string was found to be too different}
      WRITELN (CHR(7));
      WRITELN (' ■ ',newstr,' radically differs from ',
                     currword,' ... be careful.  RETRY');
      done := FALSE;
      newstr := holdstr;
      currword := holdstr;
      END
    END {non null string}
  ELSE
    BEGIN {null string}
    newstr := currword;
    done   := TRUE;
    END;
END;

BEGIN
  WRITELN;
  currentry := headentry;
  cnt := 0;
  WRITELN;
  WRITELN (' You have the option of changing the Case-Mix of the Extensions now or');
  WRITELN ('   later, on your own --- manually with an editor ');
  WRITELN;
  WHILE currentry <> NIL
  DO
    BEGIN
    currword := currentry^.wordstrg;
    IF NOT currentry^.iso
    THEN
      BEGIN
      currword[1] := UpCase(currword[1]);
      holdstr     := currword;
      WRITELN ('---');
      done := FALSE;
      inlen := Length(newstr);
      WHILE NOT done
      DO
        query_user;
      WRITELN;
      currentry^.wordstrg := newstr;
      END;
      currentry := currentry^.next;
    END;
END;

BEGIN
  Assign (extensf, extnout);
  REWRITE(extensf);
  alter_extensions;
  cnt := 0;
  currentry  := headentry;
  WRITELN;
  WRITE ('  ■ Writing ',extnout);
  WRITELN (extensf,datime);
  WHILE currentry <> NIL
  DO
    BEGIN
    currword := currentry^.wordstrg;
    cnt := cnt +1;
    IF NOT currentry^.iso
    THEN
      BEGIN
      currword := currword;
      WRITELN (extensf, extension(currword));
      WRITE ('.');
      END;
    currentry := currentry^.next;
    END;
  Close (extensf);
END;
{----------------------------------------------------------------------------}
PROCEDURE reorg_inputs;
{----------------------------------------------------------------------------}
BEGIN
  WRITELN;
  WRITE ('   Write to BASE.$$$ & EXTNS.$$$ respectively ? ');
  IF NOT yes
  THEN
    BEGIN
    WRITELN (' Very well ... bye ');
    Exit;
    END;
  Assign (newbase, newbaseout);
  REWRITE(newbase);
  Assign (newextns,newextnout);
  REWRITE(newextns);
  currentry := headentry;
  WRITELN;
  WRITELN;
  WRITELN ('       Reorganization of Input files BASE.RES & EXTNS.RES ');
  WRITELN;
  WRITELN ('   This will prune (remove duplicates within and across files,');
  WRITELN ('   ensure alphabetic sequence & proper cases).');
  WRITELN;
  WRITE   ('   Making BASE.$$$ & EXTNS.$$$');
  WHILE currentry <> NIL
  DO
    BEGIN
    currword := currentry^.wordstrg;
    cnt := cnt +1;
    WRITE ('.');
    IF currentry^.iso
    THEN
      WRITELN (newbase,currword)
    ELSE
      WRITELN (newextns,currword);
    currentry := currentry^.next;
    END;
  Close (newbase);
  Close (newextns);
END;
{----------------------------------------------------------------------------}
PROCEDURE banner;
{----------------------------------------------------------------------------}
BEGIN
  WRITELN;
  WRITELN ('┌───────────────────────────────┐');
  WRITELN ('│   p4mSetUp ─ Andy Decepida    │');
  WRITELN ('└───────────────────────────────┘');
  WRITELN;
  date := getdate;
  time := gettime;
  WRITELN ('  Run Date : ',date,' ',time);
  WRITELN (CHR(7));
  WRITELN ('┌───────────────────────────────┐');
  WRITELN ('│       ■■■ WARNING ■■■         │');
  WRITELN ('├───────────────────────────────┤');
  WRITELN ('│ Since p4mSetUp will generate  │');
  WRITELN ('│ the new versions of the files │');
  WRITELN ('│         TOKEN.INC,            │');
  WRITELN ('│         EXTNS.INC             │');
  WRITELN ('│     and TBLSIZE.INC,          │');
  WRITELN ('│ which are required to compile │');
  WRITELN ('│ pFormat.PAS, you should not   │');
  WRITELN ('│ run THIS program with copies  │');
  WRITELN ('│ of those files in the current │');
  WRITELN ('│ directory.                    │');
  WRITELN ('└───────────────────────────────┘');
  WRITELN;
  WRITE   ('    Continue ? [y/n] ');
  IF yes
  THEN
    BEGIN
    WRITELN;
    WRITELN;
    WRITE ('This is your LAST ');
    WRITELN ('chance to backout of this run');
    WRITELN;
    WRITE ('Proceed ? [y/n] ');
    IF NOT yes
    THEN
      HALT
    END
  ELSE
    HALT;
END;
{────────────────────────────────────────────────────────────────────────────}
BEGIN
  firstpass := TRUE;
  LowVideo;
  banner;
  WRITELN;
  read_iso_reserved_words;
  read_extensions;
  write_token;
  write_extensions;
  write_declaration;
  reorg_inputs;
END.