program censor(input, output);
(* censor: removes code from a program

  Tom Schneider
  National Cancer Institute
  Laboratory of Mathematical Biology
  Frederick, Maryland  21702-1201
  toms@ncifcrf.gov
  http://www-lmmb.ncifcrf.gov/~toms/

  National Cancer Institute
  Laboratory of Mathematical Biology

 *)

label 1; (* end of program *)

const
(* begin module version *)
version = 1.47; (* of censor.p 1996 January 28
origin 1990 December 19 *)
(* end module version *)

(* begin module describe.censor *)
(*
name
   censor: removes code from a program

synopsis
   censor(input: in, output: out)

files
   input:  input program with private text
   output: output program without private text

description
   The program allows one to maintain a Pascal program for personal use which
   contains features that are not yet to be made public.  The program contains
   special comment marks that delimit the text to be removed.  There are two
   situations.

   The first is the case of sections of text inside comments.  Any text
   surrounded by [[ and ]] will not be copied to the output.  This includes the
   double brackets themselves.

   The second case is sections of normal code.  Letting '@' represent the
   asterisk (so that this description does not run into trouble when it
   is inside a Pascal comment), the text between and including the symbols
   (@[[@) and (@]]@) is not copied to the output.

examples

documentation

see also

author
   Thomas Dana Schneider

bugs

technical notes

*)
(* end module describe.censor *)

(* begin module censor.const *)
      maxstring = 1500; (* the maximum string *)
(* end module censor.const *)

   fillermax = 10; (* the size of the filler array for a string *)

type
(* begin module interact.type *)
      string = record (* a string of characters *)
         letters: array[1..maxstring] of char; (* the letters in the string *)
         length: integer; (* the number of characters in the string *)
         current: integer; (* the letter we are working on *)
      end;
(* end module interact.type version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module filler.type *)
      (* the following is an array used to fill a string.
      it is convenient to have it much shorter than the maxstring, so that
      it is easy to fill the string using procedure fillstring.
      the user must declare the value of constant fillermax. *)
      filler = packed array[1..fillermax] of char;
(* end module filler.type version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module trigger.type *)
      trigger = record (* an object to be searched for *)
         seek: string; (* the characters looked for *)
         state: integer; (* how close to triggering we are *)
         skip: boolean; (* trigger not found- skip the line *)
         found: boolean (* the trigger was found *)
      end;
(* end module trigger.type version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module halt *)
procedure halt;
(* stop the program.  the procedure performs a goto to the end of the
   program.  you must have a label:
      label 1;
   declared, and also the end of the program must have this label:
      1: end.
   examples are in the module libraries.
   this is the only goto in the delila system. *)
begin
      writeln(output,' program halt.');
      goto 1
end;
(* end module halt version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module interact.clearstring *)
procedure clearstring(var ribbon: string);
(* empty the string *)
var   index: integer; (* to the ribbon *)
begin (* clearstring *)
      with ribbon do begin
         for index := 1 to maxstring do letters[index] := ' ';
         length := 0;
         current := 0;
      end
end; (* clearstring *)
(* end module interact.clearstring version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module interact.getstring *)
procedure getstring(var afile: text; var buffer: string;
                    var gotten: boolean);
(* get a string from a file not using string calls.  this lets one
obtain lines from a file without interactive prompts *)
var   index: integer; (* of buffer *)
begin (* getstring *)
      clearstring(buffer);
      if eof(afile)
      then gotten := false
      else begin
         index := 0;
         while (not eoln(afile)) and (index < maxstring) do begin
            index := succ(index);
            read(afile, buffer.letters[index])
         end;

         if not eoln(afile) then begin
            writeln(output, ' getstring: a line exceeds maximum string size (',
                            maxstring:1,')');
            halt
         end;

         buffer.length := index;
         buffer.current := 1;
         readln(afile);
         gotten := true
      end
end; (* getstring *)
(* end module interact.getstring version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module interact.writestring *)
procedure writestring(var tofile: text; var s: string);
(* write the string s to file tofile, no writeln *)
var   i: integer; (* index to s *)
begin (* writestring *)
      with s do for i := 1 to length do write(tofile, letters[i])
end; (* writestring *)
(* end module interact.writestring version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module filler.fillstring *)
procedure fillstring(var s: string; a: filler);
(* this procedure makes it reasonably easy to fill the string s with
characters.  one calls the procedure as: *)
(*                           1         2         3         4         5 *)
(*                  12345678901234567890123456789012345678901234567890 *)
(*   fillstring(s, 'this-is-the-string                                ');
the two comments make it easy to line the characters up. also, for this
example, it was assumed that the length of filler as defined by the
constant fillermax was 50. *)
var
      length: integer; (* of the string without trailing blanks *)
      index: integer; (* of s *)
begin (* fillstring *)
      clearstring(s);
      length := fillermax;
      while (length > 1) and (a[length] = ' ') do length := pred(length);
      if (length = 1) and (a[length] = ' ') then begin
         writeln(output, 'fillstring: the string is empty');
         halt
      end;

      for index := 1 to length do s.letters[index] := a[index];
      s.length := length;
      s.current := 1
end; (* fillstring *)
(* end module filler.fillstring version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module filler.filltrigger *)
procedure filltrigger(var t: trigger;
                      a: filler);
(* fill the trigger t *)
begin (* filltrigger *)
         fillstring(t.seek,a)
end; (* fillstring *)
(* end module filler.filltrigger version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module trigger.proc *)
(* this module allows one to scan a series of characters, as from
an array or a file, and to "trigger" or detect a simple string
in the series.  the advantage of the trigger is that several triggers
can "observe" a stream of characters at once, each looking for a
different thing.
some other modules required: interact.const, interact.type *)

procedure resettrigger(var t: trigger);
(* reset the trigger to ground state *)
begin (* resettrigger *)
      with t do begin
         state := 0;
         skip := false;
         found := false
      end
end; (* resettrigger *)

procedure testfortrigger(ch: char; var t: trigger);
(* look at the character ch.
   if it is part of the trigger (at the current trigger state),
       then the trigger state goes higher.
   if it is not part of the trigger then the trigger state is reset,
      skip is true and one should skip onward to find the trigger.
   if the trigger is found, found is true. *)
begin (* testfortrigger *)
      with t do begin
         state := succ(state);
(*         if debugging then begin
            writestring(list,seek);
            writeln(list,'testfortrigger seek.letters[',state:1,']:',
                           seek.letters[state],' ch:',ch);
         end;*)
         if seek.letters[state] = ch
         then begin
            skip := false;
            if state = seek.length then found := true
                                   else found := false
         end
         else begin (* reset trigger *)
            state := 0;
            skip := true;
            found := false
         end
      end
end; (* testfortrigger *)
(* end module trigger.proc version = 4.09; (@ of prgmod.p 1990 May 18 *)

(* begin module censor.tocharacter *)
function tocharacter(n: integer): char;
(* convert the integer n to a character *)
begin
  tocharacter := chr(n + ord('0'));
end;
(* end module censor.tocharacter *)

(* begin module censor.writeedit *)
procedure writeedit(var tofile: text; state: integer; s, e: string);
(* write the string s to file tofile, with writeln.  Edit out the portions
of s for which e is '2','3','5', or '6' *)
var
   doreturn: boolean; (* if there were any printed characters, be sure to
     produce a carriage return for the line. *)
   i: integer; (* index to s *)
   printing: boolean; (* if true, print *)
begin (* writeedit *)
   doreturn := false;
   if s.length > 0
   then for i := 1 to s.length do begin
      printing := e.letters[i] in ['0','1','4'];
      if printing then begin
         write(tofile, s.letters[i]);
         doreturn := true
      end
      else doreturn := false
   end
   else doreturn := (state = 0) or (state = 1) or (state = 4);

   (* if we are at the end of the line, and the state is to print,
      put a carriage return *)
   if doreturn then writeln(tofile);
end; (* writeedit *)
(* end module censor.writeedit *)

(* begin module censor.themain *)
procedure themain(var infile, outfile: text);
(* the main procedure of the program.  NOTE: '@' represents '*' in comments
below. *)
var
   buffer: string; (* buffer of a line from infile *)
   c: char; (* a character from the buffer *)
   debugging: boolean; (* set to true if debugging *)
   idline: string; (* identifier line for the states *)
   gotten: boolean; (* if true, a line was obtained *)
   state: integer; (* state of the program.
      state = 0; scan and copy, outside comments
                when     '(@' is found, move to state 1             t0a
                when      '{' is found, move to state 4             t0b

      state = 1; scan and copy, copy program comments 
                when     '@)' is found, move to state 0             t1a
                when     '[[' is found, move to state 2             t1b
      state = 2; scan and delete comment text (including comments)
                when '(@[[@)' is found, move to state 3             t2a
                when     ']]' is found, move to state 1             t2b
      state = 3; scan and delete program text (including comments)
                when '(@]]@)' is found, move to state 0             t3a

      state = 4; scan and copy, copy program comments
                when      '}' is found, move to state 0             t4a
                when     '[[' is found, move to state 5             t4b
      state = 5; scan and delete comment text (including comments)
                when     ']]' is found, move to state 4             t5a
                when   '{[[}' is found, move to state 6             t5b
      state = 6; scan and delete program text (including comments)
                when   '{]]}' is found, move to state 0             t6a
*)
   readpoint: integer; (* the point we are 'reading' in the buffer *)
   t0a,t0b,t1a,t1b,t2a,t2b,t3a,t4a,t4b,t5a,t5b,t6a:
       trigger; (* triggers for each state *)
procedure fillback(back: integer);
(* fill the buffer back several spots up to the current spot *)
var
   spot: integer; (* a point on the buffer *)
begin
   if debugging then begin
       writestring(outfile,idline); writeln(outfile,'|');
   end;
   for spot := readpoint - back to readpoint
   do idline.letters[spot] := tocharacter(state)
end;
begin
   debugging := false; (* set to true if debugging *)
   state := 0;
              (*    123456789- *)

   filltrigger(t0a,'(*        ');
   filltrigger(t0b,'{         ');
   filltrigger(t1a,'*)        ');
   filltrigger(t1b,'[[        ');
   filltrigger(t2a,'(*[[*)    ');
   filltrigger(t2b,']]        ');
   filltrigger(t3a,'(*]]*)    ');
   filltrigger(t4a,'}         ');
   filltrigger(t4b,'[[        ');
   filltrigger(t5a,']]        ');
   filltrigger(t5b,'{[[}      ');
   filltrigger(t6a,'{]]}      ');

   while not eof(infile) do begin
      getstring(infile,buffer,gotten);
      if gotten then begin
         if debugging then begin
            writestring(outfile,buffer); writeln(outfile);
         end;
         clearstring(idline);

         resettrigger(t0a);
         resettrigger(t0b);
         resettrigger(t1a);
         resettrigger(t1b);
         resettrigger(t2a);
         resettrigger(t2b);
         resettrigger(t3a);
         resettrigger(t4a);
         resettrigger(t4b);
         resettrigger(t5a);
         resettrigger(t5b);
         resettrigger(t6a);

         idline.length := buffer.length;
         for readpoint := 1 to buffer.length do begin
             idline.letters[readpoint] := tocharacter(state);
             c := buffer.letters[readpoint];

             testfortrigger(c,t0a);
             testfortrigger(c,t0b);
             testfortrigger(c,t1a);
             testfortrigger(c,t1b);
             testfortrigger(c,t2a);
             testfortrigger(c,t2b);
             testfortrigger(c,t3a);
             testfortrigger(c,t4a);
             testfortrigger(c,t4b);
             testfortrigger(c,t5a);
             testfortrigger(c,t5b);
             testfortrigger(c,t6a);

             case state of
                0: begin
                   if t0a.found then begin
                      state := 1;
                      fillback(1);
                   end
                   else if t0b.found then begin
                      state := 4;
                      fillback(0);
                   end;
                end;
                1: begin
                   if t1a.found
                   then state := 0
                   else if t1b.found then begin
                      state := 2;
                      fillback(1);
                   end;
                end;
                2: begin
                   if t2a.found then begin
                      state := 3;
                      fillback(5);
                   end
                   else if t2b.found then begin
                      state := 1;
                   end;
                end;
                3: begin
                   if t3a.found then begin
                      state := 0;
                   end;
                end;
                4: begin
                   if t4a.found then begin
                      state := 0;
                   end
                   else if t4b.found then begin
                      state := 5;
                      fillback(1);
                   end
                end;
                5: begin
                   if t5a.found then begin
                      state := 4;
                   end
                   else if t5b.found then begin
                      state := 6;
                      fillback(3);
                   end
                end;
                6: begin
                   if t6a.found then begin
                      state := 0;
                   end;
                end;
             end;

         end;
         if debugging then begin
            writestring(outfile,idline); writeln(outfile,'|');
         end;
         writeedit(outfile,state,buffer,idline);
      end;
   end;
end;
(* end module censor.themain *)

begin
   themain(input,output);
1: end.