/****************************** Module Header ******************************* * * Module Name: pkeys.e * * Copyright (c) Netlabs EPM Distribution Project 2002 * * $Id$ * * =========================================================================== * * This file is part of the Netlabs EPM Distribution package and is free * software. You can redistribute it and/or modify it under the terms of the * GNU General Public License as published by the Free Software * Foundation, in version 2 as it comes in the "COPYING" file of the * Netlabs EPM Distribution. This library is distributed in the hope that it * will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty * of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * General Public License for more details. * ****************************************************************************/ compile if not defined( SMALL) -- If compiled separately EA_comment 'This defines macros for PASCAL syntax expansion.' define INCLUDING_FILE = 'PKEYS.E' include 'stdconst.e' const tryinclude 'mycnf.e' const compile if not defined( NLS_LANGUAGE) NLS_LANGUAGE = 'ENGLISH' compile endif include NLS_LANGUAGE'.e' compile endif ; --------------------------------------------------------------------------- ; Syntax expansion ; --------------------------------------------------------------------------- ; --------------------------------------------------------------------------- defproc PascalCommentEnd( Str) universal comment_end if comment_end then return ' { 'Str' }' else return '' endif ; --------------------------------------------------------------------------- defc PascalFirstExpansion rc = PascalFirstExpansion( arg( 1)) -- (rc = 0) = processed ; This is not executed with a literal. See KEYS.E:"defproc ExpandKey" defproc PascalFirstExpansion universal indent fForce = wordpos( 'FORCE', upcase( arg( 1))) retc = 0 -- 0 = processed, otherwise 1 is returned -- (exchanged compared to standard EPM) do once = 1 to 1 if not .line then retc = 1 leave endif TabWidth = word( .tabs, 1) Case = 0 getline LineStr StripLineStr = StripBlanks( LineStr, 'T') LeftLineStr = leftstr( LineStr, .col - 1) -- Split LineStr into two parts at cursor Wrds = strip( translate( LineStr, ' ', \9)) UpWrds = upcase( Wrds) if Case = 0 then pWrds = pos( UpWrds, upcase( LineStr)) else pWrds = pos( Wrds, LineStr) endif pAfterWrds = pWrds + length( Wrds) Spc = leftstr( LineStr, Max( 0, pWrds - 1)) -- Indent of line with tabs and spaces fChanged = 0 -- Unused, but required for TabExpandStr ExpSpc = TabExpandStr( Spc, TabWidth, fChanged) ExpSpcLen = length( ExpSpc) ; Spc = ExpSpc -- Enable this line if you want to insert spaces only SpcPlus1 = Spc''copies( ' ', indent) -- Skip expansion when cursor is within a comment if InsideComment( GetMode()) then retc = 1 -- Skip expansion when cursor is not at or after line end elseif StripBlanks( LeftLineStr, 'T') <> StripLineStr & not fForce then retc = 1 elseif UpWrds = 'FOR' then END_FOR = PascalCommentEnd( 'end'Wrds) call NextCmdAltersText() SwitchInsertState( '1') .col = pAfterWrds eraseendline keyin ' := to do begin' .col = pAfterWrds + 1 insertline Spc'end;'END_FOR, .line + 1 elseif UpWrds = 'IF' then END_IF = PascalCommentEnd( 'end'Wrds) call NextCmdAltersText() SwitchInsertState( '1') .col = pAfterWrds eraseendline keyin ' then begin' .col = pAfterWrds + 1 insertline Spc'end else begin', .line + 1 insertline Spc'end;'END_IF, .line + 2 elseif UpWrds = 'WHILE' then END_WHILE = PascalCommentEnd( 'end'Wrds) call NextCmdAltersText() SwitchInsertState( '1') .col = pAfterWrds eraseendline keyin ' do begin' .col = pAfterWrds + 1 insertline Spc'end;'END_WHILE, .line + 1 elseif UpWrds = 'REPEAT' then END_REPEAT = PascalCommentEnd( 'end'Wrds) call NextCmdAltersText() .col = pAfterWrds eraseendline SwitchInsertState( '1') insertline SpcPlus1, .line + 1 down endline insertline Spc'until;'END_REPEAT, .line + 1 elseif UpWrds = 'CASE' then END_CASE = PascalCommentEnd( 'end'Wrds) call NextCmdAltersText() SwitchInsertState( '1') .col = pAfterWrds eraseendline keyin ' of' .col = pAfterWrds + 1 insertline Spc'end;'END_CASE, .line + 1 else retc = 1 endif enddo return retc ; --------------------------------------------------------------------------- defc PascalSecondExpansion rc = PascalSecondExpansion( arg( 1)) -- (rc = 0) = processed ; This is not executed with a literal. See KEYS.E:"defproc ExpandKey" defproc PascalSecondExpansion universal indent universal auto_terminate_comment fForce = wordpos( 'FORCE', upcase( arg( 1))) retc = 0 -- 0 = processed, otherwise 1 is returned -- (exchanged compared to standard EPM) do once = 1 to 1 if not .line then retc = 1 leave endif TabWidth = word( .tabs, 1) Case = 0 -- Get current line or previous line until a non-blank line is found CurLineStr = '' do l = .line to 1 by -1 getline LineStr, l if l = .line then -- Save first line CurLineStr = LineStr endif -- Strip trailing blanks StripLineStr = StripBlanks( LineStr, 'T') if StripLineStr <> '' then -- Found leave endif enddo getline LineStr StripLineStr = StripBlanks( LineStr, 'T') Wrds = translate( StripLineStr, ' ', \9) FirstWrd = word( Wrds, 1) UpFirstWrd = upcase( FirstWrd) LastWrd = word( Wrds, Max( 1, words( Wrds))) -- word needs an int > 0 UpLastWrd = upcase( LastWrd) if Case = 0 then pFirstWrd = pos( UpFirstWrd, upcase( StripLineStr)) pLastWrd = pos( UpLastWrd, upcase( StripLineStr)) else pFirstWrd = pos( FirstWrd, StripLineStr) pLastWrd = pos( LastWrd, StripLineStr) endif Spc = leftstr( StripLineStr, Max( 0, pFirstWrd - 1)) -- Indent of line with tabs and spaces ExpSpc = TabExpandStr( Spc, TabWidth, junk) ExpSpcLen = length( ExpSpc) ; Spc = ExpSpc -- Enable this line if you want to insert spaces only SpcPlus1 = Spc''copies( ' ', indent) if pos( '(*', StripLineStr) & auto_terminate_comment then call NextCmdAltersText() if not pos( '*)', StripLineStr) then endline keyin ' *)' endif 'Newline newline' leave elseif pos( '{', StripLineStr) & auto_terminate_comment then call NextCmdAltersText() if not pos( '}', StripLineStr) then endline keyin ' }' endif 'Newline newline' leave endif -- Skip further expansion when cursor is within a comment if InsideComment( GetMode()) then retc = 1 -- Skip expansion when cursor is before the start of first word or in col 1 elseif .col < pFirstWrd | .col = 1 then compile if 1 retc = 1 compile else -- Insert an empty line before insertline '', l compile endif elseif UpFirstWrd = 'FOR' then call NextCmdAltersText() parse value upcase( CurLineStr) with a ':=' if length( a) >= .col then .col = length( a) + 4 else parse value upcase( CurLineStr) with a 'TO' if length( a) >= .col then .col = length( a) + 4 else insertline SpcPlus1, .line + 1 down endline endif endif elseif wordpos( UpLastWrd, 'END; END.') then call NextCmdAltersText() insertline Spc, .line + 1 down endline elseif wordpos( UpFirstWrd, 'BEGIN CASE REPEAT VAR CONST TYPE LABEL PROTECTED PUBLIC INITIALIZATION' || ' IF THEN DO INTERFACE IMPLEMENTATION') | wordpos( UpLastWrd, 'BEGIN RECORD TRY ASM CASE OBJECT CLASS') then call NextCmdAltersText() insertline SpcPlus1, .line + 1 down endline elseif wordpos( UpFirstWrd, 'PROGRAM UNIT') then Name = GetHeadingName( FirstWrd, StripLineStr) END_NAME = PascalCommentEnd( Name) call NextCmdAltersText() insertline SpcPlus1, .line + 1 down endline if UpFirstWrd = 'UNIT' then InterfaceFound = WordWithIndentExists( 'interface', 0, 0) if not InterfaceFound then insertline 'interface', .line + 1 down insertline SpcPlus1, .line + 1 down endline insertline 'implementation', .line + 1 insertline SpcPlus1, .line + 2 endif else BeginFound = WordWithIndentExists( 'begin', 0, 0) if not BeginFound then insertline 'begin', .line + 1 down insertline SpcPlus1, .line + 1 down endline endif endif if GetLastStatement() <> 'end.' then insertline '', .last + 1 insertline 'end.'END_NAME, .last + 1 insertline '', .last + 1 endif elseif wordpos( UpFirstWrd, 'PROCEDURE FUNCTION') then Name = GetHeadingName( FirstWrd, StripLineStr) END_NAME = PascalCommentEnd( Name ) call NextCmdAltersText() insertline 'begin', .line + 1 down insertline SpcPlus1, .line + 1 down endline insertline 'end;'END_NAME, .line + 1 else retc = 1 endif enddo return retc ; --------------------------------------------------------------------------- ; Name of heading defproc GetHeadingName( FirstWrd, StripLineStr) parse value StripLineStr with (FirstWrd) RestLineStr RestLineStr = StripBlanks( RestLineStr) Mode = GetMode() CharSet = QueryModeKey( Mode, 'CharSet') pAfterHeading = verify( RestLineStr, CharSet) if pAfterHeading > 0 then Len = max( 0, pAfterHeading - 1) else Len = length( RestLineStr) endif return leftstr( RestLineStr, Len) ; --------------------------------------------------------------------------- defproc GetLastStatement LastStatement = '' CurMode = GetMode() l = .last do forever getline BottomLineStr, l -- Strip blanks BottomLineStr = StripBlanks( BottomLineStr) if BottomLineStr = '' then -- nop, get next line elseif InsideCommentLiteral( CurMode, l, 1) then -- nop, get next line else -- Found parse value BottomLineStr with LastStatement . leave endif l = l - 1 if l < 1 then leave endif enddo return LastStatement