home *** CD-ROM | disk | FTP | other *** search
/ Shareware Supreme Volume 6 #1 / swsii.zip / swsii / 167 / P4MAT202.ZIP / PFORMAT.PAS < prev    next >
Pascal/Delphi Source File  |  1985-08-30  |  37KB  |  1,239 lines
  1.  
  2. PROGRAM pformat (INPUT, OUTPUT);
  3.  
  4. {----------------------------------------------------------------------------}
  5. { Compiler Directives Follow                                                 }
  6. {$X+} {Array Optimization ON ... This PGM is Very-Much-So Array Driven}
  7. {$U-} {Non-User-Interruptible}
  8. {$K-} {NO Stack Checking}
  9. {$C-} {KeyBoard CTRL-<char> Interp OFF}
  10. {$R-} {NO Index Range Checking}
  11. {$V-} {Var Parameter Type Checking OFF}
  12. {----------------------------------------------------------------------------}
  13.  
  14. { ========================================================================
  15.  
  16.   pFORMAT version 2.0.2
  17.   ~~~~~~~~~~~~~~~~~~~~~
  18.   AUTHOR:  andy j s decepida 26-AUG-85
  19.            416 Perth Avenue, Toronto, Ontario, CANADA   M6P 3Y6
  20.  
  21.   DESCRIPTION: Reads in a .PAS text file and, depending on the user's
  22.                choice/s, generates a copy with alterations in the case of
  23.                the contained text.
  24.   Modifications
  25.          (2.0.0) : File Attributes routine has been changed;
  26.                    prior algorithm worked only for Turbo Pascal
  27.                    compiler release 2.xx; the current one accomodates
  28.                    both 2.xx & 3.xx;
  29.          (2.0.0) : Reserved Words Table has been expanded to accomodate
  30.                    new ones in Turbo Pascal 3.0;
  31.          (2.0.1) : Disabled Routing to Printer which was primitive (no
  32.                    Pagination) anyway;
  33.          (2.0.1) : Added handling of hexadecimal literals
  34.                    (preceded by '$' and composed of '0'..'9', 'A'..'F')
  35.                    --- these literals will be made uppercase (only letters
  36.                    'A'..'F' of course)
  37.          (2.0.1) : Added handling of CommandLine Parameters
  38.                    When present, the 1st Parm is the InputFile
  39.                                  the 2nd Parm is the OutputFile
  40.          (2.0.2) : Prior versions would mishandle a line that has
  41.                    more than one comment in it ... the comment/s subsequent
  42.                    to the first is/are treated as executable; this has
  43.                    been corrected.
  44.          (2.0.2) : Corrected an incipient bug in keypress-to-signal-run-abort
  45.                    option (scenario: when option is active and the user,
  46.                    intentionally or not, presses key "Y" the abort-confirm
  47.                    hesitation query would already have been answered);
  48.                    Correction implemented by changing function getc to
  49.                    use the DOS call $0C to clear KBD buffer then let the
  50.                    same chain to DOS call $07 (stdin w/o input)
  51.  
  52.     As distributed, the source for pFORMAT.PAS has been submitted to pformat
  53.     itself.  All ISO-PASCAL words are in caps and the Turbo-Extensions are
  54.     in mixed-case while user-defined words are in lower-case.
  55.  
  56.     I am also providing this source indented following the laudable indenting
  57.     guidelines suggested by Robert E. Heckert in his article "A Pascal
  58.     Indentation Philosophy" published in Computer Language magazine of
  59.     Sept 1985 (v2,#9).
  60.  
  61.   ======================================================================= }
  62.  
  63. CONST
  64.   {$I tblsize.inc}
  65.   alphabet    :  SET OF CHAR = ['a'..'z', 'A'..'Z'];
  66.   nullstr     =  '';
  67.   space       =  ' ';
  68.   apostrophe  =  '''';
  69.   period      =  '.';
  70.   stdextns    =  '.PAS';
  71.  
  72. TYPE
  73.   charset     =  SET OF CHAR;
  74.   cursorsize  =  (full, half, normal, invisible);
  75.   s255        =  STRING[255];
  76.   casetype    =  (upper, lower, asis);
  77.  
  78. VAR
  79.   iobuf, linebuf, legend, mask,
  80.   srcharg, tempstr, infnam,
  81.   outfnam     : s255;
  82.   inf,
  83.   outf        : TEXT[$1000];
  84.   token       : ARRAY [1..tbl_size] OF STRING[20];
  85.   case4reserved,
  86.   case4nonreserved: casetype;
  87.   strt, endd, posn, indx,
  88.   parmcnt,
  89.   len, cnt    : INTEGER;
  90.   reservedcount,
  91.   linecount, charcount,
  92.   commentcount: REAL;
  93.   resp, prior,
  94.   next        : CHAR;
  95.   mixedcase, abortable,
  96.   commentactive, tokenfound,
  97.   ok          : BOOLEAN;
  98. {-----------------------------------------------------------------------------}
  99. PROCEDURE initarray;
  100. {-----------------------------------------------------------------------------}
  101. {
  102. initialize the reserved word array
  103. }
  104. BEGIN
  105.   {$I TOKEN.INC}
  106. END;  {initarray}
  107. {-----------------------------------------------------------------------------}
  108. PROCEDURE makecursor (size : cursorsize);
  109. {-----------------------------------------------------------------------------}
  110. {
  111. crsr is set according to the passed Size ... IBM-PC specific!
  112. }
  113. TYPE
  114.   regpack    =  RECORD
  115.                 ax, bx, cx, dx, bp, si, di, es, flags : INTEGER;
  116.                 END; {of RegPack}
  117. VAR
  118.   reg        :  regpack;
  119.  
  120. BEGIN
  121.   reg.ax     := $0100;     {set crsr type service code ... cf A-47 of
  122.                               Hardware Technical Reference Manual}
  123.   CASE size OF
  124.     full     : reg.cx := $000D;
  125.     half     : reg.cx := $070C;
  126.     normal   : reg.cx := $0B0C;
  127.     invisible: reg.cx := $2000
  128.   END; {CASE Size OF}
  129.   Intr ($10, reg)          {call video I/O ROM call}
  130. END;
  131. {-----------------------------------------------------------------------------}
  132. FUNCTION isdelimited (ch : CHAR) : BOOLEAN;
  133. {-----------------------------------------------------------------------------}
  134. {
  135. TRUE if Ch is a valid delimiter for a substring pattern that matches that
  136. of a reserved word
  137. }
  138. BEGIN
  139.   isdelimited := (ORD(ch) IN [32, 39..47, 58..62, 91, 93, 123, 125])
  140. END;
  141. {-----------------------------------------------------------------------------}
  142. FUNCTION lowcase (ch : CHAR) : CHAR;
  143. {-----------------------------------------------------------------------------}
  144. {
  145. returns lower case of an alpha char
  146. }
  147. BEGIN
  148.   IF (ch IN ['A'..'Z'])
  149.   THEN
  150.     ch := CHR (ORD(ch) - ORD('A') + ORD('a'));
  151.   lowcase := ch
  152. END;
  153. {-----------------------------------------------------------------------------}
  154. FUNCTION upstrg (strg : s255) : s255;
  155. {-----------------------------------------------------------------------------}
  156. {
  157. returns a string with alpha chars in capitals
  158. }
  159. VAR
  160.   slot : INTEGER;
  161. BEGIN
  162.   FOR slot := 1 TO Length(strg)
  163.   DO
  164.     strg[slot] := UpCase(strg[slot]);
  165.   upstrg := strg
  166. END;
  167. {-----------------------------------------------------------------------------}
  168. FUNCTION lowstrg (strg : s255) : s255;
  169. {-----------------------------------------------------------------------------}
  170. {
  171. returns a string with alpha chars in lower-case
  172. }
  173. VAR
  174.   slot : INTEGER;
  175. BEGIN
  176.   FOR slot := 1 TO Length(strg)
  177.   DO
  178.     strg[slot] := lowcase(strg[slot]);
  179.   lowstrg := strg;
  180. END;
  181. {-----------------------------------------------------------------------------}
  182. PROCEDURE alarm;
  183. {-----------------------------------------------------------------------------}
  184. {
  185. ! sounds an alarm
  186. }
  187. BEGIN
  188.   Sound (100);
  189.   Delay (60);
  190.   NoSound;
  191.   Sound (50);
  192.   Delay (3);
  193.   NoSound
  194. END;
  195. {-----------------------------------------------------------------------------}
  196. FUNCTION getc (legalchar : charset) : CHAR;
  197. {-----------------------------------------------------------------------------}
  198. {
  199. waits for a CHAR input belonging in set legalchar, we are using
  200. a DOS service call because we need a workaround to the bug
  201. described in the prologue comment regarding keypress-to-signal-run-abort
  202. feature
  203. }
  204. TYPE
  205.   regpack    =  RECORD
  206.                 ax, bx, cx, dx, bp, si, di, es, flags : INTEGER;
  207.                 END; {of RegPack}
  208. CONST
  209.   bks = 8;
  210. VAR
  211.   inchr : CHAR;
  212.   reg   : regpack;
  213.  
  214. BEGIN
  215.   WRITE  ('[ ]');
  216.   WRITE  (CHR(bks), CHR(bks), space,CHR(bks));
  217.     REPEAT
  218.     makecursor (full);
  219.     reg.ax := $0C07;  {Clear keyboard buffer & invoke DOS stdin w/o echo}
  220.     MsDos (reg);
  221.     inchr := CHR(Lo(reg.ax));
  222.     inchr := UpCase (inchr);
  223.     IF NOT (inchr IN legalchar)
  224.     THEN
  225.       alarm;
  226.     UNTIL (inchr IN legalchar);
  227.   makecursor (normal);
  228.   getc := inchr
  229. END;
  230. {-----------------------------------------------------------------------------}
  231. FUNCTION yes : BOOLEAN;
  232. {-----------------------------------------------------------------------------}
  233. {
  234. waits for a y/Y or n/N CHAR input
  235. }
  236. VAR
  237.   reply : CHAR;
  238. BEGIN
  239.   WRITE (' [y/n] ■ ');
  240.   LowVideo;
  241.   yes := (getc(['Y','N']) = 'Y')
  242. END;
  243. {-----------------------------------------------------------------------------}
  244. PROCEDURE trim (VAR tempstr : s255);
  245. {-----------------------------------------------------------------------------}
  246. {
  247. strip leading spaces from a string
  248. }
  249. BEGIN
  250.   WHILE Pos(space, tempstr) = 1
  251.   DO
  252.     Delete (tempstr, 1, 1)
  253. END;
  254. {-----------------------------------------------------------------------------}
  255. PROCEDURE userquits;
  256. {-----------------------------------------------------------------------------}
  257. {
  258. when the pgm gets here, the user has indicated his/her intentions
  259. }
  260. BEGIN
  261.   Window (1,1,80,25);
  262.   GoToXY (1, 1);
  263.   LowVideo;
  264.   makecursor (normal);
  265.   ClrScr;
  266.   {$I-}
  267.   Close (inf);
  268.   Close (outf);
  269.   {$I+}
  270.   HALT
  271. END;
  272. {-----------------------------------------------------------------------------}
  273. PROCEDURE confirm (confirmation : s255; reserved : BOOLEAN);
  274. {-----------------------------------------------------------------------------}
  275. {
  276. evaluate / confirm user's pick
  277. }
  278. PROCEDURE setto (userchoice : casetype);
  279. {-----------------------------------------------------------------------------}
  280. {
  281. "setto" is nested in confirm !!!
  282. change case4reserved & case4nonreserved settings as per userchoice
  283. }
  284. BEGIN
  285.   IF reserved
  286.   THEN
  287.     case4reserved := userchoice
  288.   ELSE
  289.     case4nonreserved := userchoice
  290. END;
  291.  
  292. BEGIN {confirm}
  293.   WRITELN;
  294.   WRITE (' You chose ');
  295.   TextColor (Black);
  296.   TextBackGround (White);
  297.   CASE resp OF
  298.     'U' : BEGIN
  299.           WRITE ('Upper-case');
  300.           setto (upper)
  301.           END;
  302.     'L' : BEGIN
  303.           WRITE ('Lower-case');
  304.           setto (lower)
  305.           END;
  306.     'A' : BEGIN
  307.           WRITE ('As-Is');
  308.           setto (asis)
  309.           END;
  310.     'Q' : userquits
  311.   END; {CASE}
  312.   LowVideo;
  313.   WRITELN (space,confirmation);
  314.   WRITE (' Is this correct? ')
  315. END; {confirm}
  316. {-----------------------------------------------------------------------------}
  317. PROCEDURE altersettings;
  318. {-----------------------------------------------------------------------------}
  319. BEGIN {altersettings}
  320.   WRITELN;
  321.     REPEAT
  322.     WRITELN; WRITELN;
  323.     WRITELN (' ■ PASCAL reserved words.');
  324.     WRITE ('   Options are : U(pper-case, L(ower-case, A(s-Is, Q(uit');
  325.     resp := getc (['U','L','A','Q']);
  326.     confirm ('for the RESERVED words.', TRUE)
  327.     UNTIL yes;
  328.   WRITELN;   WRITELN; WRITELN;
  329.   WRITELN (' ■ Turbo Pascal Extensions.');
  330.   WRITELN ('   Would you like to have the Borland extensions written ');
  331.   WRITELN ('      in "Mixed Case" (e.g., "GotoXY" instead of "GOTOXY"');
  332.   WRITE   ('      or "gotoxy"?');
  333.   mixedcase := yes;
  334.   WRITELN;
  335.     REPEAT
  336.     WRITELN;  WRITELN;
  337.     WRITELN (' ■ Non-Reserved Words.');
  338.     WRITE ('   Options are : U(pper-case, L(ower-case, A(s-is, Q(uit');
  339.     resp := getc (['U','L','A','Q']);
  340.     confirm (' for the user defined identifiers.',FALSE);
  341.     UNTIL yes
  342. END; {altersettings}
  343. {-----------------------------------------------------------------------------}
  344. PROCEDURE makemixedcase (VAR extension : s255);
  345. {-----------------------------------------------------------------------------}
  346. {
  347. when user selects the option for mixed-case formatting of reserved words,
  348. this proc will be invoked;
  349. }
  350. BEGIN {makemixedcase}
  351.   CASE indx OF
  352.    {$I EXTNS.INC}
  353.   END; {CASE Indx OF}
  354. END;   {makemixedcase}
  355. {-----------------------------------------------------------------------------}
  356. PROCEDURE findmatch;
  357. {-----------------------------------------------------------------------------}
  358. VAR
  359.   place : INTEGER;
  360. {-----------------------------------------------------------------------------}
  361. FUNCTION isreserved : BOOLEAN;
  362. {-----------------------------------------------------------------------------}
  363. {
  364. returns true if token is properly delimited
  365. }
  366. BEGIN
  367.   IF (place + Length(token[indx])) < len
  368.   THEN                                              { there is at least 1  }
  369.     next := Copy(linebuf,                         { more character beyond  }
  370.                 (place + (Length(token[indx]))), 1)    { the pattern match }
  371.   ELSE
  372.     next := period;             {the pattern match is end of the line ...so}
  373.                                        {force Next to be a valid delimiter }
  374.   IF place > 1
  375.   THEN                       { the pattern is not at the start of the line }
  376.     BEGIN
  377.     prior := Copy(linebuf, place - 1, 1);
  378.     isreserved := ((isdelimited(prior)) AND (isdelimited(next)))
  379.     END
  380.   ELSE
  381.     IF place = 1
  382.     THEN                   { the pattern is at the start of the line }
  383.       isreserved := (isdelimited(next))
  384. END;
  385. {-----------------------------------------------------------------------------}
  386. PROCEDURE doreserved;
  387. {-----------------------------------------------------------------------------}
  388. BEGIN
  389.   reservedcount := reservedcount + 1;
  390.   srcharg       := token[indx];
  391.   CASE case4reserved OF
  392.     lower  : BEGIN
  393.              Delete (iobuf, place, Length(token[indx]));
  394.              srcharg := lowstrg (srcharg);
  395.              IF mixedcase
  396.              THEN
  397.                makemixedcase (srcharg);
  398.              Insert (srcharg, iobuf, place)
  399.              END;
  400.     upper  : BEGIN
  401.              Delete (iobuf, place, Length(token[indx]));
  402.              IF mixedcase
  403.              THEN
  404.                makemixedcase (srcharg);
  405.              Insert (srcharg, iobuf, place)
  406.              END;
  407.     asis  : IF mixedcase
  408.              THEN
  409.                BEGIN
  410.                Delete (iobuf, place, Length(token[indx]));
  411.                makemixedcase (srcharg);
  412.                Insert (srcharg, iobuf, place)
  413.                END
  414.   END {CASE case4reserved OF}
  415. END;
  416. {-----------------------------------------------------------------------------}
  417. PROCEDURE searchtable (arg : s255; VAR key : INTEGER; VAR found : BOOLEAN);
  418. {-----------------------------------------------------------------------------}
  419. {
  420. this is your basic binary table search algorithm ... no magic here
  421. }
  422. VAR
  423.   lohalf,
  424.   uphalf,
  425.   centre    : INTEGER;
  426.  
  427. BEGIN {searchtable}
  428.   lohalf := 1;
  429.   uphalf := tbl_size;
  430.   found  := FALSE;
  431.   WHILE (uphalf >= lohalf) AND (NOT found)
  432.   DO
  433.     BEGIN
  434.     centre := (lohalf + uphalf) DIV 2;
  435.     IF arg = token[centre]
  436.     THEN
  437.       BEGIN
  438.       found := TRUE;
  439.       key   := centre
  440.       END
  441.     ELSE
  442.       IF arg > token[centre]
  443.       THEN
  444.         lohalf := centre + 1
  445.       ELSE
  446.         uphalf := centre - 1
  447.     END {WHILE}
  448. END; {searchtable}
  449. {-----------------------------------------------------------------------------}
  450. PROCEDURE buildarg;
  451. {-----------------------------------------------------------------------------}
  452. {
  453. step thru the string until a non-alphabetic char is encountered
  454. }
  455. VAR
  456.   done : BOOLEAN;
  457.  
  458. BEGIN {buildarg}
  459.   REPEAT
  460.   IF linebuf[posn] IN alphabet
  461.   THEN
  462.     srcharg := srcharg + linebuf[posn];
  463.   done := ((NOT (linebuf[posn] IN alphabet)) OR (posn = len));
  464.   IF NOT done
  465.   THEN
  466.     posn := SUCC(posn);
  467.   UNTIL done
  468. END;  {buildarg}
  469.  
  470. {-------------------------------------------}
  471. BEGIN {findmatch}
  472.   posn := 1;
  473.     REPEAT                                   {till the string is exhausted}
  474.     srcharg := nullstr;
  475.     place := posn;
  476.     buildarg;
  477.     IF Length(srcharg) > 1
  478.     THEN
  479.       BEGIN
  480.       searchtable (srcharg, indx, tokenfound);
  481.       IF tokenfound AND (isreserved)
  482.       THEN
  483.         doreserved
  484.       END
  485.     ELSE
  486.       posn := SUCC(posn)
  487.     UNTIL posn > len;
  488.   IF abortable
  489.   THEN                              {check for interrupt from keyboard}
  490.     IF KeyPressed
  491.     THEN
  492.       BEGIN
  493.       TextColor (Yellow);
  494.       TextBackGround (Black);
  495.       GoToXY (15, 11);
  496.       WRITE ('Abort pFORMAT of file ',infnam,'?');
  497.       IF yes
  498.       THEN
  499.         userquits
  500.       ELSE
  501.         BEGIN
  502.         DelLine;
  503.         makecursor (invisible)
  504.         END
  505.       END;
  506.   LowVideo
  507. END;  {findmatch}
  508. {-----------------------------------------------------------------------------}
  509. PROCEDURE mask_comments_strings;
  510. {-----------------------------------------------------------------------------}
  511. {
  512. find then mask out comments & strings so as-is chars can be restored from
  513. tempstr onto iobuf
  514. }
  515. {-----------------------------------------------------------------------------}
  516. PROCEDURE maskmatch (commentlen : INTEGER);
  517. {-----------------------------------------------------------------------------}
  518. VAR
  519.   slot : INTEGER;
  520.  
  521. BEGIN {maskmatch}
  522.   tempstr := Copy (linebuf, strt, commentlen);
  523.   FOR slot := 1 TO Length(tempstr)
  524.   DO
  525.     tempstr[slot] := space;
  526.   Delete (linebuf, strt, commentlen);
  527.   Insert (tempstr, linebuf, strt)
  528. END;  {maskmatch}
  529.  
  530. BEGIN {mask_comments_strings}
  531.     REPEAT {do strings}
  532.     strt := Pos(apostrophe, linebuf);
  533.     IF strt <> 0
  534.     THEN
  535.       linebuf[strt] := space;
  536.     endd := Pos (apostrophe, linebuf);
  537.     IF endd <> 0
  538.     THEN
  539.       linebuf[endd] := space;
  540.     IF ((endd <> 0) AND (strt <> 0))
  541.     THEN
  542.       maskmatch (endd - strt + 1)
  543.     UNTIL ((endd = 0) OR (strt = 0));
  544.  
  545.     REPEAT
  546.     strt := Pos('{', linebuf);
  547.     IF strt = 0 {check again for alternative delimiter}
  548.     THEN
  549.       strt := Pos ('(*', linebuf);
  550.     endd := Pos('}', linebuf);
  551.     IF endd = 0 {check again for alternate delimiter}
  552.     THEN
  553.       endd := Pos('*)', linebuf);
  554.     IF strt <> 0
  555.     THEN
  556.       BEGIN
  557.       commentactive := TRUE;
  558.       commentcount := commentcount + 1
  559.       END;
  560.     IF endd <> 0
  561.     THEN
  562.       commentactive := FALSE;
  563.     IF strt = 0
  564.     THEN
  565.       IF endd = 0      {no end-comment nor begin-comment}
  566.       THEN
  567.         IF commentactive {continued multiline comment}
  568.         THEN
  569.           BEGIN
  570.           strt := 1;
  571.           maskmatch (len - strt + 1)
  572.           END
  573.         ELSE           {no active comment}
  574.           BEGIN        {do nothing}
  575.           END
  576.       ELSE             {end-comment found but no begin-comment}
  577.         BEGIN          {multiline comment being terminated on current line}
  578.         strt := 1;
  579.         maskmatch (endd - strt + 1)
  580.         END
  581.     ELSE               {begin-comment found}
  582.       IF endd <> 0
  583.       THEN                  {line has begin-comment & end-comment}
  584.         maskmatch (endd - strt + 1) {regular single line comment}
  585.       ELSE             {line has begin-comment but no end-comment}
  586.         maskmatch (len - strt + 1) {start of a multiline comment}
  587.     UNTIL ((endd = 0) OR (strt = 0));
  588. END; {mask_comments_strings}
  589. {-----------------------------------------------------------------------------}
  590. PROCEDURE parse;
  591. {-----------------------------------------------------------------------------}
  592. VAR
  593.   slot : INTEGER;
  594. {-----------------------------------------------------------------------------}
  595. PROCEDURE fixhex (VAR subject : s255);
  596. {-----------------------------------------------------------------------------}
  597. {
  598. Ensure that the HexaDecimal Literals ( ::= (prefixed by a $) |0..9|
  599. A..F ) stand out better by having the occurrences of A..F xlat to
  600. uppercase unconditionally --- if you don't want this feature see
  601. main block of parse which calls this PROC
  602. }
  603. CONST
  604.   hexset   : SET OF CHAR = ['0'..'9', 'A'..'F'];
  605.   hexprefix = '$';
  606. VAR
  607.   from,
  608.   num,
  609.   len,
  610.   step,
  611.   place  : INTEGER;
  612.   hold,
  613.   tmp,
  614.   newstrg: s255;
  615.   done   : BOOLEAN;
  616. {-----------------------------------------------------------------------------}
  617. PROCEDURE fixhexinit;
  618. {-----------------------------------------------------------------------------}
  619. BEGIN
  620.   hold := subject;
  621.   from := 1;
  622.   len  := Length(hold);
  623.   newstrg := nullstr;
  624.   tmp  := nullstr;
  625. END;
  626. {-----------------------------------------------------------------------------}
  627. FUNCTION ishexstr : BOOLEAN;
  628. {-----------------------------------------------------------------------------}
  629. BEGIN
  630.   place := Pos (hexprefix, hold);
  631.   ishexstr := place <> 0;
  632. END;
  633. {-----------------------------------------------------------------------------}
  634. PROCEDURE fixhex1;
  635. {-----------------------------------------------------------------------------}
  636. BEGIN
  637.   num  := place - from + 1;
  638.   step := place + 1;
  639.   tmp  := newstrg;
  640.   newstrg := Copy (hold, from, num);
  641.   newstrg := tmp + newstrg;
  642.   hold [place] := space;
  643. END;
  644.  
  645. BEGIN {fixhex}
  646.   fixhexinit;
  647.   IF NOT ishexstr
  648.   THEN
  649.     Exit;
  650.   WHILE ishexstr
  651.   DO
  652.     BEGIN
  653.     fixhex1;
  654.     done := FALSE;
  655.     WHILE NOT done
  656.     DO
  657.       BEGIN
  658.       IF UpCase(hold[step]) IN hexset
  659.       THEN
  660.         BEGIN
  661.         IF step <= len {concat}
  662.         THEN
  663.           BEGIN
  664.           newstrg := newstrg + UpCase(hold[step]);
  665.           step := SUCC(step)
  666.           END
  667.         ELSE {a stray $ is at end of string ... concat done}
  668.           done := TRUE;
  669.         END
  670.       ELSE
  671.         done := TRUE
  672.       END; {WHILE NOT done}
  673.     from := step;
  674.     END; {WHILE ishexstr}
  675.   IF Length (newstrg) < len
  676.   THEN {copy rest of the string}
  677.     BEGIN
  678.     from := step;
  679.     hold := Copy (subject, from, len - from+1);
  680.     subject := newstrg+hold
  681.     END
  682.   ELSE
  683.     subject := newstrg;
  684. END;
  685.  
  686. BEGIN {parse}
  687.   linebuf   := iobuf;
  688.   len       := Length (iobuf);
  689.   charcount := charcount + len;
  690.   mask_comments_strings;
  691.   linebuf   := upstrg (linebuf);
  692.   tempstr   := iobuf;
  693.   IF case4nonreserved = upper
  694.   THEN
  695.     iobuf := upstrg (iobuf)
  696.   ELSE
  697.     IF case4nonreserved = lower
  698.     THEN
  699.       iobuf := lowstrg (iobuf);
  700.   FOR slot := 1 TO Length(iobuf)
  701.   DO
  702.     IF linebuf[slot] = space
  703.     THEN
  704.       iobuf[slot] := tempstr[slot];
  705.   fixhex (iobuf);   {--- comment this out if you don't want hex literals in caps}
  706.   findmatch
  707. END; {parse}
  708. {-----------------------------------------------------------------------------}
  709. PROCEDURE banner;
  710. {-----------------------------------------------------------------------------}
  711. CONST
  712.   title = 'pFormat [v2.0.2] (C) Andy Decepida 1985-Aug-26';
  713.  
  714. BEGIN
  715.   Window (1, 1, 80, 25);
  716.   GoToXY (1, 1);
  717.   ClrScr;
  718.   NormVideo;
  719.   FOR cnt  := 1 TO 80
  720.   DO
  721.     WRITE   ('═');
  722.   LowVideo;
  723.   WRITELN  (title:((80 + Length(title)) DIV 2));
  724.   NormVideo;
  725.   FOR cnt  := 1 TO 80
  726.   DO
  727.     WRITE   ('═');
  728.   LowVideo;
  729.   Window (1, 5, 80, 25);
  730.   GoToXY (1, 1);
  731.   WRITELN;
  732. END;
  733. {-----------------------------------------------------------------------------}
  734. PROCEDURE checksettings;
  735. {-----------------------------------------------------------------------------}
  736. BEGIN
  737.   WRITELN; WRITELN;
  738.   ClrScr; banner;
  739.   TextColor (Brown);
  740.   WRITELN ('Output File ',outfnam,apostrophe,'s default attributes are :');
  741.   LowVideo;
  742.   WRITELN (' ■ TurboPASCAL key/reserved words are in UPPER-case letters and');
  743.   WRITELN (' ■ Other alphabetic characters are written as is.');
  744.   WRITELN;
  745.   WRITE   ('Care to change these defaults ? ');
  746.   IF yes
  747.   THEN
  748.     altersettings
  749.   ELSE
  750.     BEGIN
  751.     case4reserved := upper;
  752.     case4nonreserved := asis;
  753.     END;
  754.   NormVideo;
  755.   WRITELN;
  756.   WRITELN;
  757.   WRITE ('Would you like to be able to abort this run with a keypress ?');
  758.   abortable := yes;
  759.   LowVideo
  760. END;
  761. {-----------------------------------------------------------------------------}
  762. PROCEDURE get_attr (fd : s255);
  763. {-----------------------------------------------------------------------------}
  764. {
  765. Get the File Attributes for displaying to user ... for confirmation
  766. purposes ... IBM-PC specific
  767. }
  768. TYPE
  769.   filelist = RECORD
  770.              name   : STRING[13];
  771.              attrib : Byte;
  772.              size   : REAL;
  773.              date,
  774.              time   : s255;
  775.              END;
  776.   regpack  = RECORD
  777.              ax,bx,cx,dx,bp,si,di,ds,es,flags: INTEGER
  778.              END;
  779.   wrkstr   = STRING[80];
  780.  
  781. VAR
  782.   list: filelist;
  783.   sizestr,
  784.   filemask: wrkstr;
  785.   x,total: Byte;
  786.   recpack: regpack;
  787.   hidden,system,readonly,normal,archive,dircty: BOOLEAN;
  788. {-----------------------------------------------------------------------------}
  789. PROCEDURE directory(filemask: wrkstr; VAR list: filelist; VAR total: Byte);
  790. {-----------------------------------------------------------------------------}
  791. VAR
  792.   dta: STRING[44];
  793. {-----------------------------------------------------------------------------}
  794. FUNCTION filesiz: REAL;              { decipher the File's Size in Bytes }
  795. {-----------------------------------------------------------------------------}
  796. VAR size: REAL;
  797.     byte1,byte2,byte3,byte4: Byte;
  798. BEGIN
  799.   byte1 := ORD(Copy(dta,28,1));
  800.   byte2 := ORD(Copy(dta,27,1));
  801.   byte3 := ORD(Copy(dta,29,1));
  802.   byte4 := ORD(Copy(dta,30,1));
  803.   size := byte1 ShL 8+byte2;
  804.   IF size< 0
  805.   THEN
  806.     size := size+65536.0;       { adjust for negative values }
  807.   size := (byte3 ShL 8+byte4)*256.0+size;
  808.   filesiz := size;
  809. END;  { filesiz }
  810. {-----------------------------------------------------------------------------}
  811. FUNCTION filedate: wrkstr;             { decipher the File's Date Stamp }
  812. {-----------------------------------------------------------------------------}
  813. VAR day,month,year: wrkstr;
  814.     mon : STRING[3];
  815.     temp: INTEGER;
  816.     byte1,byte2: Byte;
  817. BEGIN
  818.   byte1 := ORD(Copy(dta,25,1));
  819.   byte2 := ORD(Copy(dta,26,1));
  820.   Str(byte1 AND 31:2,day);
  821.   temp  := (byte1 ShR 5) AND 7+(byte2 AND 1) ShL 3;
  822.   CASE temp OF
  823.     01 : mon := 'Jan';     02 : mon := 'Feb';     03 : mon := 'Mar';
  824.     04 : mon := 'Apr';     05 : mon := 'May';     06 : mon := 'Jun';
  825.     07 : mon := 'Jul';     08 : mon := 'Aug';     09 : mon := 'Sep';
  826.     10 : mon := 'Oct';     11 : mon := 'Nov';     12 : mon := 'Dec'
  827.   END;
  828.   Str((byte2 ShR 1)+80: 2,year);
  829.   IF day[1]= space
  830.   THEN
  831.     day[1] := '0';
  832.   IF year[1]= space
  833.   THEN
  834.     year[1] := '0';
  835.   filedate := day+'-'+mon+'-'+year
  836. END;  { filedate }
  837. {-----------------------------------------------------------------------------}
  838. FUNCTION filetime: wrkstr;             { decipher the File's Time Stamp }
  839. {-----------------------------------------------------------------------------}
  840. VAR hour,min,ampm: wrkstr;
  841.     temp: INTEGER;
  842.     byte1,byte2: Byte;
  843. BEGIN
  844.   byte1 := ORD(Copy(dta,23,1));
  845.   byte2 := ORD(Copy(dta,24,1));
  846.   temp := (byte1 ShR 5) AND 7+(byte2 AND 7) ShL 3;
  847.   Str(temp:2,min);
  848.   temp := byte2 ShR 3;
  849.   IF temp<13
  850.   THEN
  851.     ampm := 'am'
  852.   ELSE
  853.     BEGIN
  854.     temp := temp-12;
  855.     ampm := 'pm'
  856.     END;
  857.   Str(temp:2,hour);
  858.   WHILE (Pos(space, hour) <> 0)
  859.   DO
  860.     Delete (hour,1,1);
  861.   IF min[1]= space
  862.   THEN
  863.     min[1] := '0';
  864.   filetime := hour+':'+min+ampm
  865. END;  { filetime }
  866. {-----------------------------------------------------------------------------}
  867. PROCEDURE fillrecord(recno: Byte);   { fill List.[RecNo] with file info }
  868. {-----------------------------------------------------------------------------}
  869. BEGIN
  870.   WITH list
  871.   DO
  872.     BEGIN
  873.     name := Copy(dta,31,13);
  874.     attrib := ORD(Copy(dta,22,1));
  875.     size := filesiz;
  876.     date := filedate;
  877.     time := filetime;
  878.     IF (name[1]<>period) AND (Pos(period,name)<>0)
  879.     THEN
  880.       BEGIN        { line up the file ext.}
  881.       WHILE Pos(period,name)<9
  882.       DO
  883.         Insert(space,name,Pos(period,name)); 
  884.       name[Pos(period,name)] := space;
  885.       END;
  886.     END;
  887. END;  { fillrecord }
  888. {-----------------------------------------------------------------------------}
  889. PROCEDURE filldirlist;
  890. {-----------------------------------------------------------------------------}
  891. BEGIN
  892.   total := 1;
  893.   fillrecord(total);
  894.     REPEAT
  895.     recpack.ax := $4F ShL 8;
  896.     MsDos(recpack);
  897.     IF (recpack.ax<>18) AND (recpack.ax<>2)
  898.     THEN
  899.       BEGIN
  900.       total := total+1;
  901.       fillrecord(total)
  902.       END                          { repeat filling until no more }
  903.     UNTIL (recpack.flags AND 1)<>0;{ files are found              }
  904. END;  { filldirlist }
  905.  
  906. BEGIN  { Directory }
  907.   total := 0;
  908.   dta := '                                           ';
  909.   filemask := filemask+#0;
  910.   WITH recpack
  911.   DO
  912.     BEGIN                      { First, Set aside the DTA    }
  913.     ax := $1A ShL 8;           { or Data Transfer Area,      }
  914.     ds := Seg(dta);
  915.     dx := Ofs(dta)+1;          { call $1A then call $4E to   }
  916.     MsDos(recpack);            { find the First Match. Set   }
  917.     ax := $4E ShL 8;           { set Cx to 23 to include all }
  918.     ds := Seg(filemask);
  919.     dx := Ofs(filemask)+1;     { hidden files. Then up above }
  920.     cx := 23;                  { call $4F to find subsequent }
  921.     MsDos(recpack);            { matches, filling List.      }
  922.     IF (flags AND 1)=0
  923.     THEN
  924.       filldirlist
  925.     END
  926. END;  { directory }
  927.  
  928. BEGIN
  929.   directory(fd,list,total);          { if available         }
  930.   WRITELN;
  931.   WITH list
  932.   DO
  933.     BEGIN
  934.     Str(size:15:0, sizestr);
  935.     WHILE (Pos(space,sizestr) <> 0)
  936.     DO
  937.       Delete (sizestr,1,1);
  938.     WRITE ('The ', sizestr, '-byte file ');
  939.     HighVideo;
  940.     WRITE (fd);
  941.     LowVideo;
  942.     WRITE (' was saved on ', date);
  943.     WRITE (' at ', time);
  944.     END;
  945.   WRITELN;
  946. END;
  947. {-----------------------------------------------------------------------------}
  948. PROCEDURE checkinput;
  949. {-----------------------------------------------------------------------------}
  950. BEGIN
  951.   IF Length (infnam) < 1
  952.   THEN
  953.     userquits;
  954.   IF  (Pos (period, infnam) = 0)
  955.   AND (Pos (stdextns, infnam) = 0)
  956.   THEN
  957.     infnam := infnam+stdextns;
  958.   Assign (inf, infnam);
  959.   {$I-}
  960.   RESET  (inf)
  961.   {$I+};
  962.   ok :=  (IOResult = 0);
  963.   IF ok
  964.   THEN
  965.     BEGIN                      {open of an existing file is successful}
  966.     get_attr (infnam);
  967.     WRITELN;
  968.     NormVideo;
  969.     WRITE ('Is this the file you really want to submit? ');
  970.     IF NOT yes
  971.     THEN
  972.       ok := FALSE;
  973.     LowVideo
  974.     END
  975.   ELSE
  976.     BEGIN
  977.     alarm; alarm; alarm;
  978.     WRITELN; WRITELN;
  979.     WRITE (' ... Cannot find file ');
  980.     NormVideo;
  981.     WRITE (infnam);
  982.     LowVideo;
  983.     WRITELN(' ... PRESS ',CHR(17),'┘');
  984.     WRITELN;
  985.     makecursor (invisible);
  986.     READLN (KBD);
  987.     END
  988. END;
  989. {-----------------------------------------------------------------------------}
  990. PROCEDURE getinfnam;
  991. {-----------------------------------------------------------------------------}
  992. BEGIN {getinfnam}
  993.   ok := FALSE;
  994.   WHILE NOT ok
  995.   DO
  996.     BEGIN
  997.     WRITELN;
  998.     LowVideo;
  999.     WRITE ('Name of TurboPASCAL source text file : ');
  1000.     makecursor (full);
  1001.     READLN (infnam);
  1002.     makecursor(invisible);
  1003.     trim (infnam);
  1004.     infnam := upstrg (infnam);
  1005.     checkinput;
  1006.     END; {WHILE}
  1007.   makecursor (normal)
  1008. END; {getinfnam}
  1009. {-----------------------------------------------------------------------------}
  1010. PROCEDURE checkoutput;
  1011. {-----------------------------------------------------------------------------}
  1012. BEGIN
  1013.   outfnam := upstrg (outfnam);
  1014.   IF Length (outfnam) < 1
  1015.   THEN
  1016.     userquits;
  1017.   IF  (Pos (period, outfnam) = 0)              {concat (.PAS) only if }
  1018.   AND (Pos (stdextns, outfnam) = 0)        {there is no supplied extns}
  1019.   THEN
  1020.     outfnam := outfnam+stdextns;
  1021.   IF outfnam = infnam
  1022.   THEN
  1023.     BEGIN
  1024.     TextColor (Yellow);
  1025.     makecursor (invisible);
  1026.     WRITELN;
  1027.     alarm; alarm; alarm;
  1028.     WRITELN ('You have PERILOUSLY designated the same file_name for both your');
  1029.     WRITELN ('  input and your output file !!! ');
  1030.     WRITELN;
  1031.     WRITELN(' PRESS ',CHR(17),'┘ ... ');
  1032.     WRITELN;
  1033.     WRITELN('  And then give an output file name that is different from the input.');
  1034.     alarm;
  1035.     READLN (KBD);
  1036.     LowVideo;
  1037.     ok := FALSE;
  1038.     Exit;
  1039.     END;
  1040.   Assign (outf, outfnam);
  1041.   {$I-}
  1042.   RESET (outf);                  {check & see if destination file}
  1043.   {$I+}                                          { already exists}
  1044.   ok := (IOResult = 0);
  1045.   IF ok
  1046.   THEN
  1047.     BEGIN
  1048.     WRITELN;  WRITELN;
  1049.     TextColor (Black);
  1050.     TextBackGround (White);
  1051.     WRITELN (' ■ ',outfnam,' already exists ...');
  1052.     LowVideo;
  1053.     alarm; alarm; alarm;
  1054.     get_attr(outfnam);
  1055.     alarm;
  1056.     WRITELN;
  1057.     TextColor (Yellow);
  1058.     WRITE (' ■ Do you want to go ahead and write over it ');
  1059.     IF yes
  1060.     THEN
  1061.       Close (outf)
  1062.     ELSE
  1063.       BEGIN
  1064.       ok := FALSE;
  1065.       Exit
  1066.       END
  1067.     END;
  1068.   Assign (outf, outfnam);
  1069.   {$I-}
  1070.   REWRITE (outf);
  1071.   {$I+};
  1072.   ok := (IOResult = 0);
  1073.   IF NOT ok
  1074.   THEN
  1075.     BEGIN
  1076.     alarm; alarm; alarm;
  1077.     WRITELN; WRITELN;
  1078.     makecursor (full);
  1079.     alarm;
  1080.     NormVideo;
  1081.     WRITE (' ... Unable to open file ',outfnam, ' ... PRESS ',CHR(17),'┘ ');
  1082.     READLN;
  1083.     makecursor (invisible);
  1084.     LowVideo
  1085.     END
  1086. END;
  1087. {-----------------------------------------------------------------------------}
  1088. PROCEDURE getoutfnam;
  1089. {-----------------------------------------------------------------------------}
  1090. BEGIN {getoutfnam};
  1091.     REPEAT
  1092.     ClrScr;
  1093.     banner;
  1094.     outfnam := nullstr;
  1095.     WRITELN;
  1096.     NormVideo;
  1097.     WRITELN (' pFORMAT will generate a copy of ',infnam);
  1098.     LowVideo;
  1099.     get_attr (infnam);
  1100.     WRITELN;
  1101.     WRITELN (' Options :');
  1102.     WRITELN (' ■ You may enter a DOS file name to capture the copy on disk,');
  1103.     WRITELN (' ■ OR, you may quit by pressing a lone ',CHR(17),'┘');
  1104.     WRITE   (' --- Please designate a destination for the pFORMAT copy : ');
  1105.     makecursor (full);
  1106.     READLN  (outfnam);
  1107.     trim    (outfnam);
  1108.     checkoutput;
  1109.     UNTIL ok;
  1110.   makecursor (normal)
  1111. END; {getinfnam}
  1112. {-----------------------------------------------------------------------------}
  1113. PROCEDURE preamble;
  1114. {-----------------------------------------------------------------------------}
  1115. PROCEDURE oneparm;
  1116. {-----------------------------------------------------------------------------}
  1117. BEGIN
  1118.   ok := TRUE;
  1119.   infnam := upstrg(ParamStr(1));
  1120.   checkinput;
  1121.   IF NOT ok
  1122.   THEN
  1123.     getinfnam;
  1124.   getoutfnam;
  1125. END;
  1126. {-----------------------------------------------------------------------------}
  1127. PROCEDURE twoparms;
  1128. {-----------------------------------------------------------------------------}
  1129. BEGIN
  1130.   ok := TRUE;
  1131.   infnam := upstrg(ParamStr(1));
  1132.   outfnam:= upstrg(ParamStr(2));
  1133.   checkinput;
  1134.   IF NOT ok
  1135.   THEN
  1136.     getinfnam;
  1137.   checkoutput;
  1138.   IF NOT ok
  1139.   THEN
  1140.     BEGIN
  1141.     getoutfnam;
  1142.     parmcnt := 0;
  1143.     END;
  1144. END;
  1145.  
  1146. BEGIN
  1147.   {___ initialize global variables ___}
  1148.   mixedcase := FALSE; commentactive := FALSE;
  1149.   case4reserved := upper; case4nonreserved := lower;
  1150.   reservedcount := 0;  linecount := 0;
  1151.   charcount     := 0;  commentcount:= 0;
  1152.   LowVideo;
  1153.   ClrScr; banner;
  1154.   WRITE   (
  1155.   '      To quit, press a lone ',CHR(17),
  1156.   '┘ in response to the prompts for file names.');
  1157.   WRITELN;
  1158.   IF parmcnt = 0
  1159.   THEN
  1160.     BEGIN  {no Command Line Parms}
  1161.     getinfnam;
  1162.     getoutfnam;
  1163.     END
  1164.   ELSE
  1165.     IF parmcnt = 1
  1166.     THEN
  1167.       oneparm
  1168.     ELSE
  1169.       twoparms;
  1170.   checksettings;
  1171.   TextColor (Black);
  1172.   TextBackGround (White);
  1173.   legend := Concat ('Reading ',infnam,' & generating ',outfnam);
  1174.   ClrScr;
  1175.   banner;
  1176.   WRITELN;
  1177.   IF (Length (legend) <= 80)
  1178.   THEN {centre if it fits 80-char line}
  1179.     WRITE   (legend:((80 + Length(legend)) DIV 2))
  1180.   ELSE
  1181.     WRITE   (legend);
  1182.   WRITELN;
  1183.   NormVideo;
  1184.   FOR cnt  := 1 TO 80
  1185.   DO
  1186.     WRITE   ('═');
  1187.   LowVideo;
  1188.   makecursor (invisible);
  1189.   NormVideo;
  1190.   GoToXY (25, 5); WRITE ('           Lines processed  : ');
  1191.   GoToXY (25, 6); WRITE ('    Characters encountered  : ');
  1192.   GoToXY (25, 7); WRITE ('  Reserved words processed  : ');
  1193.   GoToXY (25, 8); WRITE ('      Comments encountered  : ');
  1194.   LowVideo
  1195. END;
  1196.  
  1197. {-----------------------------------------------------------------------------}
  1198. PROCEDURE task;
  1199. {-----------------------------------------------------------------------------}
  1200. BEGIN
  1201.   preamble;
  1202.   WHILE NOT  (EOF(inf))
  1203.   DO
  1204.     BEGIN
  1205.     iobuf := nullstr;
  1206.     READLN (inf, iobuf);
  1207.     IF Length(iobuf) <> 0
  1208.     THEN
  1209.       parse;
  1210.     linecount := linecount + 1;
  1211.     GoToXY (56, 5); WRITE (linecount:7:0);
  1212.     GoToXY (56, 6); WRITE (charcount:7:0);
  1213.     GoToXY (56, 7); WRITE (reservedcount:7:0);
  1214.     GoToXY (56, 8); WRITE (commentcount:7:0);
  1215.     WRITELN(outf, iobuf)
  1216.     END;
  1217.   alarm; alarm; alarm;
  1218.   makecursor (normal);
  1219.   alarm;
  1220.   Close (inf);
  1221.   Close (outf);
  1222. END;
  1223.  
  1224. {-- pFORMAT begins here --------------------------------------------------}
  1225. BEGIN
  1226.   TextMode;
  1227.   initarray;
  1228.   infnam := nullstr;
  1229.   parmcnt := ParamCount;
  1230.   ok := TRUE;
  1231.     REPEAT
  1232.     task;
  1233.     WRITELN; WRITELN; WRITELN;
  1234.     parmcnt := 0;
  1235.     WRITE ('                              Quit pFORMAT?')
  1236.     UNTIL yes;
  1237.   userquits
  1238. END.  {---------------------------------------------------------------pFormat}
  1239.