1 files changed, 119 insertions, 0 deletions
diff --git a/web/clip/vax_vms/ex01_b.pas b/web/clip/vax_vms/ex01_b.pas
new file mode 100644
index 0000000000..922466572a
--- /dev/null
+++ b/web/clip/vax_vms/ex01_b.pas
@@ -0,0 +1,119 @@
+    (***************  #file "PALINDROME.PAS"  ***********************)
+    (****************************************************************)
+    (* Program: Palindrome filter program.                          *)
+    (* Purpose: To filter the palindromic lines from a given input  *)
+    (*          file to a specified output file.                    *)
+    (****************************************************************)
+    PROGRAM PALINDROME (INPUT, OUTPUT, IN_FILE, OUT_FILE);
+
+    CONST
+        MAX_L = 132;
+    TYPE
+        ABSTRACT  = (DEFINED, UNDEFINED);
+        TEXT_LINE =     RECORD
+                            CHARS: ARRAY[1..MAX_L] OF CHAR;
+                            LENGTH: 0..MAX_L;
+                        END (*RECORD*);
+    VAR
+        IN_FILE, OUT_FILE: TEXT;
+        IN_LINE,
+        LETTERS:        TEXT_LINE;
+        IS_PALINDROME:  BOOLEAN;
+        IN_CHAR:    CHAR;
+        I:        INTEGER;
+        J:        INTEGER;
+        T :         INTEGER;
+
+    BEGIN
+        OPEN (IN_FILE,  'TESTDATA.IN',  HISTORY := OLD); RESET   (IN_FILE);
+        OPEN (OUT_FILE, 'TESTDATA.OUT', HISTORY := NEW); REWRITE (OUT_FILE);
+
+        (*****************  Palindrome (body)  **********************)
+        (** Copy the lines of the IN_FILE that are palindromic to  **)
+        (** the OUT_FILE.                                          **)
+        WHILE NOT EOF (IN_FILE) DO
+        BEGIN
+            (*****************  Palindrome (1)  *********************)
+            (** Read a line from IN_FILE into IN_LINE. The letters **)
+            (** of this line are copied to LETTERS.                **)
+            IN_LINE.LENGTH := 0;
+            LETTERS.LENGTH := 0;
+            WITH IN_LINE DO
+            WHILE NOT EOLN (IN_FILE) DO
+            BEGIN
+                READ (IN_FILE, IN_CHAR);
+                LENGTH := LENGTH + 1;
+                CHARS[LENGTH] := IN_CHAR;
+                IF IN_CHAR IN ['A'..'Z', 'a'..'z'] THEN
+                WITH LETTERS DO
+                BEGIN
+                    LENGTH := LENGTH + 1;
+                    CHARS[LENGTH] := IN_CHAR;
+                END (*WITH/IF*);
+            END (*WHILE/WITH*);
+
+            (*****************  Palindrome (test)  ******************)
+            (** Check contents of IN_LINE and LETTERS.             **)
+            WRITELN;
+            WRITELN ('============  DEBUGGING INFORMATION  ===============');
+            WRITELN ('Contents of buffer IN_LINE: ');
+            WRITE   ('>>>>');
+            WITH IN_LINE DO
+            FOR T := 1 TO LENGTH DO WRITE (OUTPUT, CHARS[T]);
+            WRITE   ('<<<<');
+            WRITELN;
+            WRITELN ('Contents of buffer LETTERS:  ');
+            WRITE   ('>>>>');
+            WITH LETTERS DO
+            FOR T := 1 TO LENGTH DO WRITE (OUTPUT, CHARS[T]);
+            WRITE   ('<<<<');
+            WRITELN;
+            WRITELN ('==========  END OF DEBUGGING INFORMATION  ==========');
+            WRITELN;
+            (*************  End of Palindrome (test)  ***************)
+
+            (*****************  End of Palindrome (1)  **************)
+
+            READLN (IN_FILE);
+
+            (*****************  Palindrome (2)  *********************)
+            (** Test palindromicity of LETTERS. Set IS_PALINDROME  **)
+            (** to reflect the result of the test.                 **)
+            WITH LETTERS DO
+            BEGIN
+                (* Transform lowercase to uppercase.                *)
+                FOR I := 1 TO LENGTH DO
+                IF CHARS[I] IN ['a'..'z']
+                THEN CHARS[I] :=
+                     CHR(ORD(CHARS[I]) - ORD('a') + ORD('A'));
+
+                (* Perform the palindromicity test.                 *)
+                IS_PALINDROME := TRUE;
+                I := 1;
+                WHILE IS_PALINDROME AND (I <= LENGTH DIV 2) DO
+                IF CHARS[I] = CHARS[LENGTH-I+1] THEN
+                    I := I + 1
+                ELSE
+                    IS_PALINDROME := FALSE;
+            END (*WITH*);
+            (*****************  End of Palindrome (2)  **************)
+
+
+            IF IS_PALINDROME THEN
+            BEGIN
+                (*****************  Palindrome (3)  *****************)
+                (** Write IN_LINE to OUT_FILE.                     **)
+                WITH IN_LINE DO
+                BEGIN
+                    FOR J := 1 TO LENGTH DO
+                        WRITE (OUT_FILE, CHARS[J]);
+                END (*WITH*);
+                (*************  End of Palindrome (3)  **************)
+
+                WRITELN (OUT_FILE);
+            END (*IF*);
+        END (*WHILE*);
+        (*************  End of Palindrome (body)  *******************)
+
+    END (*PALINDROME*).
+    (*******************  End of PALINDROME.PAS  ********************)