PC Plus SuperCD (UK) 2000 March/pcp161b.iso/handson/archive/Issue160/files/SyntaxEditor/syntax.pas

Pascal/Delphi Source File | 1999-10-18 | 10.3 KB | 339 lines

unit syntax;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, ExtCtrls,
  EditConsts;

const
     // possible values of status parameter
     SUCCESS = 1;
     NOERROR = 2;
     READERROR = 3;

type

  chararray = array[0..255] of char;
     // ReadStatus defines type of the status parameter
  ReadStatus = SUCCESS..READERROR;

    function KeyWord( token : string ) : boolean;
    procedure WriteRTFHeader( ms : TMemoryStream );
    procedure WriteRTFTerminator( ms : TMemoryStream );
    procedure HandleCR(c : char; msout : TMemoryStream);
    procedure HandleSpecialChars( c : char; msout : TMemoryStream );
    procedure processStream( msin, msout : TMemoryStream );
    procedure ReadChar( var c : char; msin : TMemoryStream; var status : ReadStatus );
    procedure ReadToken( var token : chararray; msin : TMemoryStream; var c : char; var status : ReadStatus );
    procedure WriteToken( var token : chararray; msout : TMemoryStream; var status : ReadStatus );
    procedure ReadWriteToken( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure ReadWriteComment( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure ReadWriteStarComment( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure ReadWriteLineComment( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure ReadWriteString( msin, msout : TMemoryStream; var c : char; var status : ReadStatus );
    procedure WriteChar( c : char; msout : TMemoryStream );
    procedure ReadWriteChar( var c : char; msin, msout : TMemoryStream; var status : ReadStatus );


implementation

function KeyWord( token : string ) : boolean;
// if token is a keyword, return true
var
   isKW : boolean;
   i    : integer;
begin
   isKW := false;
   i := 0;
   while ((i <= NUMKEYWORDS) and (isKW = false )) do
   begin
   //!! Test is case-insensitive (OK for Pascal. Change this for C or Java)
      if lowercase(token) = KeyWords[i] then
         isKW := true
      else
         Inc(i);
   end;
   result := isKW;
end;


procedure WriteRTFHeader( ms : TMemoryStream );
begin
    try
      ms.WriteBuffer( RTFHEADER, strlen(RTFHEADER) );
      ms.WriteBuffer( RTFCTABLE, strlen(RTFCTABLE) );
   except
      on EWriteError do
         ShowMessage( 'Failed to write header and ctable to stream!' );
   end;
end;

procedure WriteRTFTerminator( ms : TMemoryStream );
begin
   ms.WriteBuffer(TERMINATOR, sizeof(TERMINATOR)); // terminate RTF buffer
end;

procedure HandleCR(c : char; msout : TMemoryStream);
// deal with CR - write rtf '\para' code to stream
begin
   if c = CR then
      msout.WriteBuffer( PARCODE, strlen( PARCODE ) );
end;

procedure HandleSpecialChars( c : char; msout : TMemoryStream );
// deal with special RTF chars - add '\'
begin
   if c in SPECIALRTFCHARS then
       msout.WriteBuffer( SLASH, sizeof( SLASH ) )
   else HandleCR( c, msout );
end;

procedure WriteChar( c : char; msout : TMemoryStream );
// Write both normal chars and special rtf chars
begin  // deal with slashes and CRs
      HandleSpecialChars(c, msout );
       // then write the char
      msout.WriteBuffer( c, sizeof( c ) );
end;

procedure ReadWriteChar( var c : char; msin, msout : TMemoryStream;
                                     var status : ReadStatus );
// write any char that is not written as part of a token, string or comment
begin
   WriteChar( c, msout );
   ReadChar( c, msin, status );
end;

procedure ReadChar( var c : char; msin : TMemoryStream;
                           var status : ReadStatus );
begin
  status := NOERROR;
  try
    if msin.position < msin.size then
       msin.ReadBuffer( c, sizeof(c) );    // read one char at a time
  except
    on EReadError do
       status := READERROR;
  end;
end;

procedure ReadToken( var token : chararray; msin : TMemoryStream;
          var c : char; var status : ReadStatus );
// try to read an alphanumeric token
var
   i : integer;
begin
  status := NOERROR;
  i := 0;
  token := '';
  try
    while (c in ALPHANUMERIC) do
    begin
       token[i] := c;
       INC(i);
       ReadChar( c, msin, status );     // read one char at a time
    end;
    if token <> '' then
       status := SUCCESS;
  except
    on EReadError do
       status := READERROR;
  end;
end;

procedure WriteToken( var token : chararray; msout : TMemoryStream; var status : ReadStatus );
begin
   status := NOERROR;
   if KeyWord(token) then
   begin
      msout.WriteBuffer( KWCODE, length( KWCODE ) );
      msout.WriteBuffer( token, length( token ) );
      msout.WriteBuffer( PLAINCODE, length( PLAINCODE ) );
   end
   else
      msout.WriteBuffer( token, length( token ) );
end;


procedure ReadWriteToken( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
var
   token : chararray;
begin
   ReadToken(token,msin,c,status);
   if status = SUCCESS then
      WriteToken(token,msout,status);
end;

procedure ReadWriteComment( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
// try to read and write a standard curly-brace { } comment
begin
  status := NOERROR;
//   try           // !! add error handling here
   if c = '{' then
   begin
     msout.WriteBuffer( COMMENTCODE, strlen( COMMENTCODE ) );
     msout.WriteBuffer( SLASH, sizeof( SLASH ) );
     msout.WriteBuffer( c, sizeof( c ) );
     while (c <> '}') and (msin.position < msin.size) do
     begin
        msin.ReadBuffer( c, sizeof( c ) );
        if c <> '}' then
          WriteChar( c, msout );
     end;
     if msin.position < msin.size then
     begin
        msout.WriteBuffer( SLASH, sizeof( SLASH ) );
        msout.WriteBuffer( c, sizeof( c ) );
        msout.WriteBuffer(PLAINCODE, strlen(PLAINCODE));
        msin.ReadBuffer( c, sizeof( c ) );
        status := SUCCESS;
     end;
   end;
end;

procedure ReadWriteStarComment( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
// try to read and write a brace-star (* *) comment
var
   c2 : char;
   CommentEnd, StarFound : boolean;
begin
  status := NOERROR;
  c2 := '#';
  CommentEnd := false;
  StarFound := false;
//   try           // !! add error handling- set status
   if c = '(' then
   begin
      ReadChar(c2,msin,status);
      if c2 <> '*' then
      begin        // if not a comment then
          WriteChar( c, msout );
          c := c2; // return c2
      end
      else
      begin       // if this is a comment
        msout.WriteBuffer( COMMENTCODE, strlen( COMMENTCODE ) );
        msout.WriteBuffer( c, sizeof( c ) );
        msout.WriteBuffer( c2, sizeof( c2 ) );
        while not (CommentEnd) and (msin.position < msin.size) do
        begin
           ReadChar( c, msin, status );
           if (c = ')') and StarFound then
              CommentEnd := true
           else
           if c = '*' then
              StarFound := true
           else StarFound := false;
           WriteChar( c, msout );
        end;  // while not (CommentEnd) and (msin.position < msin.size)
        if msin.position < msin.size then
        begin
           msout.WriteBuffer(PLAINCODE, strlen(PLAINCODE));
           msin.ReadBuffer( c, sizeof( c ) );
        end;
      end;  // if this is a comment
      status := SUCCESS; // set this since c was handled even if no comment
   end;     // if c = '('
end;

procedure ReadWriteLineComment( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
// try to read and write a single-line // comment
var
   c2 : char;
begin
  status := NOERROR;
  c2 := '#';
//   try           // !! add error handling
   if c = '/' then
   begin
      ReadChar(c2,msin,status);
      if c2 <> '/' then
      begin        // if not a comment then
          WriteChar( c, msout );
          c := c2; // return c2
      end
      else
      begin       // if this is a comment
        msout.WriteBuffer( COMMENTCODE, strlen( COMMENTCODE ) );
        msout.WriteBuffer( c, sizeof( c ) );
        msout.WriteBuffer( c2, sizeof( c2 ) );
        while not (c = CR) and (msin.position < msin.size) do
        begin
           ReadChar( c, msin, status );
           WriteChar( c, msout );
        end;
        if msin.position < msin.size then
        begin
           msout.WriteBuffer(PLAINCODE, strlen(PLAINCODE));
           msin.ReadBuffer( c, sizeof( c ) );
        end;
      end;
       status := SUCCESS;
   end;
end;


procedure ReadWriteString( msin, msout : TMemoryStream;
          var c : char; var status : ReadStatus );
begin
  status := NOERROR;
//   try           // !! add error handling
   if c = '''' then
   begin
     msout.WriteBuffer( STRINGCODE, strlen( STRINGCODE ) );
     msout.WriteBuffer( c, sizeof( c ) );
     c := '#';
     while (c <> '''') and (msin.position < msin.size) do
     begin
        msin.ReadBuffer( c, sizeof( c ) );
        WriteChar( c, msout );
     end;
     if msin.position < msin.size then
     begin
        msout.WriteBuffer(PLAINCODE, strlen(PLAINCODE));
        msin.ReadBuffer( c, sizeof( c ) );
        status := SUCCESS;
     end;
   end;
end;

procedure processStream( msin, msout : TMemoryStream );
var
   c : char;
   status : ReadStatus;
begin
   Screen.Cursor := crHourglass;       // Show hourglass cursor
   c := '#';
   // start by reading 1st char
   if msin.position < msin.size then
      ReadChar(c,msin,status);
   try
      while msin.position < msin.size do     // iterate through input stream
      begin
         ReadWriteToken( msin,msout,c,status);
         if status <> SUCCESS then
           ReadWriteString( msin,msout,c,status);
         if status <> SUCCESS then
           ReadWriteComment( msin,msout,c,status);
         if status <> SUCCESS then
           ReadWriteStarComment( msin,msout,c,status);
         if status <> SUCCESS then
           ReadWriteLineComment( msin,msout,c,status);
         if status <> SUCCESS then
            ReadWriteChar(c, msin, msout, status );
      end; // while msin.position < msin.size
   finally
     Screen.Cursor := crDefault;    // restore normal cursor
   end;
end;



end.