cplex.pas

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

         ReadChar;
   end;

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

   { Return a '(row, col)' string from the scanner's stream. }
   function LEXOBJ.Posn:string;
   begin
      Posn := f^.Posn;
   end;

{-----------------------------TheCurChar-----------------------------------}

   function LEXOBJ.TheCurChar:char;
   begin
      TheCurChar := CurChar;
   end;

{-----------------------------FindCharClass--------------------------------}

   { Classify the character ch. }
   function LexObj.FindCharClass (ch:char):CharClass;
   var
      ChCl: CharClass;
   begin
      { Windows API function to determine if ch is alphabetical. }
      if IsCharAlpha (ch) then
         FindCharClass := LET
      { use lookup table }
      else FindCharClass := CharClassArray[ord(ch)];

(*
      FindCharClass := Othr;
      {$IFDEF WINDOWS}
      { Windows API function to determine if ch is alphabetical. }
      if IsCharAlpha (ch) then
         FindCharClass := LET
      {$ELSE}
      if ch in ['A'..'Z','a'..'z'] then
         FindCharClass := LET
      {$ENDIF}
      else if ch in ['0'..'9'] then
              FindCharClass := DIG
           else for ChCl := succ (DIG) to pred (OTHR) do
                    if CharClassLit[ChCl] = ch then
                       FindCharClass := ChCl;
*)
   end;

{-----------------------------ClassifyChar---------------------------------}

   procedure LexObj.ClassifyChar (ch:char);
(*   var
      ChCl: CharClass;
*)
   begin
      CurCharClass := FindCharClass (ch);
   end;

{-----------------------------SymbolType-----------------------------------}

   function LEXOBJ.SymbolType:CHARCLASS;
   begin
      SymbolType := CurCharClass;
   end;

{-----------------------------GetSymbol------------------------------------}

   { Get a symbol from the input stream. }
   procedure LexObj.GetSymbol;
   begin
      ReadChar;
      case CurChar of
         #0: CurChar := EF;
         #13: ReadChar;
         end;
      ClassifyChar (CurChar);
   end;

{-----------------------------GoodToken------------------------------------}

   function LexObj.GoodToken:Boolean;
   begin
      GoodToken := (tt <> ttBADTOKEN);
   end;

{$IFDEF DEBUG}
{-----------------------------ShowTokenType--------------------------------}

   procedure LexObj.ShowTokenType;
   var
      s: string;
   begin
      case tt of
         ttSPACE:      s := 'SPACE';
         ttEQUALS:     s := 'EQUALS';
         ttOPENPAR:    s := 'OPENPAR';
         ttCLOSEPAR:   s := 'CLOSEPAR';
         ttMINUS:      s := 'MINUS';
         ttHASH:       s := 'HASH';
         ttCOLON:      s := 'COLON';
         ttSEMICOLON:  s := 'SEMICOLON';
         ttPERIOD:     s := 'PERIOD';
         ttCOMMA:      s := 'COMMA';
         ttASTERIX:    s := 'ASTERIX';
         ttEOFL :      s := 'EOFL';
         ttIDENTIFIER: s := 'IDENTIFIER';
         ttNUMBER:     s := 'NUMBER';
         ttOTHER:      s := 'OTHER';
         end;
      writeln (output, '  ',s);
   end;
{$ENDIF}

{-----------------------------ClassifyToken--------------------------------}

   procedure LexObj.ClassifyToken;
   begin
      if (B.Count = 1) then
         tt := TOKENARRAY[FindCharClass (B.FirstChar)]
(*                            begin
         case FindCharClass (B.FirstChar) of
            SPACE: tt := ttSPACE;
            EQL:   tt := ttEQUALS;
            LPAR:  tt := ttOPENPAR;
            RPAR:  tt := ttCLOSEPAR;
            MINUS: tt := ttMINUS;
            HSH:   tt := ttHASH;
            COLON: tt := ttCOLON;
            SEM:   tt := ttSEMICOLON;
            POINT: tt := ttPERIOD;
            COMMA: tt := ttCOMMA;
            AST:   tt := ttASTERIX;
            ENDFL: tt := ttEOFL;
            DIG:   tt := ttNUMBER;
            LET:   tt := ttIDENTIFIER;
            else   tt := ttOTHER;
            end;
         end
*)
      else begin
         case FindCharClass (B.FirstChar) of
            DIG, MINUS: tt := ttNUMBER;
            else tt := ttIDENTIFIER;
            end;
         end;
   end;

{-----------------------------GetToken-------------------------------------}

   { Get the next token from the stream, skipping over comments. }
   procedure LexObj.GetToken;
   begin
      Re_set;
      while (st <> ACCEPTED) and (st <> QUIT) do begin
         case st of
            START:
               case CurCharClass of
                  LET:   begin st := GET_ID; ac := AS; end;
                  MINUS,
                  DIG:   begin st := GET_NUMBER; ac := AS; end;
                  QUOTE: begin st:= GET_STRING; ac := S; end;
                  LFEED: ac:= S;
                  LBRACK: begin st:= GET_ECHO; ac := S; end;
                  FIXEDTAB: ac := S;
                  NULL,
                  ENDFL: begin st := ACCEPTED; ac := AE; end;
                  else   begin st := ACCEPTED; ac := AES; end;
                  end;
            GET_NUMBER:
               case curcharclass of
                  DIG:   ac := AS;
                  POINT: begin st := GET_REAL; ac := AS; end;
                  LFEED: begin st := ACCEPTED; ac:= ES; end;
                  NULL,
                  ENDFL: begin st := ACCEPTED; ac := E; end;
                  else   begin st := ACCEPTED; ac := E; end;
                  end;
            GET_REAL:
               case curcharclass of
                  DIG:   ac := AS;
                  LFEED: begin st := ACCEPTED; ac:= S; end;
                  NULL,
                  ENDFL: begin st := ACCEPTED; ac := E; end;
                  else   begin st := ACCEPTED; ac := E; end;
                  end;
            GET_ECHO:
               case curcharclass of
                  LFEED: begin ac := S; end;
                  NULL,
                  ENDFL: begin st := QUIT; ac := E; end;
                  RBRACK:begin st := start; ac := S; end;
                  EXCL:  begin
                            echo := true;
                            st := GET_COMMENT;
                            ac := S;
                         end;
                  else   begin st := GET_COMMENT; ac := S; end;
                  end;
            GET_COMMENT:
               case curcharclass of
                  LFEED: begin
                            if echo then begin
                               ac := LE;
                               DoAction;
                               end;
                            ac := S;
                         end;
                  FIXEDTAB:
                         begin
                            if echo then
                               { Expand the tab }
                               B.ExpandTab;
                            ac := S;
                         end;
                  NULL,
                  ENDFL: begin st := QUIT; ac := E; end;
                  RBRACK: begin
                             if echo then begin
                                ac := LE;
                                DoAction;
                                end;
                             Re_set;
                             ac := S;
                          end;
                  else begin
                     if echo then
                        ac := AS
                     else ac := S;
                     end;
                  end;
            GET_ID:
               case CurCharClass of
                  LET, DIG, POINT, UNDER:
                         ac := AS;
                  NULL,
                  ENDFL: begin st := ACCEPTED;  ac := E; end;
                  LFEED: begin st := ACCEPTED;  ac := ES; end;
                  else   begin st := ACCEPTED;  ac := E; end;
                  end;
            GET_STRING:
               case CurCharClass of
                  QUOTE: begin st := GET_QUOTE; ac := S; end;
                  NULL,
                  ENDFL: begin st := QUIT;      ac := E; end;
                  LFEED: begin st := ACCEPTED;  ac := ES; end;
                  else   ac := AS;
                  end;
            GET_QUOTE:
               case CurCharClass of
                  QUOTE: begin st := GET_STRING; ac := AS; end;
                  NULL,
                  ENDFL: begin st := QUIT;       ac := E; end;
                  else   begin st := ACCEPTED;   ac := E; end;
                  end;
            end;
         DoAction;
         { Check for full buffer }
         if B.Full then
            st := QUIT;
         end;

      if (st = ACCEPTED) then begin
         ClassifyToken;
{         write (output, 'Token buffer = ',B.Return_Buffer,'%');
         ShowTokenType;}
         end
      else tt := ttBADTOKEN;
   end;

{-----------------------------GetNonSpaceToken-----------------------------}

   { Get next non space token. }
   procedure LEXOBJ.GetNonSpaceToken;
   begin
      repeat
         GetToken;
      until (tt <> ttSPACE) or (tt = ttBADTOKEN) or (tt = ttEOFL);
   end;

{-----------------------------Token----------------------------------------}

   { Return the token. }
   function LEXOBJ.Token:string;
   begin
      Token := B.Return_Buffer;
   end;

{-----------------------------UpCaseToken----------------------------------}

   { Return the token converted to upper case. }
   function LEXOBJ.UpCaseToken:string;
   begin
      UpCaseToken := UpCaseStr (B.Return_Buffer);
   end;

{-----------------------------GetNonSpaceSymbol----------------------------}

   { Return a non space symbol, including LF, but
     skip comments. }
   function LEXOBJ.GetNonSpaceSymbol:char;
   begin
      GetSymbol;
      while (CurCharClass in [SPACE, FIXEDTAB, LBRACK]) do
         case CurCharClass of
            SPACE, FIXEDTAB:
               { Skip spaces and tabs }
               GetSymbol;
            LBRACK:
               { Skip comments }
               begin
                  repeat
                     GetSymbol;
                  until (CurCharClass in [RBRACK, ENDFL]);
                  if (CurCharClass <> ENDFL) then
                     GetSymbol;
               end;
            else begin end;
            end; { case...}
      GetNonSpaceSymbol := CurChar;
   end;

end.