cpnex.pas

生物信息学中的遗传数据分析的delphi源码。

                           if (Cmd = BEGIN_CMD) then
                              st := stTYPE
                           else begin
                              Error := erBegin;
                              st := stQUIT;
                              end;
                           end
                        { 26 Sep 1991 bug fix }
                        else st := stQUIT;
                     end;
            stTYPE:  begin
                        L.GetNonSpaceToken;
                        if (L.tt = ttIDENTIFIER) then begin
                          Blk := ClassBlk;
                          case Blk of
                             UNSUPPORTED_BLK:
                                { a valid but unsupported NEXUS block,
                                  skip it and go to next block. }
                                begin
                                   L.GetNonSpaceToken;
                                   if (L.tt = ttSEMICOLON) then begin
                                      SkipBlock;
                                      st := stBEGIN;
                                      end
                                   else begin
                                      Error := erSemicolon;
                                      st := stQUIT;
                                      end;
                                   end;
                             UNRECOGNIZED_BLK:
                                { Flag unrecognized block }
                                begin
                                   Error := erBadBlk;
                                   st := stQuit;
                                end;
                             else st := stSEMI;
                             end; { case }
                          end
                        else begin
                           Error := erSyntax;
                           st := stQUIT;
                           end;
                     end;
            stSEMI:  begin
                        L.GetNonSpaceToken;
                        if (L.tt = ttSEMICOLON) then
                           st := stDONE
                        else begin
                           Error := erSemicolon;
                           st := stQUIT;
                           end;
                     end;
            end;
         end;
   end;

{-----------------------------GetCmd---------------------------------------}

   { Get the next nonspace token. If it is an identifier
     classify it, otherwise set the error flag.

     Token=this token
   }
   procedure NEXUS_OBJ.GetCmd;
   begin
      repeat
         L.GetToken;
      until (L.tt = ttIDENTIFIER) or (L.tt = ttEOFL) or (L.tt = ttBADTOKEN);
      case L.tt of
         ttIDENTIFIER : Cmd   := ClassCmd;
         ttBADTOKEN   : Error := erSyntax;
         ttEOFL       : Error := erEndOfFile;
         else           Error := erSyntax;
         end;
   end;

{-----------------------------IsNexusFile----------------------------------}

   { True if next token is #NEXUS

     Token = This token
   }
   function NEXUS_OBJ.IsNexusFile:Boolean;
   var
      s:string;
   begin
      IsNexusFile := FALSE;
      L.GetToken;
      if (L.tt = ttHASH) then begin
         L.Gettoken;
         s := L.UpCaseToken;
         IsNexusFile := (s = 'NEXUS');
         end;
   end;

{-----------------------------NexusError----------------------------------}

   function NEXUS_OBJ.NexusError:integer;
   begin
      NexusError := Error;
   end;

{-----------------------------Posn-----------------------------------------}

   { Return string with row and column position in stream }
   function NEXUS_OBJ.Posn:string;
   begin
      Posn := L.Posn;
   end;

{-----------------------------Scanner--------------------------------------}

   { Pointer to scanner }
   function NEXUS_OBJ.Scanner:LEXOBJ_PTR;
   begin
      Scanner := @L;
   end;

{$IFDEF debug}

{-----------------------------ShowBlk--------------------------------------}

   { Debug display command }
   procedure NEXUS_OBJ.ShowBlock (var ofile:text);
   begin
      write (ofile, 'BLK = ');
      case Blk of
         UNRECOGNIZED_BLK: writeln (ofile, 'Unrecognized');
         PROFILE_BLK:      writeln (ofile, 'Profile');
         TREES_BLK:        writeln (ofile, 'Trees');
         DISTRIBUTION_BLK: writeln (ofile, 'Distribution');
         end;
   end;

{-----------------------------ShowCmd--------------------------------------}

   { Debug display command }
   procedure NEXUS_OBJ.ShowCmd (var ofile:text);
   begin
      writeln (ofile, 'CMD = ', L.Token, '(',Cmd,')');
   end;

{$ENDIF}

{-----------------------------SkipBlock------------------------------------}

{ Skip over a NEXUS block by skipping over each command until
  the command 'endblock' is reached. Endblock is the last
  command processed.

  At the moment this is rather crude. }
procedure NEXUS_OBJ.SkipBlock;
begin
   GetCmd;
   { Because the block may contain unsupported commands,
     ignore erBadCmd flag. }
   while (Error in [erOK, erBadCmd]) and (Cmd <> END_CMD) do begin
      SkipCmd;
      if (Error in [erOK, erBadCmd]) then
         GetCmd;
      end;
   if (Error = erBadCmd) then
      Error := erOK;
end;

{-----------------------------SkipCmd--------------------------------------}

   { Skip a command by searching for ";"

     Token = last token read
   }
   procedure NEXUS_OBJ.SkipCmd;
   begin
      L.GetToken;
      while (L.tt <> ttSEMICOLON) and (L.tt <> ttEOFL) do
         L.GetToken;
      if (L.tt = ttEOFL) then
         Error := erEndOfFile;
   end;

{-----------------------------StringCmd------------------------------------}

   { Read a "command = 'string'; statement.

     Token = this token
   }
   function NEXUS_OBJ.StringCmd (UpCase: Boolean):string;
   type
      STATES = (stEQUALS, stSTRING, stSEMI, stDONE, stQUIT);
   var
      st   : STATES;
   begin
      StringCmd := '';
      st        := stEQUALS;
      while (st <> stDONE) and (st <> stQUIT) do
         case st of
            stEQUALS: begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttEQUALS) then
                            st := stSTRING
                         else begin
                            Error := erEQUALS;
									 st    := stQUIT;
                            end;
                      end;
            stSTRING: begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttIDENTIFIER) then begin
                            if UpCase then
                               StringCmd := L.UpCaseToken
                            else StringCmd := L.Token;
                            st := stSEMI;
                            end
                         else begin
                            Error := erString;
                            st    := stQUIT;
                            end;
                      end;
            stSEMI:   begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttSEMICOLON) then
                            st := stDONE
                         else begin
                            Error := erSEMICOLON;
                            st    := stQUIT;
                            end;
                      end;
            end;
   end;

{-----------------------------StringField----------------------------------}

   { Read the "command = 'string'" part of a statement.
     No terminating ";"

     Token = this token
   }
   function NEXUS_OBJ.StringField:string;
   type
      STATES = (stEQUALS, stSTRING, stDONE, stQUIT);
   var
      st   : STATES;
   begin
      StringField := '';
      st := stEQUALS;
      while (st <> stDONE) and (st <> stQUIT) do
         case st of
            stEQUALS: begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttEQUALS) then
                            st := stSTRING
                         else begin
                            Error := erEQUALS;
                            st    := stQUIT;
                            end;
                      end;
            stSTRING: begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttIDENTIFIER) then begin
                            StringField := L.UpCaseToken;
                            st := stDONE;
                            end
                         else begin
                            Error :=erString;
                            st    := stQUIT;
                            end;
                      end;
            end;
   end;

{-----------------------------SymbolField----------------------------------}

   { Read the "command = symbol" part of a statement.
     No terminating ";"

     Token = this token
   }
   function NEXUS_OBJ.SymbolField:char;
   type
      STATES = (stEQUALS, stSYMBOL, stDONE, stQUIT);
   var
      st   : STATES;
      s : string;
   begin
      SymbolField := ' ';
      st := stEQUALS;
      while (st <> stDONE) and (st <> stQUIT) do
         case st of
            stEQUALS: begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttEQUALS) then
                            st := stSYMBOL
                         else begin
                            Error := erEQUALS;
                            st    := stQUIT;
                            end;
                      end;
            stSYMBOL: begin
                         L.GetNonSpaceToken;
                         s := L.UpCaseToken;
                         SymbolField := s[1];
                         st := stDONE;
                      end;
            end;
   end;

{-----------------------------ValueField-----------------------------------}

   { Read a "command = value" statement. Return value.

     Token = this token
   }
   function NEXUS_OBJ.ValueField:real;
   type
      STATES = (stEQUALS, stVALUE, stDONE, stQUIT);
   var
      st   : STATES;
      v    : real;
      code : integer;
   begin
      ValueField := 0.0;
      st := stEQUALS;
      while (st <> stDONE) and (st <> stQUIT) do
         case st of
            stEQUALS: begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttEQUALS) then
                            st := stVALUE
                         else begin
                            Error := erEQUALS;
                            st := stQUIT;
                            end;
                      end;
            stVALUE:  begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttNUMBER) then begin
                            Val (L.Token, v, code);
                            if (code = 0) then
                               st := stDONE
                            else begin
                               Error := erInvalidNumber;
                               st    := stQUIT;
                               end
                            end
                         else begin
                            Error := erNumber;
                            st    := stQUIT;
                            end;
                      end;
            end;
      if (st = stDONE) then
         ValueField := v;
   end;

{-----------------------------ValueCmd-------------------------------------}

   { Read a "command = value;" command. Return value.

     Token = this token
   }
   function NEXUS_OBJ.ValueCmd:real;
   type
      STATES = (stEQUALS, stVALUE, stSEMI, stDONE, stQUIT);
   var
      st   : STATES;
      v    : real;
      code : integer;
   begin
      ValueCmd := 0.0;
      st := stEQUALS;
      while (st <> stDONE) and (st <> stQUIT) do
         case st of
            stEQUALS: begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttEQUALS) then
                            st := stVALUE
                         else begin
                            Error := erEQUALS;
                            st := stQUIT;
                            end;
                      end;
            stVALUE:  begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttNUMBER) then begin
                            Val (L.Token, v, code);
                            if (code = 0) then
                               st := stSEMI
                            else begin
                               Error := erInvalidNumber;
                               st    := stQUIT;
                               end
                            end
                         else begin
                            Error := erNumber;
                            st    := stQUIT;
                            end;
                      end;
            stSEMI:   begin
                         L.GetNonSpaceToken;
                         if (L.tt = ttSEMICOLON) then
                            st := stDONE
                         else begin
                            Error := erSemiColon;
                            st    := stQUIT;
                            end;
                      end;
            end;
      if (st = stDONE) then
         ValueCmd := v;
   end;

end.