Power-Programmierung/CD1.mdf/pascal/library/dos/bix/caps.pas

Pascal/Delphi Source File | 1986-08-04 | 6.7 KB | 275 lines

PROGRAM Caps(INPUT,OUTPUT);
(****************************************************************************)
(*                                                                          *)
(*   This program is a result of much frustration with other programs       *)
(* designed to do the same. I wanted a program that capitalized a specific  *)
(* set of words in my pascal programs, and put a row of commented asterisks *)
(* in front of every procedure and function. I also wanted it to capitalize *)
(* the first letter not in the list. This was achieved to a degree by       *)
(* Hermann Calabria's LC. The problem was that it was too slow and it       *)
(* did not capitalize correctly. It also had the nagging problem that       *)
(* strings with comments and quotes were also all capitalized. This program *)
(* fixxes all these things, and keeps the word set in an external file,     *)
(* thus making it easy to modify the word list.                             *)
(*                                                                          *)
(*   I release this program to the public domain, as long as it is not used *)
(* for monetary gain. Otherwise, do as you please with it, and don't come   *)
(* to me to complain about anything. You are resposible for the use of this *)
(* program. Oh, and by the way, make sure that this notice is kept with it. *)
(*                                                                          *)
(*                        Juan Orlandini                                    *)
(*                        7460 SW 174 ST                                    *)
(*                        Miami, FL 33157                                   *)
(*                        [phone]                                    *)
(****************************************************************************)

TYPE Ptr=^Node;
     Str=STRING[20];
     Line=STRING[128];
     Node= RECORD
            Info:Str;
            Left:Ptr;
            Right:Ptr;
           END;

VAR Flag,Flag2,Flag3,Flag4:BOOLEAN;

(************************************************************************)

PROCEDURE Add(VAR N:Ptr; D:Str);
VAR I,T,P:Ptr;
BEGIN
  NEW(I);
  I^.Info:=D;
  I^.Right:=NIL;
  I^.Left:=NIL;
  T:=N; P:=N;
  WHILE T<>NIL DO
   IF D>T^.Info THEN
    BEGIN
     P:=T;
     T:=T^.Right
    END
   ELSE
    BEGIN
     P:=T;
     T:=T^.Left;
    END;
   IF N=NIL THEN N:=I ELSE
     IF D>P^.Info THEN P^.Right:=I ELSE P^.Left:=I;
END;

(************************************************************************)

PROCEDURE Lowcase(VAR L:Line);
VAR C:INTEGER;
    F,E,G:BOOLEAN;
BEGIN
F:=FALSE; E:=FALSE; G:=FALSE;
FOR C:=1 TO LENGTH(L) DO
  CASE L[C] OF
    #39: F:=NOT(F);
    '}': IF NOT(G) THEN E:=FALSE;
    '{': IF NOT(G) THEN E:=TRUE;
    '(': IF (C<>LENGTH(L)) AND (L[C+1]='*') AND NOT(E) THEN G:=TRUE;
    ')': IF (C>1) AND (L[C-1]='*') AND NOT(E) THEN G:=FALSE;
    'A'..'Z': IF NOT(E OR F OR G) THEN L[C]:=CHR(ORD(L[C])+32);
  END;
END;

(************************************************************************)

FUNCTION Up(W:Str):Str;
VAR I:INTEGER;
BEGIN
 FOR I:=1 TO LENGTH(W) DO W[I]:=UPCASE(W[I]);
 Up:=W;
END;

(************************************************************************)

PROCEDURE Getword(L:Line; VAR C:INTEGER; VAR W:Str);

BEGIN
W:='';
WHILE (C<=LENGTH(L)) AND (L[C] IN ['a'..'z']) DO
 BEGIN
  W:=W+L[C];
  C:=C+1;
 END;
END;

(************************************************************************)

PROCEDURE Nextone(L:Line; VAR C:INTEGER; VAR W:Line);
BEGIN
W:='';
IF NOT(Flag OR Flag2 OR Flag4) THEN
WHILE (C<=LENGTH(L)) AND NOT(L[C] IN ['a'..'z']) DO
 BEGIN
  IF (L[C]=#123) AND NOT(Flag2 OR Flag4) THEN Flag:=TRUE;
  IF (L[C]=#125) AND NOT(Flag2 OR Flag4) THEN Flag:=FALSE;
  IF (C<LENGTH(L)) AND (L[C]='(') AND (L[C+1]='*')
     AND NOT(Flag2 OR Flag) THEN Flag4:=TRUE;
  IF (NOT(Flag OR Flag4) AND (L[C]=#39)) THEN Flag2:=NOT(Flag2);
  W:=W+L[C];
  C:=C+1;
 END
ELSE
 WHILE (C<=LENGTH(L)) AND (Flag OR Flag2 OR Flag4) DO
  BEGIN
   IF Flag AND (L[C]=#125) THEN Flag:=FALSE;
   IF (L[C]=')') AND (C>1) AND (L[C-1]='*') AND NOT(Flag OR Flag2)
       THEN Flag4:=FALSE;
   IF NOT(Flag OR Flag4) AND (L[C]=#39) THEN Flag2:=NOT(Flag2);
   W:=W+L[C];
   C:=C+1;
  END;
END;

(************************************************************************)

FUNCTION Nerd(W:Str):Str;
BEGIN
W[1]:=UPCASE(W[1]);
Nerd:=W;
END;

(************************************************************************)

FUNCTION Word(Root:Ptr; W:Str):BOOLEAN;
VAR X:BOOLEAN;
    T:Ptr;

BEGIN
X:=FALSE; T:=Root;
WHILE NOT(X) AND  (T<>NIL) DO
  IF T^.Info=W THEN X:=TRUE ELSE
   IF W>T^.Info THEN T:=T^.Right ELSE T:=T^.Left;
IF X AND ((W='procedure') OR (W='function')) THEN Flag3:=TRUE;
Word:=X;
END;

(************************************************************************)

PROCEDURE Change(Root:Ptr; VAR L:Line);
VAR C:INTEGER;
    W:Str;
    O,S:Line;

BEGIN
IF NOT(Flag OR Flag2 OR Flag4) THEN Lowcase(L);
C:=1; O:='';
Nextone(L,C,S);
O:=O+S;
IF Flag OR Flag4 THEN
 BEGIN
  WHILE (Flag OR Flag4) AND (C<=LENGTH(L)) DO
   BEGIN
    Nextone(L,C,S);
    O:=O+S;
   END;
  Nextone(L,C,S);
  O:=O+S;
 END
ELSE
WHILE C<=LENGTH(L) DO
 BEGIN
  IF NOT(Flag OR Flag2 OR Flag4) THEN
   BEGIN
    Getword(L,C,W);
    IF Word(Root,W) THEN O:=O+Up(W) ELSE O:=O+Nerd(W);
   END;
  Nextone(L,C,S);
  O:=O+S;
 END;
L:=O;
END;

(************************************************************************)

PROCEDURE Readwords(VAR Root:Ptr);
VAR F:TEXT;
    N:Str;
    C:INTEGER;

BEGIN
C:=0;
ASSIGN(F,'words');
RESET(F);
WHILE NOT(Eof(F)) DO
 BEGIN
  READLN(F,N);
  Add(Root,N);
  C:=C+1;
 END;
Close(F);
END;

(************************************************************************)

PROCEDURE Openfile(M:Line; VAR P:TEXT; S:BOOLEAN);
VAR N:Str;
    F:BOOLEAN;

BEGIN
F:=FALSE;
WHILE NOT(F) DO
 BEGIN
  WRITE(M);
  READLN(N);
  ASSIGN(P,N);
  IF S THEN
   BEGIN
    {$I-} RESET(P); {$I+}
    F:=IORESULT=0;
   END
  ELSE
   BEGIN
    REWRITE(P);
    F:=TRUE;
   END;
 END;
END;

(************************************************************************)

PROCEDURE Main;
VAR Root:Ptr;
    L:Line;
    F,O:TEXT;

BEGIN
Flag:=FALSE;
Flag2:=FALSE;
Flag3:=FALSE;
Flag4:=FALSE;
Root:=NIL;
Readwords(Root);
Openfile('file to read  :',F,TRUE);
Openfile('file to write :',O,FALSE);
WHILE NOT Eof(F) DO
 BEGIN
  READLN(F,L);
  IF L<>'' THEN Change(Root,L);
  IF Flag3 THEN
    BEGIN

*********)');

*********)');
     WRITELN(O);
     WRITELN;
     Flag3:=FALSE;
    END;
  WRITELN(O,L);
  WRITELN(L);
 END;
Close(F);
Close(O);
END;

BEGIN
Main;
END.