Internet File Formats/InternetFileFormatsCD.bin/text/latex/mac/alpha60.hqx/Tcl/SystemCode/fortran.tcl

Text File | 1995-05-08 | 8.9 KB | 323 lines

#=============================================================================
# Fortran mode definition
#
# modified 12/94 by Tom Pollard <[e-mail]>
#  - fixed funcExpr, FortMarkFile search expressions
#  - changed comment character from 'C' to 'c' (why isn't it case-insensitive?)
#  - added 'include' keyword
#  - added FortShiftRight and FortShiftLeft procs
#
# modified 5/95
#  - added Cmd-Dbl-Click handler
#  - added auto-indentation
#
proc dummyFort {} {}

newModeVar Fort    prefixString    {c}    0
newModeVar Fort sortedIsDefault    {0} 1
newModeVar Fort wordWrap        {0}    1
newModeVar Fort funcExpr    {^[^c][ \t]*(subroutine|[ \ta-z*0-9]*function|entry).*$} 0
newModeVar Fort autoMark        0    1

set FortKeywords {
  backspace block call character close common complex
  continue data dimension do double else elseif end enddo endfile endif entry
  equivalence external format function goto if implicit include inquire integer
  intrinsic logical open parameter precision print program read return save
  stop real rewind subroutine then write
}

regModeKeywords -e {c} -c red -k blue Fort $FortKeywords
unset FortKeywords


bind '\[' <c>  FortShiftLeft Fort
bind '\[' <co> FortShiftLeftSpace Fort
bind '\]' <c>  FortShiftRight Fort
bind '\]' <co> FortShiftRightSpace Fort

bind '\t' <z>     doATab Fort

#=============================================================================

proc FortMarkFile {} {
  set pat1 {^[^c][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+([a-z0-9_]+)}
  set end [maxPos]
  set pos 0
  set l {}
  while {![catch {search -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
    regexp -nocase $pat1 [eval getText $mtch] allofit subtyp name
    set start [lindex $mtch 0]
    set end [nextLineStart $start]
    set pos $end
    set inds($name) [lineStart $start]
  }

  if {[info exists inds]} {
    foreach f [lsort [array names inds]] {
      set next [nextLineStart $inds($f)]
      setNamedMark $f $inds($f) $next $next
    }
  }
}

#================================================================================
# Block shift left and right for Fortran mode (preserves cols 1-6)
#================================================================================

proc FortShiftLeft {} {
    global shiftChar
    doFortShiftLeft "\t"

}
proc FortShiftLeftSpace {} {
    global shiftChar
    doFortShiftLeft " "
}

proc doFortShiftLeft {shiftChar} {
    set start [lineStart [getPos]]
    set end [nextLineStart [expr [selEnd] - 1]]
    if {$start >= $end} {set end [nextLineStart $start]}

    set text [split [getText $start [expr $end - 1]] "\r"]

    set textout ""

    set pat {^(c|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
    foreach line $text {
    if {[regexp $pat $line mtch pref body]} {
        if {[string index $body 0] == $shiftChar} {
        lappend textout $pref[string range $body 1 end]
        } else {
        lappend textout $line
        }
    } else {
        lappend textout $line
    }
    }

    set text [join $textout "\r"]
    replaceText $start [expr $end - 1] $text
    select $start [expr 1 + $start + [string length $text]]
}

proc FortShiftRight {} {
    global shiftChar
    doFortShiftRight "\t"

}
proc FortShiftRightSpace {} {
    global shiftChar
    doFortShiftRight " "
}

proc doFortShiftRight {shiftChar} {
    set start [lineStart [getPos]]
    set end [nextLineStart [expr [selEnd] - 1]]
    if {$start >= $end} {set end [nextLineStart $start]}

    set text [split [getText $start [expr $end - 1]] "\r"]

    set textout ""

    set pat {^(c|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
    foreach line $text {
    if {[regexp $pat $line mtch pref body]} {
        lappend textout $pref$shiftChar$body
    } else {
        lappend textout $line
    }
    }

    set text [join $textout "\r"]
    replaceText $start [expr $end - 1] $text
    select $start [expr 1 + $start + [string length $text]]
}

#=============================================================================

proc FortDblClick {from to} {
    global tagFile

    select $from $to
    set text [getSelect]

    set lines [grep "^$text'" $tagFile]
    if {[regexp {'(.*)'(.*[^\t])(\t)+░} $lines dummy one two]} {
        if {[string match "*$one*" [winNames -f]]} {
            bringToFront $one
        } else {
            edit $one
        }
        set inds [search -f 1 -r 0 "$two" 0]
        display [lindex $inds 0]
        eval select $inds
    }
}

####################################################################################
# Fortan auto-indentation
#
# Author:    Tom Pollard <[e-mail]>
# Released:    2/17/95
#
# Logic:
#    0.    Identify previous line
#            a) ignore comments and continuation lines
#            b) if current line is a CONTINUE that matches a DO, use the
#                first corresponding DO as the previous line
#
#    1.    Find leading whitespace for previous line
#
#    2.    Increase whitespace if previous line starts a block, i.e.,
#            a) DO loop
#            b) IF ... THEN
#            c) ELSE
#
#    3.    Decrease whitespace if current line ends a block, i.e.,
#            a) ELSE || ENDIF || END IF || ENDDO || END DO
#            b) <linenum> CONTINUE matching a preceding DO
#
#        or if previous line ends a DO loop on an executable statement, i.e.,
#            c) <linenum> (not CONTINUE) matching a preceding DO
#
proc FortindentLine {} {
    set subPat {^[^c][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+([a-z0-9_]+)}
    set bolPat {^[^c\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
    set mtPat {^[ \t]*$}
    set tab "    "

    set contPat {^     ([^ \t\n\r])[^\r\n]*$}
    set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
    set comPat {^cc*([ \t]*)(.*)$}
    set comPat1 {^cc*([ \t]*)(.*[^ \t])[ \t]*$}
    set doPat {^[^c\n\r][ \t]*do[ \t]+}
    set tailPat {[^\r\n]*$}

    set bobPat {^(if[^\n\r]*then|else|do)}
    set eobPat {^(end[ \t]*if|end[ \t]*do|else)}

    set bol [lineStart [getPos]]
    set eol [expr [nextLineStart $bol] - 1]

    # find the beginning of the current routine
    #
    if {![catch {search -f 0 -r 1 -m 0 -i 1 $subPat $bol} sublst]} {
         set subLine [eval getText $sublst]
#        alertnote "subLine: \/$subLine\/"
        set top [lindex $sublst 0]
    } else {
        set top 0
    }

    set thisLine [getText $bol $eol]

    # Is the current line a comment line...
    #
    if {[regexp $comPat $thisLine allofit pre body]} {
        set body [string trimright $body]
#        alertnote "line: \/$pre\/$body\/"
        set lwhite "c     "
        set lnum ""

        replaceText $bol $eol $lwhite$body

    # ... or a line of code (possibly empty)?
    #
    } elseif {[regexp $lnumPat $thisLine allofit pre lnum post body]} {
        set body [string trimright $body]
#        alertnote "line: \/$pre\/$lnum\/$post\/$body\/"

        # is it a continuation line?
        #
        if {(![regexp {\t} $pre]) && ([string length $pre] == 5)} {
                set cont [string index $lnum$post$body 0]
                set body [string trimleft [string range $lnum$post$body 1 end]]
        } else {
            set cont {}
        }
#        alertnote "cont: \/$cont\/"

        # if there's a line number, check for a matching DO statement ...
        #
        if {[string length $lnum] &&
                ![catch {search -s -f 1 -r 1 -i 1 -l [expr $bol -1] $doPat$lnum $top} dolst]} {
              set prevLine [eval getText $dolst]
              set enddo 1

        # ... otherwise find the first preceding non-comment, non-continuation line
        #
        } else {
            set lst [search -s -f 0 -r 1 -i 1 $bolPat [expr $bol-1]]
            set prevLine [eval getText $lst]
            while {[regexp $contPat $prevLine]} {
                set lst [search -s -f 0 -r 1 -i 1 $bolPat [expr [lindex $lst 0] - 1]]
                set prevLine [eval getText $lst]
            }
              set enddo 0
        }
#        alertnote "prevLine: \/$prevLine\/"

        # get whitespace for preceding line (ignoring linenums)
        #
        if {[regexp $lnumPat $prevLine allofit pre0 lnum0 post0 body0]} {
#            alertnote "prevLine: \/$pre0\/$lnum0\/$post0\/$body0\/"

            if {[string length $lnum0]} {
                if {[string index $post0 0] == $tab} {
                    set lwhite $post0
                } else {
                    regsub -all {[0-9]} $pre0$lnum0$post0 { } lwhite
                }

            } else {
                set lwhite $pre0
            }
#            alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"

            # if there's a line number and it's not a CONTINUE,
            # then check for a matching DO statement
            #
            if {[string length $lnum0] && ![regexp $contPat $body0] &&
                ![catch {search -s -f 0 -r 1 -i 1 -l $top $doPat$lnum0 [expr $lst -1]} dolst]} {

                 set doLine0 [eval getText $dolst]
#                alertnote "doLine0: \/$doLine0\/"

            }

            # If the preceeding line begins a block (IF-THEN, DO, or ELSE),
            # then increase the whitespace
            #
            if {[regexp $bobPat $body0]} {
                set lwhite "$lwhite   "
            }
        }

        # if this line ends a block, decrease the whitespace
        #
        if {[regexp $eobPat $body] || $enddo} {
            set lwlen [expr [string length $lwhite] - 4]
            set lwhite [string range $lwhite 0 $lwlen]
        }

        if {[string length $lnum]} {
            if {[string index $lwhite 0] != $tab} {
                set lwhite [string range $lwhite [expr [string length $lnum] +1] end]
            }
            set lnum " $lnum"
        }
#        alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"

        if {[string length $cont]} {
            replaceText $bol $eol "     $cont$lwhite$body"
        } else {
            replaceText $bol $eol $lnum$lwhite$body
        }
    }

    goto [expr $bol + [string length $lnum$lwhite]]
}