Externals/crystaledit/editlib/fortran.cpp

   1 ///////////////////////////////////////////////////////////////////////////
   2 //  File:    fortran.cpp
   3 //  Version: 1.1.0.4
   4 //  Updated: 19-Jul-1998
   5 //
   6 //  Copyright:  Ferdinand Prantl, portions by Stcherbatchenko Andrei
   7 //  E-mail:     prantl@ff.cuni.cz
   8 //
   9 //  FORTRAN syntax highlighing definition
  10 //
  11 //  You are free to use or modify this code to the following restrictions:
  12 //  - Acknowledge me somewhere in your about box, simple "Parts of code by.."
  13 //  will be enough. If you can't (or don't want to), contact me personally.
  14 //  - LEAVE THIS HEADER INTACT
  15 ////////////////////////////////////////////////////////////////////////////
  16
  17 #include "StdAfx.h"
  18 #include "crystallineparser.h"
  19 #include "SyntaxColors.h"
  20 #include "string_util.h"
  21
  22 #ifdef _DEBUG
  23 #define new DEBUG_NEW
  24 #endif
  25
  26 //  C++ keywords (MSVC5.0 + POET5.0)
  27 static LPCTSTR s_apszFortranKeywordList[] =
  28   {
  29     _T (".and."),
  30     _T (".not."),
  31     _T (".or."),
  32     _T ("abs"),
  33     _T ("achar"),
  34     _T ("acos"),
  35     _T ("adjustl"),
  36     _T ("adjustr"),
  37     _T ("aimag"),
  38     _T ("aint"),
  39     _T ("all"),
  40     _T ("allocatable"),
  41     _T ("allocate"),
  42     _T ("allocated"),
  43     _T ("anint"),
  44     _T ("any"),
  45     _T ("asin"),
  46     _T ("assignment"),
  47     _T ("associated"),
  48     _T ("atan"),
  49     _T ("atan2"),
  50     _T ("backspace"),
  51     _T ("bit_size"),
  52     _T ("block"),
  53     _T ("blockdata"),
  54     _T ("btest"),
  55     _T ("call"),
  56     _T ("call"),
  57     _T ("case"),
  58     _T ("ceiling"),
  59     _T ("char"),
  60     _T ("character"),
  61     _T ("close"),
  62     _T ("cmplx"),
  63     _T ("common"),
  64     _T ("complex"),
  65     _T ("conjg"),
  66     _T ("contains"),
  67     _T ("continue"),
  68     _T ("cos"),
  69     _T ("cosh"),
  70     _T ("count"),
  71     _T ("cshift"),
  72     _T ("cycle"),
  73     _T ("data"),
  74     _T ("date_and_time"),
  75     _T ("dble"),
  76     _T ("deallocate"),
  77     _T ("default"),
  78     _T ("digits"),
  79     _T ("dim"),
  80     _T ("dimension"),
  81     _T ("do"),
  82     _T ("dot_product"),
  83     _T ("double"),
  84     _T ("doubleprecision"),
  85     _T ("dprod"),
  86     _T ("else"),
  87     _T ("elseif"),
  88     _T ("elsewhere"),
  89     _T ("end"),
  90     _T ("endblock"),
  91     _T ("endblockdata"),
  92     _T ("enddo"),
  93     _T ("endfile"),
  94     _T ("endif"),
  95     _T ("endinterface"),
  96     _T ("endselect"),
  97     _T ("endtype"),
  98     _T ("endwhere"),
  99     _T ("entry"),
 100     _T ("eoshift"),
 101     _T ("epsilon"),
 102     _T ("equivalence"),
 103     _T ("exit"),
 104     _T ("exp"),
 105     _T ("exponent"),
 106     _T ("external"),
 107     _T ("file"),
 108     _T ("floor"),
 109     _T ("format."),
 110     _T ("fraction"),
 111     _T ("function"),
 112     _T ("go"),
 113     _T ("goto"),
 114     _T ("huge"),
 115     _T ("iachar"),
 116     _T ("iand"),
 117     _T ("ibclr"),
 118     _T ("ibits"),
 119     _T ("ibset"),
 120     _T ("ichar"),
 121     _T ("ieor"),
 122     _T ("if"),
 123     _T ("implicit"),
 124     _T ("in"),
 125     _T ("index"),
 126     _T ("inout"),
 127     _T ("inquire"),
 128     _T ("int"),
 129     _T ("integer"),
 130     _T ("intent"),
 131     _T ("interface"),
 132     _T ("intrinsic"),
 133     _T ("iolength"),
 134     _T ("ior"),
 135     _T ("ishftc"),
 136     _T ("ishift"),
 137     _T ("kind"),
 138     _T ("lbound"),
 139     _T ("len"),
 140     _T ("len_trim"),
 141     _T ("lge"),
 142     _T ("lgt"),
 143     _T ("lle"),
 144     _T ("llt"),
 145     _T ("log"),
 146     _T ("log10"),
 147     _T ("logical"),
 148     _T ("matmul"),
 149     _T ("max"),
 150     _T ("maxexponent"),
 151     _T ("maxloc"),
 152     _T ("maxval"),
 153     _T ("merge"),
 154     _T ("min"),
 155     _T ("minexponent"),
 156     _T ("minloc"),
 157     _T ("minval"),
 158     _T ("mod"),
 159     _T ("module"),
 160     _T ("modulo"),
 161     _T ("mvbits"),
 162     _T ("namelist"),
 163     _T ("nearest"),
 164     _T ("nint"),
 165     _T ("none"),
 166     _T ("nullify"),
 167     _T ("only"),
 168     _T ("open"),
 169     _T ("operator"),
 170     _T ("optional"),
 171     _T ("out"),
 172     _T ("pack"),
 173     _T ("parameter"),
 174     _T ("pointer"),
 175     _T ("precision"),
 176     _T ("present"),
 177     _T ("print"),
 178     _T ("private"),
 179     _T ("procedure"),
 180     _T ("product"),
 181     _T ("program"),
 182     _T ("public"),
 183     _T ("radix"),
 184     _T ("random_number"),
 185     _T ("random_seed"),
 186     _T ("rangereal"),
 187     _T ("read"),
 188     _T ("real"),
 189     _T ("recursive"),
 190     _T ("repeat"),
 191     _T ("reshape"),
 192     _T ("result"),
 193     _T ("return"),
 194     _T ("rewrind"),
 195     _T ("rrspacing"),
 196     _T ("save"),
 197     _T ("scale"),
 198     _T ("scan"),
 199     _T ("select"),
 200     _T ("selectcase"),
 201     _T ("selected_int_kind"),
 202     _T ("selected_real_kind"),
 203     _T ("sequence"),
 204     _T ("set_exponent"),
 205     _T ("shape"),
 206     _T ("sign"),
 207     _T ("sin"),
 208     _T ("sinh"),
 209     _T ("size"),
 210     _T ("spacing"),
 211     _T ("spread"),
 212     _T ("sqrt"),
 213     _T ("stop"),
 214     _T ("subroutine"),
 215     _T ("sum"),
 216     _T ("system_clock"),
 217     _T ("tan"),
 218     _T ("tanh"),
 219     _T ("target"),
 220     _T ("then"),
 221     _T ("tiny"),
 222     _T ("to"),
 223     _T ("transfer"),
 224     _T ("transpose"),
 225     _T ("trim"),
 226     _T ("type"),
 227     _T ("unbound"),
 228     _T ("unpack"),
 229     _T ("use"),
 230     _T ("verify"),
 231     _T ("where"),
 232     _T ("while"),
 233     _T ("write"),
 234   };
 235
 236 static bool
 237 IsFortranKeyword (LPCTSTR pszChars, int nLength)
 238 {
 239   return ISXKEYWORDI (s_apszFortranKeywordList, pszChars, nLength);
 240 }
 241
 242 DWORD
 243 CrystalLineParser::ParseLineFortran (DWORD dwCookie, const TCHAR *pszChars, int nLength, TEXTBLOCK * pBuf, int &nActualItems)
 244 {
 245   if (nLength == 0)
 246     return dwCookie & COOKIE_EXT_COMMENT;
 247
 248   bool bFirstChar = (dwCookie & ~COOKIE_EXT_COMMENT) == 0;
 249   bool bRedefineBlock = true;
 250   bool bDecIndex = false;
 251   int nIdentBegin = -1;
 252   int nPrevI = -1;
 253   int I=0;
 254   for (I = 0;; nPrevI = I, I = static_cast<int>(::CharNext(pszChars+I) - pszChars))
 255     {
 256       if (I == nPrevI)
 257         {
 258           // CharNext did not advance, so we're at the end of the string
 259           // and we already handled this character, so stop
 260           break;
 261         }
 262
 263       if (bRedefineBlock)
 264         {
 265           int nPos = I;
 266           if (bDecIndex)
 267             nPos = nPrevI;
 268           if (dwCookie & (COOKIE_COMMENT | COOKIE_EXT_COMMENT))
 269             {
 270               DEFINE_BLOCK (nPos, COLORINDEX_COMMENT);
 271             }
 272           else if (dwCookie & (COOKIE_CHAR | COOKIE_STRING))
 273             {
 274               DEFINE_BLOCK (nPos, COLORINDEX_STRING);
 275             }
 276           else
 277             {
 278               if (xisalnum (pszChars[nPos]) || pszChars[nPos] == '.' && nPos > 0 && (!xisalpha (*::CharPrev(pszChars, pszChars + nPos)) && !xisalpha (*::CharNext(pszChars + nPos))))
 279                 {
 280                   DEFINE_BLOCK (nPos, COLORINDEX_NORMALTEXT);
 281                 }
 282               else
 283                 {
 284                   DEFINE_BLOCK (nPos, COLORINDEX_OPERATOR);
 285                   bRedefineBlock = true;
 286                   bDecIndex = true;
 287                   goto out;
 288                 }
 289             }
 290           bRedefineBlock = false;
 291           bDecIndex = false;
 292         }
 293 out:
 294
 295       // Can be bigger than length if there is binary data
 296       // See bug #1474782 Crash when comparing SQL with with binary data
 297       if (I >= nLength || pszChars[I] == 0)
 298         break;
 299
 300       if (dwCookie & COOKIE_COMMENT)
 301         {
 302           DEFINE_BLOCK (I, COLORINDEX_COMMENT);
 303           dwCookie |= COOKIE_COMMENT;
 304           break;
 305         }
 306
 307       //  String constant "...."
 308       if (dwCookie & COOKIE_STRING)
 309         {
 310           if (pszChars[I] == '"' && (I == 0 || I == 1 && pszChars[nPrevI] != '\\' || I >= 2 && (pszChars[nPrevI] != '\\' || *::CharPrev(pszChars, pszChars + nPrevI) == '\\')))
 311             {
 312               dwCookie &= ~COOKIE_STRING;
 313               bRedefineBlock = true;
 314             }
 315           continue;
 316         }
 317
 318       //  Char constant '..'
 319       if (dwCookie & COOKIE_CHAR)
 320         {
 321           if (pszChars[I] == '\'' && (I == 0 || I == 1 && pszChars[nPrevI] != '\\' || I >= 2 && (pszChars[nPrevI] != '\\' || *::CharPrev(pszChars, pszChars + nPrevI) == '\\')))
 322             {
 323               dwCookie &= ~COOKIE_CHAR;
 324               bRedefineBlock = true;
 325             }
 326           continue;
 327         }
 328
 329       if (pszChars[I] == '!' || !I && (pszChars[I] == 'C' || pszChars[I] == 'c'))
 330         {
 331           DEFINE_BLOCK (I, COLORINDEX_COMMENT);
 332           dwCookie |= COOKIE_COMMENT;
 333           break;
 334         }
 335
 336       //  Normal text
 337       if (pszChars[I] == '"')
 338         {
 339           DEFINE_BLOCK (I, COLORINDEX_STRING);
 340           dwCookie |= COOKIE_STRING;
 341           continue;
 342         }
 343       if (pszChars[I] == '\'')
 344         {
 345           // if (I + 1 < nLength && pszChars[I + 1] == '\'' || I + 2 < nLength && pszChars[I + 1] != '\\' && pszChars[I + 2] == '\'' || I + 3 < nLength && pszChars[I + 1] == '\\' && pszChars[I + 3] == '\'')
 346           if (!I || !xisalnum (pszChars[nPrevI]))
 347             {
 348               DEFINE_BLOCK (I, COLORINDEX_STRING);
 349               dwCookie |= COOKIE_CHAR;
 350               continue;
 351             }
 352         }
 353
 354       if (bFirstChar)
 355         {
 356           if (!xisspace (pszChars[I]))
 357             bFirstChar = false;
 358         }
 359
 360       if (pBuf == nullptr)
 361         continue;               //  We don't need to extract keywords,
 362       //  for faster parsing skip the rest of loop
 363
 364       if (xisalnum (pszChars[I]) || pszChars[I] == '.' && I > 0 && (!xisalpha (pszChars[nPrevI]) && !xisalpha (pszChars[I + 1])))
 365         {
 366           if (nIdentBegin == -1)
 367             nIdentBegin = I;
 368         }
 369       else
 370         {
 371           if (nIdentBegin >= 0)
 372             {
 373               if (IsFortranKeyword (pszChars + nIdentBegin, I - nIdentBegin))
 374                 {
 375                   DEFINE_BLOCK (nIdentBegin, COLORINDEX_KEYWORD);
 376                 }
 377               else if (IsXNumber (pszChars + nIdentBegin, I - nIdentBegin))
 378                 {
 379                   DEFINE_BLOCK (nIdentBegin, COLORINDEX_NUMBER);
 380                 }
 381               bRedefineBlock = true;
 382               bDecIndex = true;
 383               nIdentBegin = -1;
 384             }
 385         }
 386     }
 387
 388   if (nIdentBegin >= 0)
 389     {
 390       if (IsFortranKeyword (pszChars + nIdentBegin, I - nIdentBegin))
 391         {
 392           DEFINE_BLOCK (nIdentBegin, COLORINDEX_KEYWORD);
 393         }
 394       else if (IsXNumber (pszChars + nIdentBegin, I - nIdentBegin))
 395         {
 396           DEFINE_BLOCK (nIdentBegin, COLORINDEX_NUMBER);
 397         }
 398     }
 399
 400   if (pszChars[nLength - 1] != '\\' || IsMBSTrail(pszChars, nLength - 1))
 401     dwCookie &= COOKIE_EXT_COMMENT;
 402   return dwCookie;
 403 }