Revision: 724 Author: eht16 Date: 2006-08-15 10:57:41 -0700 (Tue, 15 Aug 2006) ViewCVS: http://svn.sourceforge.net/geany/?rev=724&view=rev
Log Message: ----------- Added new filetype Fortran 77 (not yet finished).
Modified Paths: -------------- trunk/ChangeLog trunk/data/filetype_extensions.conf trunk/scintilla/KeyWords.cxx trunk/scintilla/Makefile.am trunk/src/filetypes.c trunk/src/filetypes.h trunk/src/highlighting.c trunk/src/highlighting.h trunk/src/msgwindow.c trunk/tagmanager/Makefile.am trunk/tagmanager/parsers.h
Added Paths: ----------- trunk/data/filetypes.fortran trunk/scintilla/LexFortran.cxx trunk/tagmanager/fortran.c Modified: trunk/ChangeLog =================================================================== --- trunk/ChangeLog 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/ChangeLog 2006-08-15 17:57:41 UTC (rev 724) @@ -16,6 +16,12 @@ style(STYLE_DEFAULT). * src/sci_cb.c: Improved HTML "<table>" auto completion to use the indentation better. + * src/filetypes.c, src/highlighting.c, src/msgwindow.c, + data/filetypes.fortran, data/filetype_extensions.conf, + scintilla/Makefile.am, scintilla/LexFortran.cxx, + scintilla/KeyWords.cxx, tagmanager/fortran.c, + tagmanager/Makefile.am, tagmanager/parsers.c: + Added new filetype Fortran 77.
2006-08-14 Nick Treleaven nick.treleaven@btinternet.com
Modified: trunk/data/filetype_extensions.conf =================================================================== --- trunk/data/filetype_extensions.conf 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/data/filetype_extensions.conf 2006-08-15 17:57:41 UTC (rev 724) @@ -8,6 +8,7 @@ Java=*.java; Pascal=*.pas;*.pp;*.inc;*.dpr;*.dpk; ASM=*.asm; +Fortran=*.f;*.f77;*.f90;*.f95;*.for;*.ftn; CAML=*.ml;*.mli; Perl=*.pl;*.perl;*.pm; PHP=*.php;*.php3;*.php4;*.php5;*.html;*.htm;
Added: trunk/data/filetypes.fortran =================================================================== --- trunk/data/filetypes.fortran (rev 0) +++ trunk/data/filetypes.fortran 2006-08-15 17:57:41 UTC (rev 724) @@ -0,0 +1,54 @@ +# For complete documentation of this file, please see Geany's main documentation +[styling] +# foreground;background;bold;italic +default=0x000000;0xffffff;false;false +comment=0x808080;0xffffff;false;false +number=0x007f00;0xffffff;false;false +string=0xff901e;0xffffff;false;false +operator=0x301010;0xffffff;false;false +identifier=0x000000;0xffffff;false;false +string2=0x111199;0xffffff;true;false +word=0x7f0000;0xffffff;true;false +word2=0x000099;0xffffff;true;false +word3=0x3d670f;0xffffff;true;false +preprocessor=0x007f7f;0xffffff;false;false +operator2=0x301010;0xffffff;true;false +continuation=0x000000;0xffffff;false;false +#continuation=0xff901e;0xf0e080;false;false +stringeol=0x000000;0xe0c0e0;false;false +label=0xa861a8;0xffffff;true;false + + +[keywords] +# all items must be in one line +primary=access action advance allocatable allocate apostrophe assign assignment associate asynchronous backspace bind blank blockdata call case character class close common complex contains continue cycle data deallocate decimal delim default dimension direct do dowhile double doubleprecision else elseif elsewhere encoding end endassociate endblockdata enddo endfile endforall endfunction endif endinterface endmodule endprogram endselect endsubroutine endtype endwhere entry eor equivalence err errmsg exist exit external file flush fmt forall form format formatted function go goto id if implicit in include inout integer inquire intent interface intrinsic iomsg iolength iostat kind len logical module name named namelist nextrec nml none nullify number only open opened operator optional out pad parameter pass pause pending pointer pos position precision print private program protected public quote read readwrite real rec recl recursive result return rewind save select selectcase selecttype sequential sign size stat status stop stream subroutine target then to type unformatted unit use value volatile wait where while write +intrinsic_functions=abs achar acos acosd adjustl adjustr aimag aimax0 aimin0 aint ajmax0 ajmin0 akmax0 akmin0 all allocated alog alog10 amax0 amax1 amin0 amin1 amod anint any asin asind associated atan atan2 atan2d atand bitest bitl bitlr bitrl bjtest bit_size bktest break btest cabs ccos cdabs cdcos cdexp cdlog cdsin cdsqrt ceiling cexp char clog cmplx conjg cos cosd cosh count cpu_time cshift csin csqrt dabs dacos dacosd dasin dasind datan datan2 datan2d datand date date_and_time dble dcmplx dconjg dcos dcosd dcosh dcotan ddim dexp dfloat dflotk dfloti dflotj digits dim dimag dint dlog dlog10 dmax1 dmin1 dmod dnint dot_product dprod dreal dsign dsin dsind dsinh dsqrt dtan dtand dtanh eoshift epsilon errsns exp exponent float floati floatj floatk floor fraction free huge iabs iachar iand ibclr ibits ibset ichar idate idim idint idnint ieor ifix iiabs iiand iibclr iibits iibset iidim iidint iidnnt iieor iifix iint iior iiqint iiqnnt iishft iishftc iisign ilen imax0 imax1 imin0 imin1 imod index inint inot int int1 int2 int4 int8 iqint iqnint ior ishft ishftc isign isnan izext jiand jibclr jibits jibset jidim jidint jidnnt jieor jifix jint jior jiqint jiqnnt jishft jishftc jisign jmax0 jmax1 jmin0 jmin1 jmod jnint jnot jzext kiabs kiand kibclr kibits kibset kidim kidint kidnnt kieor kifix kind kint kior kishft kishftc kisign kmax0 kmax1 kmin0 kmin1 kmod knint knot kzext lbound leadz len len_trim lenlge lge lgt lle llt log log10 logical lshift malloc matmul max max0 max1 maxexponent maxloc maxval merge min min0 min1 minexponent minloc minval mod modulo mvbits nearest nint not nworkers number_of_processors pack popcnt poppar precision present product radix random random_number random_seed range real repeat reshape rrspacing rshift scale scan secnds selected_int_kind selected_real_kind set_exponent shape sign sin sind sinh size sizeof sngl snglq spacing spread sqrt sum system_clock tan tand tanh tiny transfer transpose trim ubound unpack verify +user_functions=cdabs cdcos cdexp cdlog cdsin cdsqrt cotan cotand dcmplx dconjg dcotan dcotand decode dimag dll_export dll_import doublecomplex dreal dvchk encode find flen flush getarg getcharqq getcl getdat getenv gettim hfix ibchng identifier imag int1 int2 int4 intc intrup invalop iostat_msg isha ishc ishl jfix lacfar locking locnear map nargs nbreak ndperr ndpexc offset ovefl peekcharqq precfill prompt qabs qacos qacosd qasin qasind qatan qatand qatan2 qcmplx qconjg qcos qcosd qcosh qdim qexp qext qextd qfloat qimag qlog qlog10 qmax1 qmin1 qmod qreal qsign qsin qsind qsinh qsqrt qtan qtand qtanh ran rand randu rewrite segment setdat settim system timer undfl unlock union val virtual volatile zabs zcos zexp zlog zsin zsqrt + + +[settings] +# the following characters are these which a "word" can contains, see documentation +wordchars=_#&abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 + +# if only single comment char is supported like # in this file, leave comment_close blank +comment_open=c +comment_close= + +# set to false if a comment character/string should start at column 0 of a line, true uses any +# indention of the line, e.g. setting to true causes the following on pressing CTRL+d + #command_example(); +# setting to false would generate this +# command_example(); +# This setting works only for single line comments +comment_use_indent=false + + +[build_settings] +# %f will be replaced by the complete filename +# %e will be replaced by the filename without extension +# (use only one of it at one time) +compiler=g77 -Wall -c "%f" +# the -o option is automatically added by Geany +linker=g77 -Wall "%f" +run_cmd="./%e" +
Modified: trunk/scintilla/KeyWords.cxx =================================================================== --- trunk/scintilla/KeyWords.cxx 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/scintilla/KeyWords.cxx 2006-08-15 17:57:41 UTC (rev 724) @@ -141,6 +141,7 @@ LINK_LEXER(lmBash); LINK_LEXER(lmOMS); LINK_LEXER(lmCaml); + LINK_LEXER(lmFortran); LINK_LEXER(lmPython); LINK_LEXER(lmBatch); LINK_LEXER(lmDiff);
Added: trunk/scintilla/LexFortran.cxx =================================================================== --- trunk/scintilla/LexFortran.cxx (rev 0) +++ trunk/scintilla/LexFortran.cxx 2006-08-15 17:57:41 UTC (rev 724) @@ -0,0 +1,452 @@ +// Scintilla source code edit control +/** @file LexFortran.cxx + ** Lexer for Fortran. + ** Writen by Chuan-jian Shen, Last changed Sep. 2003 + **/ +// Copyright 1998-2001 by Neil Hodgson neilh@scintilla.org +// The License.txt file describes the conditions under which this software may be distributed. +/***************************************/ +#include <stdlib.h> +#include <string.h> +#include <ctype.h> +#include <stdio.h> +#include <stdarg.h> +/***************************************/ +#include "Platform.h" +#include "PropSet.h" +#include "Accessor.h" +#include "StyleContext.h" +#include "KeyWords.h" +#include "Scintilla.h" +#include "SciLexer.h" +/***********************************************/ +static inline bool IsAWordChar(const int ch) { + return (ch < 0x80) && (isalnum(ch) || ch == '_' || ch == '%'); +} +/**********************************************/ +static inline bool IsAWordStart(const int ch) { + return (ch < 0x80) && (isalnum(ch)); +} +/***************************************/ +inline bool IsABlank(unsigned int ch) { + return (ch == ' ') || (ch == 0x09) || (ch == 0x0b) ; +} +/***************************************/ +inline bool IsALineEnd(char ch) { + return ((ch == '\n') || (ch == '\r')) ; +} +/***************************************/ +unsigned int GetContinuedPos(unsigned int pos, Accessor &styler) { + while (!IsALineEnd(styler.SafeGetCharAt(pos++))) continue; + if (styler.SafeGetCharAt(pos) == '\n') pos++; + while (IsABlank(styler.SafeGetCharAt(pos++))) continue; + char chCur = styler.SafeGetCharAt(pos); + if (chCur == '&') { + while (IsABlank(styler.SafeGetCharAt(++pos))) continue; + return pos; + } else { + return pos; + } +} +/***************************************/ +static void ColouriseFortranDoc(unsigned int startPos, int length, int initStyle, + WordList *keywordlists[], Accessor &styler, bool isFixFormat) { + WordList &keywords = *keywordlists[0]; + WordList &keywords2 = *keywordlists[1]; + WordList &keywords3 = *keywordlists[2]; + /***************************************/ + int posLineStart = 0, numNonBlank = 0, prevState = 0; + int endPos = startPos + length; + /***************************************/ + // backtrack to the nearest keyword + while ((startPos > 1) && (styler.StyleAt(startPos) != SCE_F_WORD)) { + startPos--; + } + startPos = styler.LineStart(styler.GetLine(startPos)); + initStyle = styler.StyleAt(startPos - 1); + StyleContext sc(startPos, endPos-startPos, initStyle, styler); + /***************************************/ + for (; sc.More(); sc.Forward()) { + // remember the start position of the line + if (sc.atLineStart) { + posLineStart = sc.currentPos; + numNonBlank = 0; + sc.SetState(SCE_F_DEFAULT); + } + if (!IsASpaceOrTab(sc.ch)) numNonBlank ++; + /***********************************************/ + // Handle the fix format generically + int toLineStart = sc.currentPos - posLineStart; + if (isFixFormat && (toLineStart < 6 || toLineStart > 72)) { + if (toLineStart == 0 && (tolower(sc.ch) == 'c' || sc.ch == '*') || sc.ch == '!') { + sc.SetState(SCE_F_COMMENT); + while (!sc.atLineEnd && sc.More()) sc.Forward(); // Until line end + } else if (toLineStart > 72) { + sc.SetState(SCE_F_COMMENT); + while (!sc.atLineEnd && sc.More()) sc.Forward(); // Until line end + } else if (toLineStart < 5) { + if (IsADigit(sc.ch)) + sc.SetState(SCE_F_LABEL); + else + sc.SetState(SCE_F_DEFAULT); + } else if (toLineStart == 5) { + if (!IsASpace(sc.ch) && sc.ch != '0') { + sc.SetState(SCE_F_CONTINUATION); + sc.ForwardSetState(prevState); + } else + sc.SetState(SCE_F_DEFAULT); + } + continue; + } + /***************************************/ + // Handle line continuation generically. + if (!isFixFormat && sc.ch == '&') { + char chTemp = ' '; + int j = 1; + while (IsABlank(chTemp) && j<132) { + chTemp = static_cast<char>(sc.GetRelative(j)); + j++; + } + if (chTemp == '!') { + sc.SetState(SCE_F_CONTINUATION); + if (sc.chNext == '!') sc.ForwardSetState(SCE_F_COMMENT); + } else if (chTemp == '\r' || chTemp == '\n') { + int currentState = sc.state; + sc.SetState(SCE_F_CONTINUATION); + sc.ForwardSetState(SCE_F_DEFAULT); + while (IsASpace(sc.ch) && sc.More()) sc.Forward(); + if (sc.ch == '&') { + sc.SetState(SCE_F_CONTINUATION); + sc.Forward(); + } + sc.SetState(currentState); + } + } + /***************************************/ + // Determine if the current state should terminate. + if (sc.state == SCE_F_OPERATOR) { + sc.SetState(SCE_F_DEFAULT); + } else if (sc.state == SCE_F_NUMBER) { + if (!(IsAWordChar(sc.ch) || sc.ch==''' || sc.ch=='"' || sc.ch=='.')) { + sc.SetState(SCE_F_DEFAULT); + } + } else if (sc.state == SCE_F_IDENTIFIER) { + if (!IsAWordChar(sc.ch) || (sc.ch == '%')) { + char s[100]; + sc.GetCurrentLowered(s, sizeof(s)); + if (keywords.InList(s)) { + sc.ChangeState(SCE_F_WORD); + } else if (keywords2.InList(s)) { + sc.ChangeState(SCE_F_WORD2); + } else if (keywords3.InList(s)) { + sc.ChangeState(SCE_F_WORD3); + } + sc.SetState(SCE_F_DEFAULT); + } + } else if (sc.state == SCE_F_COMMENT || sc.state == SCE_F_PREPROCESSOR) { + if (sc.ch == '\r' || sc.ch == '\n') { + sc.SetState(SCE_F_DEFAULT); + } + } else if (sc.state == SCE_F_STRING1) { + prevState = sc.state; + if (sc.ch == ''') { + if (sc.chNext == ''') { + sc.Forward(); + } else { + sc.ForwardSetState(SCE_F_DEFAULT); + prevState = SCE_F_DEFAULT; + } + } else if (sc.atLineEnd) { + sc.ChangeState(SCE_F_STRINGEOL); + sc.ForwardSetState(SCE_F_DEFAULT); + } + } else if (sc.state == SCE_F_STRING2) { + prevState = sc.state; + if (sc.atLineEnd) { + sc.ChangeState(SCE_F_STRINGEOL); + sc.ForwardSetState(SCE_F_DEFAULT); + } else if (sc.ch == '"') { + if (sc.chNext == '"') { + sc.Forward(); + } else { + sc.ForwardSetState(SCE_F_DEFAULT); + prevState = SCE_F_DEFAULT; + } + } + } else if (sc.state == SCE_F_OPERATOR2) { + if (sc.ch == '.') { + sc.ForwardSetState(SCE_F_DEFAULT); + } + } else if (sc.state == SCE_F_CONTINUATION) { + sc.SetState(SCE_F_DEFAULT); + } else if (sc.state == SCE_F_LABEL) { + if (!IsADigit(sc.ch)) { + sc.SetState(SCE_F_DEFAULT); + } else { + if (isFixFormat && sc.currentPos-posLineStart > 4) + sc.SetState(SCE_F_DEFAULT); + else if (numNonBlank > 5) + sc.SetState(SCE_F_DEFAULT); + } + } + /***************************************/ + // Determine if a new state should be entered. + if (sc.state == SCE_F_DEFAULT) { + if (sc.ch == '!') { + if (sc.chNext == '$') { + sc.SetState(SCE_F_PREPROCESSOR); + } else { + sc.SetState(SCE_F_COMMENT); + } + } else if ((!isFixFormat) && IsADigit(sc.ch) && numNonBlank == 1) { + sc.SetState(SCE_F_LABEL); + } else if (IsADigit(sc.ch) || (sc.ch == '.' && IsADigit(sc.chNext))) { + sc.SetState(SCE_F_NUMBER); + } else if ((tolower(sc.ch) == 'b' || tolower(sc.ch) == 'o' || + tolower(sc.ch) == 'z') && (sc.chNext == '"' || sc.chNext == ''')) { + sc.SetState(SCE_F_NUMBER); + sc.Forward(); + } else if (sc.ch == '.' && isalpha(sc.chNext)) { + sc.SetState(SCE_F_OPERATOR2); + } else if (IsAWordStart(sc.ch)) { + sc.SetState(SCE_F_IDENTIFIER); + } else if (sc.ch == '"') { + sc.SetState(SCE_F_STRING2); + } else if (sc.ch == ''') { + sc.SetState(SCE_F_STRING1); + } else if (isoperator(static_cast<char>(sc.ch))) { + sc.SetState(SCE_F_OPERATOR); + } + } + } + sc.Complete(); +} +/***************************************/ +// To determine the folding level depending on keywords +static int classifyFoldPointFortran(const char* s, const char* prevWord, const char chNextNonBlank) { + int lev = 0; + if ((strcmp(prevWord, "else") == 0 && strcmp(s, "if") == 0) || strcmp(s, "elseif") == 0) + return -1; + if (strcmp(s, "associate") == 0 || strcmp(s, "block") == 0 + || strcmp(s, "blockdata") == 0 || strcmp(s, "select") == 0 + || strcmp(s, "do") == 0 || strcmp(s, "enum") ==0 + || strcmp(s, "function") == 0 || strcmp(s, "interface") == 0 + || strcmp(s, "module") == 0 || strcmp(s, "program") == 0 + || strcmp(s, "subroutine") == 0 || strcmp(s, "then") == 0 + || (strcmp(s, "type") == 0 && chNextNonBlank != '(') ){ + if (strcmp(prevWord, "end") == 0) + lev = 0; + else + lev = 1; + } else if (strcmp(s, "end") == 0 && chNextNonBlank != '=' + || strcmp(s, "endassociate") == 0 || strcmp(s, "endblock") == 0 + || strcmp(s, "endblockdata") == 0 || strcmp(s, "endselect") == 0 + || strcmp(s, "enddo") == 0 || strcmp(s, "endenum") ==0 + || strcmp(s, "endif") == 0 || strcmp(s, "endforall") == 0 + || strcmp(s, "endfunction") == 0 || strcmp(s, "endinterface") == 0 + || strcmp(s, "endmodule") == 0 || strcmp(s, "endprogram") == 0 + || strcmp(s, "endsubroutine") == 0 || strcmp(s, "endtype") == 0 + || strcmp(s, "endwhere") == 0 + || strcmp(s, "procedure") == 0 ) { // Take care of the module procedure statement + lev = -1; + } else if (strcmp(prevWord, "end") == 0 && strcmp(s, "if") == 0){ // end if + lev = 0; + } + return lev; +} +// Folding the code +static void FoldFortranDoc(unsigned int startPos, int length, int initStyle, + Accessor &styler, bool isFixFormat) { + // + // bool foldComment = styler.GetPropertyInt("fold.comment") != 0; + // Do not know how to fold the comment at the moment. + // + bool foldCompact = styler.GetPropertyInt("fold.compact", 1) != 0; + unsigned int endPos = startPos + length; + int visibleChars = 0; + int lineCurrent = styler.GetLine(startPos); + int levelPrev = styler.LevelAt(lineCurrent) & SC_FOLDLEVELNUMBERMASK; + int levelCurrent = levelPrev; + char chNext = styler[startPos]; + char chNextNonBlank; + int styleNext = styler.StyleAt(startPos); + int style = initStyle; + /***************************************/ + int lastStart = 0; + char prevWord[32] = ""; + char Label[6] = ""; + // Variables for do label folding. + static int doLabels[100]; + static int posLabel=-1; + /***************************************/ + for (unsigned int i = startPos; i < endPos; i++) { + char ch = chNext; + chNext = styler.SafeGetCharAt(i + 1); + chNextNonBlank = chNext; + unsigned int j=i+1; + while(IsABlank(chNextNonBlank) && j<endPos) { + j ++ ; + chNextNonBlank = styler.SafeGetCharAt(j); + } + int stylePrev = style; + style = styleNext; + styleNext = styler.StyleAt(i + 1); + bool atEOL = (ch == '\r' && chNext != '\n') || (ch == '\n'); + // + if (stylePrev == SCE_F_DEFAULT && (style == SCE_F_WORD || style == SCE_F_LABEL)) { + // Store last word and label start point. + lastStart = i; + } + /***************************************/ + if (style == SCE_F_WORD) { + if(iswordchar(ch) && !iswordchar(chNext)) { + char s[32]; + unsigned int k; + for(k=0; (k<31 ) && (k<i-lastStart+1 ); k++) { + s[k] = static_cast<char>(tolower(styler[lastStart+k])); + } + s[k] = '\0'; + // Handle the forall and where statement and structure. + if (strcmp(s, "forall") == 0 || strcmp(s, "where") == 0) { + if (strcmp(prevWord, "end") != 0) { + j = i + 1; + char chBrace = '(', chSeek = ')', ch1 = styler.SafeGetCharAt(j); + // Find the position of the first ( + while (ch1 != chBrace && j<endPos) { + j++; + ch1 = styler.SafeGetCharAt(j); + } + char styBrace = styler.StyleAt(j); + int depth = 1; + char chAtPos; + char styAtPos; + while (j<endPos) { + j++; + chAtPos = styler.SafeGetCharAt(j); + styAtPos = styler.StyleAt(j); + if (styAtPos == styBrace) { + if (chAtPos == chBrace) depth++; + if (chAtPos == chSeek) depth--; + if (depth == 0) break; + } + } + while (j<endPos) { + j++; + chAtPos = styler.SafeGetCharAt(j); + styAtPos = styler.StyleAt(j); + if (styAtPos == SCE_F_COMMENT || IsABlank(chAtPos)) continue; + if (isFixFormat) { + if (!IsALineEnd(chAtPos)) { + break; + } else { + if (lineCurrent < styler.GetLine(styler.Length()-1)) { + j = styler.LineStart(lineCurrent+1); + if (styler.StyleAt(j+5) == SCE_F_CONTINUATION) { + j += 5; + continue; + } else { + levelCurrent++; + break; + } + } + } + } else { + if (chAtPos == '&' && styler.StyleAt(j) == SCE_F_CONTINUATION) { + j = GetContinuedPos(j+1, styler); + continue; + } else if (IsALineEnd(chAtPos)) { + levelCurrent ++; + break; + } else { + break; + } + } + } + } + } else { + levelCurrent += classifyFoldPointFortran(s, prevWord, chNextNonBlank); + // Store the do Labels into array + if (strcmp(s, "do") == 0 && IsADigit(chNextNonBlank)) { + unsigned int k = 0; + for (i=j; (i<j+5 && i<endPos); i++) { + ch = styler.SafeGetCharAt(i); + if (IsADigit(ch)) + Label[k++] = ch; + else + break; + } + Label[k] = '\0'; + posLabel ++; + doLabels[posLabel] = atoi(Label); + } + } + strcpy(prevWord, s); + } + } else if (style == SCE_F_LABEL) { + if(IsADigit(ch) && !IsADigit(chNext)) { + for(j = 0; ( j < 5 ) && ( j < i-lastStart+1 ); j++) { + ch = styler.SafeGetCharAt(lastStart + j); + if (IsADigit(ch) && styler.StyleAt(lastStart+j) == SCE_F_LABEL) + Label[j] = ch; + else + break; + } + Label[j] = '\0'; + while (doLabels[posLabel] == atoi(Label) && posLabel > -1) { + levelCurrent--; + posLabel--; + } + } + } + if (atEOL) { + int lev = levelPrev; + if (visibleChars == 0 && foldCompact) + lev |= SC_FOLDLEVELWHITEFLAG; + if ((levelCurrent > levelPrev) && (visibleChars > 0)) + lev |= SC_FOLDLEVELHEADERFLAG; + if (lev != styler.LevelAt(lineCurrent)) { + styler.SetLevel(lineCurrent, lev); + } + lineCurrent++; + levelPrev = levelCurrent; + visibleChars = 0; + strcpy(prevWord, ""); + } + /***************************************/ + if (!isspacechar(ch)) visibleChars++; + } + /***************************************/ + // Fill in the real level of the next line, keeping the current flags as they will be filled in later + int flagsNext = styler.LevelAt(lineCurrent) & ~SC_FOLDLEVELNUMBERMASK; + styler.SetLevel(lineCurrent, levelPrev | flagsNext); +} +/***************************************/ +static const char * const FortranWordLists[] = { + "Primary keywords and identifiers", + "Intrinsic functions", + "Extended and user defined functions", + 0, +}; +/***************************************/ +static void ColouriseFortranDocFreeFormat(unsigned int startPos, int length, int initStyle, WordList *keywordlists[], + Accessor &styler) { + ColouriseFortranDoc(startPos, length, initStyle, keywordlists, styler, false); +} +/***************************************/ +static void ColouriseFortranDocFixFormat(unsigned int startPos, int length, int initStyle, WordList *keywordlists[], + Accessor &styler) { + ColouriseFortranDoc(startPos, length, initStyle, keywordlists, styler, true); +} +/***************************************/ +static void FoldFortranDocFreeFormat(unsigned int startPos, int length, int initStyle, + WordList *[], Accessor &styler) { + FoldFortranDoc(startPos, length, initStyle,styler, false); +} +/***************************************/ +static void FoldFortranDocFixFormat(unsigned int startPos, int length, int initStyle, + WordList *[], Accessor &styler) { + FoldFortranDoc(startPos, length, initStyle,styler, true); +} +/***************************************/ +LexerModule lmFortran(SCLEX_FORTRAN, ColouriseFortranDocFreeFormat, "fortran", FoldFortranDocFreeFormat, FortranWordLists); +LexerModule lmF77(SCLEX_F77, ColouriseFortranDocFixFormat, "f77", FoldFortranDocFixFormat, FortranWordLists);
Modified: trunk/scintilla/Makefile.am =================================================================== --- trunk/scintilla/Makefile.am 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/scintilla/Makefile.am 2006-08-15 17:57:41 UTC (rev 724) @@ -16,6 +16,7 @@ LexConf.cxx \ LexCrontab.cxx \ LexCSS.cxx \ +LexFortran.cxx \ LexHTML.cxx \ LexOthers.cxx \ LexPascal.cxx \
Modified: trunk/src/filetypes.c =================================================================== --- trunk/src/filetypes.c 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/src/filetypes.c 2006-08-15 17:57:41 UTC (rev 724) @@ -58,7 +58,8 @@ FILETYPE_UID_TCL, // 19 FILETYPE_UID_ALL, // 20 FILETYPE_UID_D, // 21 - //FILETYPE_UID_HTML, // 22 + FILETYPE_UID_FORTRAN // 22 + //FILETYPE_UID_HTML, // 23 };
@@ -96,6 +97,7 @@ case FILETYPE_UID_TCL: return filetypes[GEANY_FILETYPES_TCL]; case FILETYPE_UID_ALL: return filetypes[GEANY_FILETYPES_ALL]; case FILETYPE_UID_D: return filetypes[GEANY_FILETYPES_D]; + case FILETYPE_UID_FORTRAN: return filetypes[GEANY_FILETYPES_FORTRAN]; //case FILETYPE_UID_HTML: return filetypes[GEANY_FILETYPES_HTML]; default: return NULL; } @@ -243,6 +245,30 @@ filetypes_init_build_programs(filetypes[GEANY_FILETYPES_ASM]); filetypes_create_menu_item(filetype_menu, filetypes[GEANY_FILETYPES_ASM]->title, filetypes[GEANY_FILETYPES_ASM]);
+#define FORTRAN + filetypes[GEANY_FILETYPES_FORTRAN] = g_new0(filetype, 1); + filetypes[GEANY_FILETYPES_FORTRAN]->id = GEANY_FILETYPES_FORTRAN; + filetypes[GEANY_FILETYPES_FORTRAN]->uid = FILETYPE_UID_FORTRAN; + filetypes[GEANY_FILETYPES_FORTRAN]->item = NULL; + filetypes[GEANY_FILETYPES_FORTRAN]->lang = 18; + filetypes[GEANY_FILETYPES_FORTRAN]->name = g_strdup("Fortran"); + filetypes[GEANY_FILETYPES_FORTRAN]->has_tags = TRUE; + filetypes[GEANY_FILETYPES_FORTRAN]->title = g_strdup(_("Fortran source file (F77)")); + filetypes[GEANY_FILETYPES_FORTRAN]->extension = g_strdup("f"); + filetypes[GEANY_FILETYPES_FORTRAN]->pattern = g_new0(gchar*, 7); + filetypes[GEANY_FILETYPES_FORTRAN]->pattern[0] = g_strdup("*.f"); + filetypes[GEANY_FILETYPES_FORTRAN]->pattern[1] = g_strdup("*.for"); + filetypes[GEANY_FILETYPES_FORTRAN]->pattern[2] = g_strdup("*.ftn"); + filetypes[GEANY_FILETYPES_FORTRAN]->pattern[3] = g_strdup("*.f77"); + filetypes[GEANY_FILETYPES_FORTRAN]->pattern[4] = g_strdup("*.f90"); + filetypes[GEANY_FILETYPES_FORTRAN]->pattern[5] = g_strdup("*.f95"); + filetypes[GEANY_FILETYPES_FORTRAN]->pattern[6] = NULL; + filetypes[GEANY_FILETYPES_FORTRAN]->style_func_ptr = styleset_fortran; + filetypes[GEANY_FILETYPES_FORTRAN]->comment_open = g_strdup("c"); + filetypes[GEANY_FILETYPES_FORTRAN]->comment_close = NULL; + filetypes_init_build_programs(filetypes[GEANY_FILETYPES_FORTRAN]); + filetypes_create_menu_item(filetype_menu, filetypes[GEANY_FILETYPES_FORTRAN]->title, filetypes[GEANY_FILETYPES_FORTRAN]); + #define CAML filetypes[GEANY_FILETYPES_CAML] = g_new0(filetype, 1); filetypes[GEANY_FILETYPES_CAML]->id = GEANY_FILETYPES_CAML;
Modified: trunk/src/filetypes.h =================================================================== --- trunk/src/filetypes.h 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/src/filetypes.h 2006-08-15 17:57:41 UTC (rev 724) @@ -27,32 +27,33 @@
enum { - GEANY_FILETYPES_C = 0, // 0 - GEANY_FILETYPES_CPP, // 1 - GEANY_FILETYPES_D, // 2 - GEANY_FILETYPES_JAVA, // 3 - GEANY_FILETYPES_PASCAL, // 4 - GEANY_FILETYPES_ASM, // 5 - GEANY_FILETYPES_CAML, // 6 - GEANY_FILETYPES_PERL, // 7 - GEANY_FILETYPES_PHP, // 8 - GEANY_FILETYPES_PYTHON, // 9 - GEANY_FILETYPES_RUBY, // 10 - GEANY_FILETYPES_TCL, // 11 - GEANY_FILETYPES_SH, // 12 - GEANY_FILETYPES_MAKE, // 13 - GEANY_FILETYPES_XML, // 14 - GEANY_FILETYPES_DOCBOOK, // 15 + GEANY_FILETYPES_C = 0, + GEANY_FILETYPES_CPP, + GEANY_FILETYPES_D, + GEANY_FILETYPES_JAVA, + GEANY_FILETYPES_PASCAL, + GEANY_FILETYPES_ASM, + GEANY_FILETYPES_FORTRAN, + GEANY_FILETYPES_CAML, + GEANY_FILETYPES_PERL, + GEANY_FILETYPES_PHP, + GEANY_FILETYPES_PYTHON, + GEANY_FILETYPES_RUBY, + GEANY_FILETYPES_TCL, + GEANY_FILETYPES_SH, + GEANY_FILETYPES_MAKE, + GEANY_FILETYPES_XML, + GEANY_FILETYPES_DOCBOOK, /* - GEANY_FILETYPES_HTML, // 16 + GEANY_FILETYPES_HTML, */ - GEANY_FILETYPES_CSS, // 17 - GEANY_FILETYPES_SQL, // 18 - GEANY_FILETYPES_LATEX, // 19 - GEANY_FILETYPES_OMS, // 20 - GEANY_FILETYPES_CONF, // 21 - GEANY_FILETYPES_ALL, // 22 - GEANY_MAX_FILE_TYPES // 23 + GEANY_FILETYPES_CSS, + GEANY_FILETYPES_SQL, + GEANY_FILETYPES_LATEX, + GEANY_FILETYPES_OMS, + GEANY_FILETYPES_CONF, + GEANY_FILETYPES_ALL, + GEANY_MAX_FILE_TYPES };
Modified: trunk/src/highlighting.c =================================================================== --- trunk/src/highlighting.c 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/src/highlighting.c 2006-08-15 17:57:41 UTC (rev 724) @@ -1983,6 +1983,84 @@ }
+static void styleset_fortran_init(void) +{ + GKeyFile *config = g_key_file_new(); + GKeyFile *config_home = g_key_file_new(); + gchar *f0 = g_strconcat(app->datadir, G_DIR_SEPARATOR_S "filetypes.fortran", NULL); + gchar *f = g_strconcat(app->configdir, G_DIR_SEPARATOR_S GEANY_FILEDEFS_SUBDIR G_DIR_SEPARATOR_S "filetypes.fortran", NULL); + + styleset_load_file(config, f0, G_KEY_FILE_KEEP_COMMENTS, NULL); + g_key_file_load_from_file(config_home, f, G_KEY_FILE_KEEP_COMMENTS, NULL); + + types[GEANY_FILETYPES_FORTRAN] = g_new(style_set, 1); + styleset_get_hex(config, config_home, "styling", "default", "0x000000", "0xffffff", "false", types[GEANY_FILETYPES_FORTRAN]->styling[0]); + styleset_get_hex(config, config_home, "styling", "comment", "0x808080", "0xffffff", "false", types[GEANY_FILETYPES_FORTRAN]->styling[1]); + styleset_get_hex(config, config_home, "styling", "number", "0x007f00", "0xffffff", "false", types[GEANY_FILETYPES_FORTRAN]->styling[2]); + styleset_get_hex(config, config_home, "styling", "string", "0xff901e", "0xffffff", "false", types[GEANY_FILETYPES_FORTRAN]->styling[3]); + styleset_get_hex(config, config_home, "styling", "operator", "0x301010", "0xffffff", "false", types[GEANY_FILETYPES_FORTRAN]->styling[4]); + styleset_get_hex(config, config_home, "styling", "identifier", "0x000000", "0xffffff", "false", types[GEANY_FILETYPES_FORTRAN]->styling[5]); + styleset_get_hex(config, config_home, "styling", "string2", "0x111199", "0xffffff", "true", types[GEANY_FILETYPES_FORTRAN]->styling[6]); + styleset_get_hex(config, config_home, "styling", "word", "0x7f0000", "0xffffff", "true", types[GEANY_FILETYPES_FORTRAN]->styling[7]); + styleset_get_hex(config, config_home, "styling", "word2", "0x000099", "0xffffff", "true", types[GEANY_FILETYPES_FORTRAN]->styling[8]); + styleset_get_hex(config, config_home, "styling", "word3", "0x3d670f", "0xffffff", "true", types[GEANY_FILETYPES_FORTRAN]->styling[9]); + styleset_get_hex(config, config_home, "styling", "preprocessor", "0x007f7f", "0xffffff", "false", types[GEANY_FILETYPES_FORTRAN]->styling[10]); + styleset_get_hex(config, config_home, "styling", "operator2", "0x301010", "0xffffff", "true", types[GEANY_FILETYPES_FORTRAN]->styling[11]); + styleset_get_hex(config, config_home, "styling", "continuation", "0x000000", "0xf0e080", "false", types[GEANY_FILETYPES_FORTRAN]->styling[12]); + styleset_get_hex(config, config_home, "styling", "stringeol", "0x000000", "0xe0c0e0", "false", types[GEANY_FILETYPES_FORTRAN]->styling[13]); + styleset_get_hex(config, config_home, "styling", "label", "0xa861a8", "0xffffff", "true", types[GEANY_FILETYPES_FORTRAN]->styling[14]); + + types[GEANY_FILETYPES_FORTRAN]->keywords = g_new(gchar*, 4); + styleset_get_keywords(config, config_home, "keywords", "primary", GEANY_FILETYPES_FORTRAN, 0, ""); + styleset_get_keywords(config, config_home, "keywords", "intrinsic_functions", GEANY_FILETYPES_FORTRAN, 1, ""); + styleset_get_keywords(config, config_home, "keywords", "user_functions", GEANY_FILETYPES_FORTRAN, 2, ""); + types[GEANY_FILETYPES_FORTRAN]->keywords[3] = NULL; + + styleset_get_wordchars(config, config_home, GEANY_FILETYPES_FORTRAN, GEANY_WORDCHARS); + filetypes_get_config(config, config_home, GEANY_FILETYPES_FORTRAN); + + g_key_file_free(config); + g_key_file_free(config_home); + g_free(f0); + g_free(f); +} + + +void styleset_fortran(ScintillaObject *sci) +{ + if (types[GEANY_FILETYPES_FORTRAN] == NULL) styleset_fortran_init(); + + styleset_common(sci, 5); + + SSM(sci, SCI_SETWORDCHARS, 0, (sptr_t) types[GEANY_FILETYPES_FORTRAN]->wordchars); + SSM(sci, SCI_AUTOCSETMAXHEIGHT, app->autocompletion_max_height, 0); + + SSM(sci, SCI_SETLEXER, SCLEX_F77, 0); + //SSM(sci, SCI_SETLEXER, SCLEX_FORTRAN, 0); + + SSM(sci, SCI_SETKEYWORDS, 0, (sptr_t) types[GEANY_FILETYPES_FORTRAN]->keywords[0]); + SSM(sci, SCI_SETKEYWORDS, 1, (sptr_t) types[GEANY_FILETYPES_FORTRAN]->keywords[1]); + SSM(sci, SCI_SETKEYWORDS, 2, (sptr_t) types[GEANY_FILETYPES_FORTRAN]->keywords[2]); + + styleset_set_style(sci, STYLE_DEFAULT, GEANY_FILETYPES_FORTRAN, 0); + styleset_set_style(sci, SCE_F_DEFAULT, GEANY_FILETYPES_FORTRAN, 0); + styleset_set_style(sci, SCE_F_COMMENT, GEANY_FILETYPES_FORTRAN, 1); + styleset_set_style(sci, SCE_F_NUMBER, GEANY_FILETYPES_FORTRAN, 2); + styleset_set_style(sci, SCE_F_STRING1, GEANY_FILETYPES_FORTRAN, 3); + styleset_set_style(sci, SCE_F_OPERATOR, GEANY_FILETYPES_FORTRAN, 4); + styleset_set_style(sci, SCE_F_IDENTIFIER, GEANY_FILETYPES_FORTRAN, 5); + styleset_set_style(sci, SCE_F_STRING2, GEANY_FILETYPES_FORTRAN, 6); + styleset_set_style(sci, SCE_F_WORD, GEANY_FILETYPES_FORTRAN, 7); + styleset_set_style(sci, SCE_F_WORD2, GEANY_FILETYPES_FORTRAN, 8); + styleset_set_style(sci, SCE_F_WORD3, GEANY_FILETYPES_FORTRAN, 9); + styleset_set_style(sci, SCE_F_PREPROCESSOR, GEANY_FILETYPES_FORTRAN, 10); + styleset_set_style(sci, SCE_F_OPERATOR2, GEANY_FILETYPES_FORTRAN, 11); + styleset_set_style(sci, SCE_F_CONTINUATION, GEANY_FILETYPES_FORTRAN, 12); + styleset_set_style(sci, SCE_F_STRINGEOL, GEANY_FILETYPES_FORTRAN, 13); + styleset_set_style(sci, SCE_F_LABEL, GEANY_FILETYPES_FORTRAN, 14); +} + + static void styleset_sql_init(void) { GKeyFile *config = g_key_file_new();
Modified: trunk/src/highlighting.h =================================================================== --- trunk/src/highlighting.h 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/src/highlighting.h 2006-08-15 17:57:41 UTC (rev 724) @@ -83,4 +83,6 @@
void styleset_d(ScintillaObject *sci);
+void styleset_fortran(ScintillaObject *sci); + #endif
Modified: trunk/src/msgwindow.c =================================================================== --- trunk/src/msgwindow.c 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/src/msgwindow.c 2006-08-15 17:57:41 UTC (rev 724) @@ -357,6 +357,7 @@ field_idx_file = 0; break; } + case GEANY_FILETYPES_FORTRAN: case GEANY_FILETYPES_LATEX: { // ./kommtechnik_2b.tex:18: Emergency stop.
Modified: trunk/tagmanager/Makefile.am =================================================================== --- trunk/tagmanager/Makefile.am 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/tagmanager/Makefile.am 2006-08-15 17:57:41 UTC (rev 724) @@ -31,6 +31,7 @@ conf.c\ css.c\ docbook.c\ + fortran.c\ make.c\ asm.c\ latex.c\
Added: trunk/tagmanager/fortran.c =================================================================== --- trunk/tagmanager/fortran.c (rev 0) +++ trunk/tagmanager/fortran.c 2006-08-15 17:57:41 UTC (rev 724) @@ -0,0 +1,1682 @@ +/* +* +* Copyright (c) 1998-2001, Darren Hiebert +* +* This source code is released for free distribution under the terms of the +* GNU General Public License. +* +* This module contains functions for generating tags for Fortran language +* files. +*/ + +/* +* INCLUDE FILES +*/ +#include "general.h" /* must always come first */ + +#include <string.h> +#include <limits.h> +#include <ctype.h> /* to define tolower () */ +#include <setjmp.h> + +#include "entry.h" +#include "keyword.h" +#include "main.h" +#include "options.h" +#include "parse.h" +#include "read.h" +#include "vstring.h" + +/* +* MACROS +*/ +#define isident(c) (isalnum(c) || (c) == '_') +#define isBlank(c) (boolean) (c == ' ' || c == '\t') +#define isType(token,t) (boolean) ((token)->type == (t)) +#define isKeyword(token,k) (boolean) ((token)->keyword == (k)) + +/* +* DATA DECLARATIONS +*/ + +typedef enum eException { + ExceptionNone, ExceptionEOF, ExceptionFixedFormat +} exception_t; + +/* Used to designate type of line read in fixed source form. + */ +typedef enum eFortranLineType { + LTYPE_UNDETERMINED, + LTYPE_INVALID, + LTYPE_COMMENT, + LTYPE_CONTINUATION, + LTYPE_EOF, + LTYPE_INITIAL, + LTYPE_SHORT +} lineType; + +/* Used to specify type of keyword. + */ +typedef enum eKeywordId { + KEYWORD_NONE, + KEYWORD_allocatable, + KEYWORD_assignment, + KEYWORD_block, + KEYWORD_character, + KEYWORD_common, + KEYWORD_complex, + KEYWORD_contains, + KEYWORD_data, + KEYWORD_dimension, + KEYWORD_do, + KEYWORD_double, + KEYWORD_end, + KEYWORD_entry, + KEYWORD_equivalence, + KEYWORD_external, + KEYWORD_format, + KEYWORD_function, + KEYWORD_if, + KEYWORD_implicit, + KEYWORD_include, + KEYWORD_integer, + KEYWORD_intent, + KEYWORD_interface, + KEYWORD_intrinsic, + KEYWORD_logical, + KEYWORD_module, + KEYWORD_namelist, + KEYWORD_operator, + KEYWORD_optional, + KEYWORD_parameter, + KEYWORD_pointer, + KEYWORD_precision, + KEYWORD_private, + KEYWORD_program, + KEYWORD_public, + KEYWORD_real, + KEYWORD_recursive, + KEYWORD_save, + KEYWORD_select, + KEYWORD_sequence, + KEYWORD_subroutine, + KEYWORD_target, + KEYWORD_type, + KEYWORD_use, + KEYWORD_where +} keywordId; + +/* Used to determine whether keyword is valid for the token language and + * what its ID is. + */ +typedef struct sKeywordDesc { + const char *name; + keywordId id; +} keywordDesc; + +typedef enum eTokenType { + TOKEN_UNDEFINED, + TOKEN_COMMA, + TOKEN_DOUBLE_COLON, + TOKEN_IDENTIFIER, + TOKEN_KEYWORD, + TOKEN_LABEL, + TOKEN_NUMERIC, + TOKEN_OPERATOR, + TOKEN_PAREN_CLOSE, + TOKEN_PAREN_OPEN, + TOKEN_STATEMENT_END, + TOKEN_STRING +} tokenType; + +typedef enum eTagType { + TAG_UNDEFINED = -1, + TAG_BLOCK_DATA, + TAG_COMMON_BLOCK, + TAG_ENTRY_POINT, + TAG_FUNCTION, + TAG_INTERFACE, + TAG_COMPONENT, + TAG_LABEL, + TAG_LOCAL, + TAG_MODULE, + TAG_NAMELIST, + TAG_PROGRAM, + TAG_SUBROUTINE, + TAG_DERIVED_TYPE, + TAG_VARIABLE, + TAG_COUNT /* must be last */ +} tagType; + +typedef struct sTokenInfo { + tokenType type; + keywordId keyword; + tagType tag; + vString* string; + unsigned long lineNumber; + fpos_t filePosition; +} tokenInfo; + +/* +* DATA DEFINITIONS +*/ + +static langType Lang_fortran; +static jmp_buf Exception; +static int Ungetc = '\0'; +static unsigned int Column = 0; +static boolean FreeSourceForm = FALSE; +static tokenInfo *Parent = NULL; + +/* indexed by tagType */ +static kindOption FortranKinds [] = { + { TRUE, 'b', "block data", "block data"}, + { TRUE, 'c', "common", "common blocks"}, + { TRUE, 'e', "entry", "entry points"}, + { TRUE, 'f', "function", "functions"}, + { TRUE, 'i', "interface", "interfaces"}, + { TRUE, 'k', "component", "type components"}, + { TRUE, 'l', "label", "labels"}, + { FALSE, 'L', "local", "local and common block variables"}, + { TRUE, 'm', "module", "modules"}, + { TRUE, 'n', "namelist", "namelists"}, + { TRUE, 'p', "program", "programs"}, + { TRUE, 's', "subroutine", "subroutines"}, + { TRUE, 't', "type", "derived types"}, + { TRUE, 'v', "variable", "module variables"} +}; + +static const keywordDesc FortranKeywordTable [] = { + /* keyword keyword ID */ + { "allocatable", KEYWORD_allocatable }, + { "assignment", KEYWORD_assignment }, + { "block", KEYWORD_block }, + { "character", KEYWORD_character }, + { "common", KEYWORD_common }, + { "complex", KEYWORD_complex }, + { "contains", KEYWORD_contains }, + { "data", KEYWORD_data }, + { "dimension", KEYWORD_dimension }, + { "do", KEYWORD_do }, + { "double", KEYWORD_double }, + { "end", KEYWORD_end }, + { "entry", KEYWORD_entry }, + { "equivalence", KEYWORD_equivalence }, + { "external", KEYWORD_external }, + { "format", KEYWORD_format }, + { "function", KEYWORD_function }, + { "if", KEYWORD_if }, + { "implicit", KEYWORD_implicit }, + { "include", KEYWORD_include }, + { "instrinsic", KEYWORD_intrinsic }, + { "integer", KEYWORD_integer }, + { "intent", KEYWORD_intent }, + { "interface", KEYWORD_interface }, + { "logical", KEYWORD_logical }, + { "module", KEYWORD_module }, + { "namelist", KEYWORD_namelist }, + { "operator", KEYWORD_operator }, + { "optional", KEYWORD_optional }, + { "parameter", KEYWORD_parameter }, + { "pointer", KEYWORD_pointer }, + { "precision", KEYWORD_precision }, + { "private", KEYWORD_private }, + { "program", KEYWORD_program }, + { "public", KEYWORD_public }, + { "real", KEYWORD_real }, + { "recursive", KEYWORD_recursive }, + { "save", KEYWORD_save }, + { "select", KEYWORD_select }, + { "sequence", KEYWORD_sequence }, + { "subroutine", KEYWORD_subroutine }, + { "target", KEYWORD_target }, + { "type", KEYWORD_type }, + { "use", KEYWORD_use }, + { "where", KEYWORD_where } +}; + +static struct { + unsigned int count; + unsigned int max; + tokenInfo* list; +} Ancestors = { 0, 0, NULL }; + +/* +* FUNCTION PROTOTYPES +*/ +static void parseDerivedTypeDef (tokenInfo *const token); +static void parseFunctionSubprogram (tokenInfo *const token); +static void parseSubroutineSubprogram (tokenInfo *const token); + +/* +* FUNCTION DEFINITIONS +*/ + +static void ancestorPush (tokenInfo *const token) +{ + enum { incrementalIncrease = 10 }; + if (Ancestors.list == NULL) + { + Assert (Ancestors.max == 0); + Ancestors.count = 0; + Ancestors.max = incrementalIncrease; + Ancestors.list = xMalloc (Ancestors.max, tokenInfo); + } + else if (Ancestors.count == Ancestors.max) + { + Ancestors.max += incrementalIncrease; + Ancestors.list = xRealloc (Ancestors.list, Ancestors.max, tokenInfo); + } + Ancestors.list [Ancestors.count] = *token; + Ancestors.list [Ancestors.count].string = vStringNewCopy (token->string); + Ancestors.count++; +} + +static void ancestorPop (void) +{ + Assert (Ancestors.count > 0); + --Ancestors.count; + vStringDelete (Ancestors.list [Ancestors.count].string); + + Ancestors.list [Ancestors.count].type = TOKEN_UNDEFINED; + Ancestors.list [Ancestors.count].keyword = KEYWORD_NONE; + Ancestors.list [Ancestors.count].tag = TAG_UNDEFINED; + Ancestors.list [Ancestors.count].string = NULL; + Ancestors.list [Ancestors.count].lineNumber = 0L; +} + +static const tokenInfo* ancestorTop (void) +{ + Assert (Ancestors.count > 0); + return &Ancestors.list [Ancestors.count - 1]; +} + +#define ancestorCount() (Ancestors.count) + +static void ancestorClear (void) +{ + while (Ancestors.count > 0) + ancestorPop (); + if (Ancestors.list != NULL) + eFree (Ancestors.list); + Ancestors.list = NULL; + Ancestors.count = 0; + Ancestors.max = 0; +} + +static void buildFortranKeywordHash (void) +{ + const size_t count = sizeof (FortranKeywordTable) / + sizeof (FortranKeywordTable [0]); + size_t i; + for (i = 0 ; i < count ; ++i) + { + const keywordDesc* const p = &FortranKeywordTable [i]; + addKeyword (p->name, Lang_fortran, (int) p->id); + } +} + +/* +* Tag generation functions +*/ + +static boolean isFileScope (const tagType type) +{ + return (boolean) (type == TAG_LABEL || type == TAG_LOCAL); +} + +static boolean includeTag (const tagType type) +{ + boolean include; + Assert (type != TAG_UNDEFINED); + include = FortranKinds [(int) type].enabled; + if (include && isFileScope (type)) + include = Option.include.fileScope; + return include; +} + +static void makeFortranTag (tokenInfo *const token, tagType tag) +{ + token->tag = tag; + if (includeTag (token->tag)) + { + const char *const name = vStringValue (token->string); + tagEntryInfo e; + + initTagEntry (&e, name); + + if (token->tag == TAG_COMMON_BLOCK) + e.lineNumberEntry = (boolean) (Option.locate != EX_PATTERN); + + e.lineNumber = token->lineNumber; + e.filePosition = token->filePosition; + e.isFileScope = isFileScope (token->tag); + e.kindName = FortranKinds [token->tag].name; + e.kind = FortranKinds [token->tag].letter; + e.truncateLine = (boolean) (token->tag != TAG_LABEL); + + if (ancestorCount () > 0) + { + const tokenInfo* const parent = ancestorTop (); + e.extensionFields.scope [0] = FortranKinds [parent->tag].name; + e.extensionFields.scope [1] = vStringValue (parent->string); + } + makeTagEntry (&e); + } +} + +/* +* Parsing functions +*/ + +static int skipLine (void) +{ + int c; + + do + c = fileGetc (); + while (c != EOF && c != '\n'); + + return c; +} + +static void makeLabelTag (vString *const label) +{ + tokenInfo token; + + token.type = TOKEN_LABEL; + token.keyword = KEYWORD_NONE; + token.tag = TAG_LABEL; + token.string = label; + token.lineNumber = getSourceLineNumber (); + token.filePosition = getInputFilePosition (); + + makeFortranTag (&token, TAG_LABEL); +} + +static lineType getLineType (void) +{ + static vString *label = NULL; + int column = 0; + lineType type = LTYPE_UNDETERMINED; + + if (label == NULL) + label = vStringNew (); + + do /* read in first 6 "margin" characters */ + { + int c = fileGetc (); + + /* 3.2.1 Comment_Line. A comment line is any line that contains + * a C or an asterisk in column 1, or contains only blank characters + * in columns 1 through 72. A comment line that contains a C or + * an asterisk in column 1 may contain any character capable of + * representation in the processor in columns 2 through 72. + */ + /* EXCEPTION! Some compilers permit '!' as a commment character here. + * + * Treat '#' in column 1 as comment to permit preprocessor directives. + */ + if (column == 0 && strchr ("*Cc!#", c) != NULL) + type = LTYPE_COMMENT; + else if (c == '\t') /* EXCEPTION! Some compilers permit a tab here */ + { + column = 8; + type = LTYPE_INITIAL; + } + else if (column == 5) + { + /* 3.2.2 Initial_Line. An initial line is any line that is not + * a comment line and contains the character blank or the digit 0 + * in column 6. Columns 1 through 5 may contain a statement label + * (3.4), or each of the columns 1 through 5 must contain the + * character blank. + */ + if (c == ' ' || c == '0') + type = LTYPE_INITIAL; + + /* 3.2.3 Continuation_Line. A continuation line is any line that + * contains any character of the FORTRAN character set other than + * the character blank or the digit 0 in column 6 and contains + * only blank characters in columns 1 through 5. + */ + else if (vStringLength (label) == 0) + type = LTYPE_CONTINUATION; + else + type = LTYPE_INVALID; + } + else if (c == ' ') + ; + else if (c == EOF) + type = LTYPE_EOF; + else if (c == '\n') + type = LTYPE_SHORT; + else if (isdigit (c)) + vStringPut (label, c); + else + type = LTYPE_INVALID; + + ++column; + } while (column < 6 && type == LTYPE_UNDETERMINED); + + Assert (type != LTYPE_UNDETERMINED); + + if (vStringLength (label) > 0) + { + vStringTerminate (label); + makeLabelTag (label); + vStringClear (label); + } + return type; +} + +static int getFixedFormChar (void) +{ + boolean newline = FALSE; + lineType type; + int c = '\0'; + + if (Column > 0) + { +#ifdef STRICT_FIXED_FORM + /* EXCEPTION! Some compilers permit more than 72 characters per line. + */ + if (Column > 71) + c = skipLine (); + else +#endif + { + c = fileGetc (); + ++Column; + } + if (c == '\n') + { + newline = TRUE; /* need to check for continuation line */ + Column = 0; + } + else if (c == '&') /* check for free source form */ + { + const int c2 = fileGetc (); + if (c2 == '\n') + longjmp (Exception, (int) ExceptionFixedFormat); + else + fileUngetc (c2); + } + } + while (Column == 0) + { + type = getLineType (); + switch (type) + { + case LTYPE_UNDETERMINED: + case LTYPE_INVALID: + longjmp (Exception, (int) ExceptionFixedFormat); + break; + + case LTYPE_SHORT: break; + case LTYPE_COMMENT: skipLine (); break; + + case LTYPE_EOF: + Column = 6; + if (newline) + c = '\n'; + else + c = EOF; + break; + + case LTYPE_INITIAL: + if (newline) + { + c = '\n'; + Column = 6; + break; + } + /* fall through to next case */ + case LTYPE_CONTINUATION: + Column = 5; + do + { + c = fileGetc (); + ++Column; + } while (isBlank (c)); + if (c == '\n') + Column = 0; + else if (Column > 6) + { + fileUngetc (c); + c = ' '; + } + break; + + default: + Assert ("Unexpected line type" == NULL); + } + } + return c; +} + +static int skipToNextLine (void) +{ + int c = skipLine (); + if (c != EOF) + c = fileGetc (); + return c; +} + +static int getFreeFormChar (void) +{ + static boolean newline = TRUE; + boolean recurse = FALSE; + int c = fileGetc (); + + if (c == '&') /* handle line continuation */ + { + recurse = TRUE; + c = fileGetc (); + } + else if (newline && (c == '!' || c == '#')) + recurse = TRUE; + while (recurse) + { + while (isspace (c)) + c = fileGetc (); + while (c == '!' || (newline && c == '#')) + { + c = skipToNextLine (); + newline = TRUE; + } + if (c == '&') + c = fileGetc (); + else + recurse = FALSE; + } + newline = (boolean) (c == '\n'); + return c; +} + +static int getChar (void) +{ + int c; + + if (Ungetc != '\0') + { + c = Ungetc; + Ungetc = '\0'; + } + else if (FreeSourceForm) + c = getFreeFormChar (); + else + c = getFixedFormChar (); + + return c; +} + +static void ungetChar (const int c) +{ + Ungetc = c; +} + +/* If a numeric is passed in 'c', this is used as the first digit of the + * numeric being parsed. + */ +static vString *parseInteger (int c) +{ + static vString *string = NULL; + + if (string == NULL) + string = vStringNew (); + vStringClear (string); + + if (c == '-') + { + vStringPut (string, c); + c = getChar (); + } + else if (! isdigit (c)) + c = getChar (); + while (c != EOF && isdigit (c)) + { + vStringPut (string, c); + c = getChar (); + } + vStringTerminate (string); + + if (c == '_') + { + do + c = getChar (); + while (c != EOF && isalpha (c)); + } + ungetChar (c); + + return string; +} + +static vString *parseNumeric (int c) +{ + static vString *string = NULL; + + if (string == NULL) + string = vStringNew (); + vStringCopy (string, parseInteger (c)); + + c = getChar (); + if (c == '.') + { + vStringPut (string, c); + vStringCat (string, parseInteger ('\0')); + c = getChar (); + } + if (tolower (c) == 'e') + { + vStringPut (string, c); + vStringCat (string, parseInteger ('\0')); + } + else + ungetChar (c); + + vStringTerminate (string); + + return string; +} + +static void parseString (vString *const string, const int delimeter) +{ + const unsigned long inputLineNumber = getInputLineNumber (); + int c = getChar (); + + while (c != delimeter && c != '\n' && c != EOF) + { + vStringPut (string, c); + c = getChar (); + } + if (c == '\n' || c == EOF) + { + verbose ("%s: unterminated character string at line %lu\n", + getInputFileName (), inputLineNumber); + if (c == EOF) + longjmp (Exception, (int) ExceptionEOF); + else if (! FreeSourceForm) + longjmp (Exception, (int) ExceptionFixedFormat); + } + vStringTerminate (string); +} + +/* Read a C identifier beginning with "firstChar" and places it into "name". + */ +static void parseIdentifier (vString *const string, const int firstChar) +{ + int c = firstChar; + + do + { + vStringPut (string, c); + c = getChar (); + } while (isident (c)); + + vStringTerminate (string); + ungetChar (c); /* unget non-identifier character */ +} + +static tokenInfo *newToken (void) +{ + tokenInfo *const token = xMalloc (1, tokenInfo); + + token->type = TOKEN_UNDEFINED; + token->keyword = KEYWORD_NONE; + token->tag = TAG_UNDEFINED; + token->string = vStringNew (); + token->lineNumber = getSourceLineNumber (); + token->filePosition = getInputFilePosition (); + + return token; +} + +static void deleteToken (tokenInfo *const token) +{ + vStringDelete (token->string); + eFree (token); +} + +/* Analyzes the identifier contained in a statement described by the + * statement structure and adjusts the structure according the significance + * of the identifier. + */ +static keywordId analyzeToken (vString *const name) +{ + static vString *keyword = NULL; + keywordId id; + + if (keyword == NULL) + keyword = vStringNew (); + vStringCopyToLower (keyword, name); + id = (keywordId) lookupKeyword (vStringValue (keyword), Lang_fortran); + + return id; +} + +static void checkForLabel (void) +{ + tokenInfo* token = NULL; + int length; + int c; + + do + c = getChar (); + while (isBlank (c)); + + for (length = 0 ; isdigit (c) && length < 5 ; ++length) + { + if (token == NULL) + { + token = newToken (); + token->type = TOKEN_LABEL; + } + vStringPut (token->string, c); + c = getChar (); + } + if (length > 0) + { + Assert (token != NULL); + vStringTerminate (token->string); + makeFortranTag (token, TAG_LABEL); + deleteToken (token); + } + ungetChar (c); +} + +static void readToken (tokenInfo *const token) +{ + int c; + + token->type = TOKEN_UNDEFINED; + token->tag = TAG_UNDEFINED; + token->keyword = KEYWORD_NONE; + vStringClear (token->string); + +getNextChar: + token->lineNumber = getSourceLineNumber (); + token->filePosition = getInputFilePosition (); + + c = getChar (); + + switch (c) + { + case EOF: longjmp (Exception, (int) ExceptionEOF); break; + case ' ': goto getNextChar; + case '\t': goto getNextChar; + case ',': token->type = TOKEN_COMMA; break; + case '(': token->type = TOKEN_PAREN_OPEN; break; + case ')': token->type = TOKEN_PAREN_CLOSE; break; + + case '*': + case '/': + case '+': + case '-': + case '=': + case '<': + case '>': + { + const char *const operatorChars = "*/+-=<>"; + + do { + vStringPut (token->string, c); + c = getChar (); + } while (strchr (operatorChars, c) != NULL); + ungetChar (c); + vStringTerminate (token->string); + token->type = TOKEN_OPERATOR; + break; + } + + case '!': + if (FreeSourceForm) + { + do + c = getChar (); + while (c != '\n'); + } + else + { + skipLine (); + Column = 0; + } + /* fall through to newline case */ + case '\n': + token->type = TOKEN_STATEMENT_END; + if (FreeSourceForm) + checkForLabel (); + break; + + case '.': + parseIdentifier (token->string, c); + c = getChar (); + if (c == '.') + { + vStringPut (token->string, c); + vStringTerminate (token->string); + token->type = TOKEN_OPERATOR; + } + else + { + ungetChar (c); + token->type = TOKEN_UNDEFINED; + } + break; + + case ':': + if (getChar () == ':') + token->type = TOKEN_DOUBLE_COLON; + else + token->type = TOKEN_UNDEFINED; + break; + + default: + if (isalpha (c)) + { + parseIdentifier (token->string, c); + token->keyword = analyzeToken (token->string); + if (isKeyword (token, KEYWORD_NONE)) + token->type = TOKEN_IDENTIFIER; + else + token->type = TOKEN_KEYWORD; + } + else if (isdigit (c)) + { + vStringCat (token->string, parseNumeric (c)); + token->type = TOKEN_NUMERIC; + } + else if (c == '"' || c == ''') + { + parseString (token->string, c); + token->type = TOKEN_STRING; + } + else if (c == ';' && FreeSourceForm) + token->type = TOKEN_STATEMENT_END; + else + token->type = TOKEN_UNDEFINED; + break; + } +} + +/* +* Scanning functions +*/ + +static void skipToToken (tokenInfo *const token, tokenType type) +{ + while (! isType (token, type) && ! isType (token, TOKEN_STATEMENT_END)) + readToken (token); +} + +static void skipPast (tokenInfo *const token, tokenType type) +{ + skipToToken (token, type); + if (! isType (token, TOKEN_STATEMENT_END)) + readToken (token); +} + +static void skipToNextStatement (tokenInfo *const token) +{ + do + { + skipToToken (token, TOKEN_STATEMENT_END); + readToken (token); + } while (isType (token, TOKEN_STATEMENT_END)); +} + +static boolean isTypeSpec (tokenInfo *const token) +{ + boolean result; + switch (token->keyword) + { + case KEYWORD_integer: + case KEYWORD_real: + case KEYWORD_double: + case KEYWORD_complex: + case KEYWORD_character: + case KEYWORD_logical: + case KEYWORD_type: + result = TRUE; + break; + default: + result = FALSE; + break; + } + return result; +} + +/* type-spec + * is INTEGER [kind-selector] + * or REAL [kind-selector] is ( etc. ) + * or DOUBLE PRECISION + * or COMPLEX [kind-selector] + * or CHARACTER [kind-selector] + * or LOGICAL [kind-selector] + * or TYPE ( type-name ) + * + * Note that INTEGER and REAL may be followed by "*N" where "N" is an integer + */ +static void parseTypeSpec (tokenInfo *const token) +{ + /* parse type-spec, leaving `token' at first token following type-spec */ + Assert (isTypeSpec (token)); + switch (token->keyword) + { + case KEYWORD_integer: + case KEYWORD_real: + case KEYWORD_complex: + case KEYWORD_character: + case KEYWORD_logical: + readToken (token); + if (isType (token, TOKEN_PAREN_OPEN)) + skipPast (token, TOKEN_PAREN_CLOSE); /* skip kind-selector */ + else if (isType (token, TOKEN_OPERATOR) && + strcmp (vStringValue (token->string), "*") == 0) + { + readToken (token); + readToken (token); + } + break; + + case KEYWORD_double: + readToken (token); + if (! isKeyword (token, KEYWORD_precision)) + skipToToken (token, TOKEN_STATEMENT_END); + break; + + case KEYWORD_type: + readToken (token); + if (isType (token, TOKEN_PAREN_OPEN)) + skipPast (token, TOKEN_PAREN_CLOSE); /* skip type-name */ + else + parseDerivedTypeDef (token); + break; + + default: + skipToToken (token, TOKEN_STATEMENT_END); + break; + } +} + +/* skip over parenthesis enclosed contents starting at next token. + * Token refers to first token following closing parenthesis. If an opening + * parenthesis is not found, `token' is moved to the end of the statement. + */ +static void skipOverParens (tokenInfo *const token) +{ + if (isType (token, TOKEN_PAREN_OPEN)) + skipPast (token, TOKEN_PAREN_CLOSE); +} + +static boolean skipStatementIfKeyword (tokenInfo *const token, keywordId keyword) +{ + boolean result = FALSE; + if (isKeyword (token, keyword)) + { + result = TRUE; + skipToNextStatement (token); + } + return result; +} + +static boolean isMatchingEnd (tokenInfo *const token, keywordId keyword) +{ + boolean result = FALSE; + if (isKeyword (token, KEYWORD_end)) + { + readToken (token); + result = (boolean) (isKeyword (token, KEYWORD_NONE) || + isKeyword (token, keyword)); + } + return result; +} + +/* parse a list of qualifying specifiers, leaving `token' at first token + * following list. Examples of such specifiers are: + * [[, attr-spec] ::] + * [[, component-attr-spec-list] ::] + * + * attr-spec + * is PARAMETER + * or access-spec (is PUBLIC or PRIVATE) + * or ALLOCATABLE + * or DIMENSION ( array-spec ) + * or EXTERNAL + * or INTENT ( intent-spec ) + * or INTRINSIC + * or OPTIONAL + * or POINTER + * or SAVE + * or TARGET + * + * component-attr-spec + * is POINTER + * or DIMENSION ( component-array-spec ) + */ +static void parseQualifierSpecList (tokenInfo *const token) +{ + do + { + readToken (token); /* should be an attr-spec */ + switch (token->keyword) + { + case KEYWORD_parameter: + case KEYWORD_allocatable: + case KEYWORD_external: + case KEYWORD_intrinsic: + case KEYWORD_optional: + case KEYWORD_private: + case KEYWORD_pointer: + case KEYWORD_public: + case KEYWORD_save: + case KEYWORD_target: + readToken (token); + break; + + case KEYWORD_dimension: + case KEYWORD_intent: + readToken (token); + skipOverParens (token); + break; + + default: skipToToken (token, TOKEN_STATEMENT_END); break; + } + } while (isType (token, TOKEN_COMMA)); + if (! isType (token, TOKEN_DOUBLE_COLON)) + skipToToken (token, TOKEN_STATEMENT_END); +} + +static boolean localVariableScope (void) +{ + boolean result = TRUE; + if (ancestorCount () > 0) + { + const tokenInfo* const parent = ancestorTop (); + result = (boolean) (parent->tag != TAG_MODULE); + } + return result; +} + +/* type-declaration-stmt is + * type-spec [[, attr-spec] ... ::] entity-decl-list + */ +static void parseTypeDeclarationStmt (tokenInfo *const token) +{ + const tagType tag = localVariableScope () ? TAG_LOCAL : TAG_VARIABLE; + Assert (isTypeSpec (token)); + parseTypeSpec (token); + if (isType (token, TOKEN_COMMA)) + parseQualifierSpecList (token); + if (isType (token, TOKEN_DOUBLE_COLON)) + readToken (token); + do + { + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, tag); + skipPast (token, TOKEN_COMMA); + } while (! isType (token, TOKEN_STATEMENT_END)); + skipToNextStatement (token); +} + +static void parseParenName (tokenInfo *const token) +{ + readToken (token); + if (isType (token, TOKEN_PAREN_OPEN)) + readToken (token); +} + +/* common-stmt is + * COMMON [/[common-block-name]/] common-block-object-list [[,]/[common-block-name]/ common-block-object-list] ... + * + * common-block-object is + * variable-name [ ( explicit-shape-spec-list ) ] + */ +static void parseCommonStmt (tokenInfo *const token) +{ + Assert (isKeyword (token, KEYWORD_common)); + readToken (token); + do + { + if (isType (token, TOKEN_OPERATOR)) + { + readToken (token); + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, TAG_COMMON_BLOCK); + skipPast (token, TOKEN_OPERATOR); + } + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, TAG_LOCAL); + skipPast (token, TOKEN_COMMA); + } while (! isType (token, TOKEN_STATEMENT_END)); + skipToNextStatement (token); +} + +static void tagSlashName (tokenInfo *const token, const tagType type) +{ + readToken (token); + if (isType (token, TOKEN_OPERATOR)) + { + readToken (token); + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, type); + } +} + +/* specification-stmt + * is access-stmt (is access-spec [[::] access-id-list) + * or allocatable-stmt (is ALLOCATABLE [::] array-name etc.) + * or common-stmt (is COMMON [ / [common-block-name] /] etc.) + * or data-stmt (is DATA data-stmt-list [[,] data-stmt-set] ...) + * or dimension-stmt (is DIMENSION [::] array-name etc.) + * or equivalence-stmt (is EQUIVALENCE equivalence-set-list) + * or external-stmt (is EXTERNAL etc.) + * or intent-stmt (is INTENT ( intent-spec ) [::] etc.) + * or instrinsic-stmt (is INTRINSIC etc.) + * or namelist-stmt (is NAMELIST / namelist-group-name / etc.) + * or optional-stmt (is OPTIONAL [::] etc.) + * or pointer-stmt (is POINTER [::] object-name etc.) + * or save-stmt (is SAVE etc.) + * or target-stmt (is TARGET [::] object-name etc.) + * + * access-spec is PUBLIC or PRIVATE + */ +static boolean parseSpecificationStmt (tokenInfo *const token) +{ + boolean result = TRUE; + switch (token->keyword) + { + case KEYWORD_common: parseCommonStmt (token); break; + + case KEYWORD_namelist: + tagSlashName (token, TAG_NAMELIST); + skipToNextStatement (token); + break; + + case KEYWORD_allocatable: + case KEYWORD_data: + case KEYWORD_dimension: + case KEYWORD_equivalence: + case KEYWORD_external: + case KEYWORD_intent: + case KEYWORD_intrinsic: + case KEYWORD_optional: + case KEYWORD_pointer: + case KEYWORD_private: + case KEYWORD_public: + case KEYWORD_save: + case KEYWORD_target: + skipToNextStatement (token); + break; + + default: + result = FALSE; + break; + } + return result; +} + +/* component-def-stmt is + * type-spec [[, component-attr-spec-list] ::] component-decl-list + * + * component-decl is + * component-name [ ( component-array-spec ) ] [ * char-length ] + */ +static void parseComponentDefStmt (tokenInfo *const token) +{ + Assert (isTypeSpec (token)); + parseTypeSpec (token); + if (isType (token, TOKEN_COMMA)) + parseQualifierSpecList (token); + if (isType (token, TOKEN_DOUBLE_COLON)) + readToken (token); + do + { + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, TAG_COMPONENT); + skipPast (token, TOKEN_COMMA); + } while (! isType (token, TOKEN_STATEMENT_END)); + readToken (token); +} + +/* derived-type-def is + * derived-type-stmt is (TYPE [[, access-spec] ::] type-name + * [private-sequence-stmt] ... (is PRIVATE or SEQUENCE) + * component-def-stmt + * [component-def-stmt] ... + * end-type-stmt + */ +static void parseDerivedTypeDef (tokenInfo *const token) +{ + if (isType (token, TOKEN_COMMA)) + parseQualifierSpecList (token); + if (isType (token, TOKEN_DOUBLE_COLON)) + readToken (token); + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, TAG_DERIVED_TYPE); + ancestorPush (token); + skipToNextStatement (token); + if (isKeyword (token, KEYWORD_private) || + isKeyword (token, KEYWORD_sequence)) + { + skipToNextStatement (token); + } + while (! isMatchingEnd (token, KEYWORD_type)) + { + if (isTypeSpec (token)) + parseComponentDefStmt (token); + else + skipToNextStatement (token); + } + ancestorPop (); +} + +/* interface-block + * interface-stmt (is INTERFACE [generic-spec]) + * [interface-body] + * [module-procedure-stmt] ... + * end-interface-stmt (is END INTERFACE) + * + * generic-spec + * is generic-name + * or OPERATOR ( defined-operator ) + * or ASSIGNMENT ( = ) + * + * interface-body + * is function-stmt + * [specification-part] + * end-function-stmt + * or subroutine-stmt + * [specification-part] + * end-subroutine-stmt + * + * module-procedure-stmt is + * MODULE PROCEDURE procedure-name-list + */ +static void parseInterfaceBlock (tokenInfo *const token) +{ + readToken (token); + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, TAG_INTERFACE); + else if (isKeyword (token, KEYWORD_assignment) || + isKeyword (token, KEYWORD_operator)) + { + parseParenName (token); + + if (isType (token, TOKEN_OPERATOR)) + makeFortranTag (token, TAG_INTERFACE); + } + while (! isMatchingEnd (token, KEYWORD_interface)) + readToken (token); + skipToNextStatement (token); +} + +/* entry-stmt is + * ENTRY entry-name [ ( dummy-arg-list ) ] + */ +static void parseEntryStmt (tokenInfo *const token) +{ + Assert (isKeyword (token, KEYWORD_entry)); + readToken (token); + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, TAG_ENTRY_POINT); + skipToNextStatement (token); +} + + /* stmt-function-stmt is + * function-name ([dummy-arg-name-list]) = scalar-expr + */ +static boolean parseStmtFunctionStmt (tokenInfo *const token) +{ + boolean result = FALSE; + Assert (isType (token, TOKEN_IDENTIFIER)); +#if 0 /* cannot reliably parse this yet */ + makeFortranTag (token, TAG_FUNCTION); +#endif + readToken (token); + if (isType (token, TOKEN_PAREN_OPEN)) + { + skipOverParens (token); + result = (boolean) (isType (token, TOKEN_OPERATOR) && + strcmp (vStringValue (token->string), "=") == 0); + } + skipToNextStatement (token); + return result; +} + +/* declaration-construct + * [derived-type-def] + * [interface-block] + * [type-declaration-stmt] + * [specification-stmt] + * [parameter-stmt] (is PARAMETER ( named-constant-def-list ) + * [format-stmt] (is FORMAT format-specification) + * [entry-stmt] + * [stmt-function-stmt] + */ +static boolean parseDeclarationConstruct (tokenInfo *const token) +{ + boolean result = TRUE; + switch (token->keyword) + { + case KEYWORD_entry: parseEntryStmt (token); break; + case KEYWORD_interface: parseInterfaceBlock (token); break; + case KEYWORD_format: skipToNextStatement (token); break; + case KEYWORD_parameter: skipToNextStatement (token); break; + case KEYWORD_include: skipToNextStatement (token); break; + /* derived type handled by parseTypeDeclarationStmt(); */ + + default: + if (isTypeSpec (token)) + { + parseTypeDeclarationStmt (token); + result = TRUE; + } + else if (isType (token, TOKEN_IDENTIFIER)) + result = parseStmtFunctionStmt (token); + else + result = parseSpecificationStmt (token); + break; + } + return result; +} + +/* implicit-part-stmt + * is [implicit-stmt] (is IMPLICIT etc.) + * or [parameter-stmt] (is PARAMETER etc.) + * or [format-stmt] (is FORMAT etc.) + * or [entry-stmt] (is ENTRY entry-name etc.) + */ +static boolean parseImplicitPartStmt (tokenInfo *const token) +{ + boolean result = TRUE; + switch (token->keyword) + { + case KEYWORD_entry: parseEntryStmt (token); break; + + case KEYWORD_implicit: + case KEYWORD_include: + case KEYWORD_parameter: + case KEYWORD_format: + skipToNextStatement (token); + break; + + default: result = FALSE; break; + } + return result; +} + +/* specification-part is + * [use-stmt] ... (is USE module-name etc.) + * [implicit-part] (is [implicit-part-stmt] ... [implicit-stmt]) + * [declaration-construct] ... + */ +static void parseSpecificationPart (tokenInfo *const token) +{ + while (skipStatementIfKeyword (token, KEYWORD_use)) + ; + while (parseImplicitPartStmt (token)) + ; + while (parseDeclarationConstruct (token)) + ; +} + +/* block-data is + * block-data-stmt (is BLOCK DATA [block-data-name] + * [specification-part] + * end-block-data-stmt (is END [BLOCK DATA [block-data-name]]) + */ +static void parseBlockData (tokenInfo *const token) +{ + Assert (isKeyword (token, KEYWORD_block)); + readToken (token); + if (isKeyword (token, KEYWORD_data)) + { + readToken (token); + makeFortranTag (token, TAG_BLOCK_DATA); + } + ancestorPush (token); + skipToNextStatement (token); + parseSpecificationPart (token); + while (! isMatchingEnd (token, KEYWORD_block)) + readToken (token); + skipToNextStatement (token); + ancestorPop (); +} + +/* internal-subprogram-part is + * contains-stmt (is CONTAINS) + * internal-subprogram + * [internal-subprogram] ... + * + * internal-subprogram + * is function-subprogram + * or subroutine-subprogram + */ +static void parseInternalSubprogramPart (tokenInfo *const token) +{ + boolean done = FALSE; + Assert (isKeyword (token, KEYWORD_contains)); + skipToNextStatement (token); + do + { + switch (token->keyword) + { + case KEYWORD_function: parseFunctionSubprogram (token); break; + case KEYWORD_subroutine: parseSubroutineSubprogram (token); break; + case KEYWORD_recursive: readToken (token); break; + + default: + if (isTypeSpec (token)) + parseTypeSpec (token); + else + done = TRUE; + break; + } + } while (! done); +} + +/* module is + * mudule-stmt (is MODULE module-name) + * [specification-part] + * [module-subprogram-part] + * end-module-stmt (is END [MODULE [module-name]]) + * + * module-subprogram-part + * contains-stmt (is CONTAINS) + * module-subprogram + * [module-subprogram] ... + * + * module-subprogram + * is function-subprogram + * or subroutine-subprogram + */ +static void parseModule (tokenInfo *const token) +{ + Assert (isKeyword (token, KEYWORD_module)); + readToken (token); + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, TAG_MODULE); + ancestorPush (token); + skipToNextStatement (token); + parseSpecificationPart (token); + if (isKeyword (token, KEYWORD_contains)) + parseInternalSubprogramPart (token); + while (! isMatchingEnd (token, KEYWORD_module)) + readToken (token); + skipToNextStatement (token); + ancestorPop (); +} + +/* execution-part + * executable-contstruct + * + * executable-contstruct is + * execution-part-construct [execution-part-construct] + * + * execution-part-construct + * is executable-construct + * or format-stmt + * or data-stmt + * or entry-stmt + */ +static void parseExecutionPart (tokenInfo *const token, const keywordId keyword) +{ + while (! isMatchingEnd (token, keyword)) + { + readToken (token); + if (isKeyword (token, KEYWORD_contains)) + parseInternalSubprogramPart (token); + else if (isKeyword (token, KEYWORD_entry)) + parseEntryStmt (token); + skipOverParens (token); + } + skipToNextStatement (token); +} + +static void parseSubprogram (tokenInfo *const token, + const keywordId keyword, const tagType tag) +{ + Assert (isKeyword (token, keyword)); + readToken (token); + if (isType (token, TOKEN_IDENTIFIER)) + makeFortranTag (token, tag); + ancestorPush (token); + skipToNextStatement (token); + parseSpecificationPart (token); + parseExecutionPart (token, keyword); + ancestorPop (); +} + + +/* function-subprogram is + * function-stmt (is [prefix] FUNCTION function-name etc.) + * [specification-part] + * [execution-part] + * [internal-subprogram-part] + * end-function-stmt (is END [FUNCTION [function-name]]) + * + * prefix + * is type-spec [RECURSIVE] + * or [RECURSIVE] type-spec + */ +static void parseFunctionSubprogram (tokenInfo *const token) +{ + parseSubprogram (token, KEYWORD_function, TAG_FUNCTION); +} + +/* subroutine-subprogram is + * subroutine-stmt (is [RECURSIVE] SUBROUTINE subroutine-name etc.) + * [specification-part] + * [execution-part] + * [internal-subprogram-part] + * end-subroutine-stmt (is END [SUBROUTINE [function-name]]) + */ +static void parseSubroutineSubprogram (tokenInfo *const token) +{ + parseSubprogram (token, KEYWORD_subroutine, TAG_SUBROUTINE); +} + +/* main-program is + * [program-stmt] (is PROGRAM program-name) + * [specification-part] + * [execution-part] + * [internal-subprogram-part ] + * end-program-stmt + */ +static void parseMainProgram (tokenInfo *const token) +{ + parseSubprogram (token, KEYWORD_program, TAG_PROGRAM); +} + +/* program-unit + * is main-program + * or external-subprogram (is function-subprogram or subroutine-subprogram) + * or module + * or block-data + */ +static void parseProgramUnit (tokenInfo *const token) +{ + readToken (token); + do + { + if (isType (token, TOKEN_STATEMENT_END)) + readToken (token); + else switch (token->keyword) + { + case KEYWORD_block: parseBlockData (token); break; + case KEYWORD_function: parseFunctionSubprogram (token); break; + case KEYWORD_module: parseModule (token); break; + case KEYWORD_program: parseMainProgram (token); break; + case KEYWORD_subroutine: parseSubroutineSubprogram (token); break; + case KEYWORD_recursive: readToken (token); break; + default: + if (isTypeSpec (token)) + parseTypeSpec (token); + else + { + parseSpecificationPart (token); + parseExecutionPart (token, KEYWORD_NONE); + } + break; + } + } while (TRUE); +} + +static boolean findFortranTags (const unsigned int passCount) +{ + tokenInfo *token; + exception_t exception; + boolean retry; + + Assert (passCount < 3); + Parent = newToken (); + token = newToken (); + FreeSourceForm = (boolean) (passCount > 1); + Column = 0; + exception = (exception_t) setjmp (Exception); + if (exception == ExceptionEOF) + retry = FALSE; + else if (exception == ExceptionFixedFormat && ! FreeSourceForm) + { + verbose ("%s: not fixed source form; retry as free source form\n", + getInputFileName ()); + retry = TRUE; + } + else + { + parseProgramUnit (token); + retry = FALSE; + } + ancestorClear (); + deleteToken (token); + deleteToken (Parent); + + return retry; +} + +static void initialize (const langType language) +{ + Lang_fortran = language; + buildFortranKeywordHash (); +} + +extern parserDefinition* FortranParser (void) +{ + static const char *const extensions [] = { + "f", "for", "ftn", "f77", "f90", "f95", +#ifndef CASE_INSENSITIVE_FILENAMES + "F", "FOR", "FTN", "F77", "F90", "F95", +#endif + NULL + }; + parserDefinition* def = parserNew ("Fortran"); + def->kinds = FortranKinds; + def->kindCount = KIND_COUNT (FortranKinds); + def->extensions = extensions; + def->parser2 = findFortranTags; + def->initialize = initialize; + return def; +} + +/* vi:set tabstop=8 shiftwidth=4: */
Modified: trunk/tagmanager/parsers.h =================================================================== --- trunk/tagmanager/parsers.h 2006-08-15 15:53:18 UTC (rev 723) +++ trunk/tagmanager/parsers.h 2006-08-15 17:57:41 UTC (rev 724) @@ -32,7 +32,8 @@ RubyParser, \ TclParser, \ ShParser, \ - DParser + DParser, \ + FortranParser
/* langType of each parser @@ -54,6 +55,7 @@ 15 TclParser 16 ShParser 17 DParser +18 FortranParser */ #endif /* _PARSERS_H */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.