From 15e0efc7dc8e01b9416def38bc1f18fdabe70256 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 13 Dec 2011 10:33:25 -0500 Subject: [PATCH] * lisp/progmodes/pascal.el: Declare `ind' as dyn-bound. Fixes: debbugs:10264 --- lisp/ChangeLog | 4 + lisp/progmodes/pascal.el | 1 + test/indent/pascal.pas | 1088 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 1093 insertions(+) create mode 100644 test/indent/pascal.pas diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 31533082b77..cc48e86efe3 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2011-12-13 Stefan Monnier + + * progmodes/pascal.el: Declare `ind' as dyn-bound (bug#10264). + 2011-12-13 Martin Rudalics * window.el (delete-other-windows): Use correct frame in call to diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index b1502adbeb1..2db4309d9e0 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -786,6 +786,7 @@ on the line which ends a function or procedure named NAME." (if (looking-at "[ \t]+$") (skip-chars-forward " \t")))) +(defvar ind) ;Used via `eval' in pascal-indent-alist. (defun pascal-indent-line () "Indent current line as a Pascal statement." (let* ((indent-str (pascal-calculate-indent)) diff --git a/test/indent/pascal.pas b/test/indent/pascal.pas new file mode 100644 index 00000000000..07a21f23c3c --- /dev/null +++ b/test/indent/pascal.pas @@ -0,0 +1,1088 @@ +{ GPC demo program for the CRT unit. + +Copyright (C) 1999-2006 Free Software Foundation, Inc. + +Author: Frank Heckenbach + +This program 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, version 2. + +This program 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. + +You should have received a copy of the GNU General Public License +along with this program; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. + +As a special exception, if you incorporate even large parts of the +code of this demo program into another program with substantially +different functionality, this does not cause the other program to +be covered by the GNU General Public License. This exception does +not however invalidate any other reasons why it might be covered +by the GNU General Public License. } + +{$gnu-pascal,I+} + +program CRTDemo; + +uses GPC, CRT; + +type + TFrameChars = array [1 .. 8] of Char; + TSimulateBlockCursorKind = (bc_None, bc_Blink, bc_Static); + +const + SingleFrame: TFrameChars = (chCornerTLS, chLineHS, chCornerTRS, chLineVS, chLineVS, chCornerBLS, chLineHS, chCornerBRS); + DoubleFrame: TFrameChars = (chCornerTLD, chLineHD, chCornerTRD, chLineVD, chLineVD, chCornerBLD, chLineHD, chCornerBRD); + +var + ScrollState: Boolean = True; + SimulateBlockCursorKind: TSimulateBlockCursorKind = bc_None; + CursorShape: TCursorShape = CursorNormal; + MainPanel: TPanel; + OrigScreenSize: TPoint; + +procedure FrameWin (const Title: String; const Frame: TFrameChars; TitleInverse: Boolean); +var + w, h, y, Color: Integer; + Attr: TTextAttr; +begin + HideCursor; + SetPCCharSet (True); + ClrScr; + w := GetXMax; + h := GetYMax; + WriteCharAt (1, 1, 1, Frame[1], TextAttr); + WriteCharAt (2, 1, w - 2, Frame[2], TextAttr); + WriteCharAt (w, 1, 1, Frame[3], TextAttr); + for y := 2 to h - 1 do + begin + WriteCharAt (1, y, 1, Frame[4], TextAttr); + WriteCharAt (w, y, 1, Frame[5], TextAttr) + end; + WriteCharAt (1, h, 1, Frame[6], TextAttr); + WriteCharAt (2, h, w - 2, Frame[7], TextAttr); + WriteCharAt (w, h, 1, Frame[8], TextAttr); + SetPCCharSet (False); + Attr := TextAttr; + if TitleInverse then + begin + Color := GetTextColor; + TextColor (GetTextBackground); + TextBackground (Color) + end; + WriteStrAt ((w - Length (Title)) div 2 + 1, 1, Title, TextAttr); + TextAttr := Attr +end; + +function GetKey (TimeOut: Integer) = Key: TKey; forward; + +procedure ClosePopUpWindow; +begin + PanelDelete (GetActivePanel); + PanelDelete (GetActivePanel) +end; + +function PopUpConfirm (XSize, YSize: Integer; const Msg: String): Boolean; +var + ax, ay: Integer; + Key: TKey; + SSize: TPoint; +begin + repeat + SSize := ScreenSize; + ax := (SSize.x - XSize - 4) div 2 + 1; + ay := (SSize.y - YSize - 4) div 2 + 1; + PanelNew (ax, ay, ax + XSize + 3, ay + YSize + 1, False); + TextBackground (Black); + TextColor (Yellow); + SetControlChars (True); + FrameWin ('', DoubleFrame, False); + NormalCursor; + PanelNew (ax + 2, ay + 1, ax + XSize + 2, ay + YSize, False); + ClrScr; + Write (Msg); + Key := GetKey (-1); + if Key = kbScreenSizeChanged then ClosePopUpWindow + until Key <> kbScreenSizeChanged; + PopUpConfirm := not (Key in [kbEsc, kbAltEsc]) +end; + +procedure MainDraw; +begin + WriteLn ('3, F3 : Open a window'); + WriteLn ('4, F4 : Close window'); + WriteLn ('5, F5 : Previous window'); + WriteLn ('6, F6 : Next window'); + WriteLn ('7, F7 : Move window'); + WriteLn ('8, F8 : Resize window'); + Write ('q, Esc: Quit') +end; + +procedure StatusDraw; +const + YesNo: array [Boolean] of String [3] = ('No', 'Yes'); + SimulateBlockCursorIDs: array [TSimulateBlockCursorKind] of String [8] = ('Off', 'Blinking', 'Static'); + CursorShapeIDs: array [TCursorShape] of String [7] = ('Ignored', 'Hidden', 'Normal', 'Fat', 'Block'); +var + SSize: TPoint; +begin + WriteLn ('You can change some of the following'); + WriteLn ('settings by pressing the key shown'); + WriteLn ('in parentheses. Naturally, color and'); + WriteLn ('changing the cursor shape or screen'); + WriteLn ('size does not work on all terminals.'); + WriteLn; + WriteLn ('XCurses version: ', YesNo[XCRT]); + WriteLn ('CRTSavePreviousScreen: ', YesNo[CRTSavePreviousScreenWorks]); + WriteLn ('(M)onochrome: ', YesNo[IsMonochrome]); + SSize := ScreenSize; + WriteLn ('Screen (C)olumns: ', SSize.x); + WriteLn ('Screen (L)ines: ', SSize.y); + WriteLn ('(R)estore screen size'); + WriteLn ('(B)reak checking: ', YesNo[CheckBreak]); + WriteLn ('(S)crolling: ', YesNo[ScrollState]); + WriteLn ('S(i)mulated block cursor: ', SimulateBlockCursorIDs[SimulateBlockCursorKind]); + Write ('C(u)rsor shape: ', CursorShapeIDs[CursorShape]); + GotoXY (36, WhereY) +end; + +procedure RedrawAll; forward; +procedure CheckScreenSize; forward; + +procedure StatusKey (Key: TKey); +var SSize, NewSize: TPoint; +begin + case LoCase (Key2Char (Key)) of + 'm': begin + SetMonochrome (not IsMonochrome); + RedrawAll + end; + 'c': begin + SSize := ScreenSize; + if SSize.x > 40 then + NewSize.x := 40 + else + NewSize.x := 80; + if SSize.y > 25 then + NewSize.y := 50 + else + NewSize.y := 25; + SetScreenSize (NewSize.x, NewSize.y); + CheckScreenSize + end; + 'l': begin + SSize := ScreenSize; + if SSize.x > 40 then + NewSize.x := 80 + else + NewSize.x := 40; + if SSize.y > 25 then + NewSize.y := 25 + else + NewSize.y := 50; + SetScreenSize (NewSize.x, NewSize.y); + CheckScreenSize + end; + 'r': begin + SetScreenSize (OrigScreenSize.x, OrigScreenSize.y); + CheckScreenSize + end; + 'b': CheckBreak := not CheckBreak; + 's': ScrollState := not ScrollState; + 'i': if SimulateBlockCursorKind = High (SimulateBlockCursorKind) then + SimulateBlockCursorKind := Low (SimulateBlockCursorKind) + else + Inc (SimulateBlockCursorKind); + 'u': case CursorShape of + CursorNormal: CursorShape := CursorBlock; + CursorFat, + CursorBlock : CursorShape := CursorHidden; + else CursorShape := CursorNormal + end; + end; + ClrScr; + StatusDraw +end; + +procedure TextAttrDemo; +var f, b, y, x1, y1, x2, y2, Fill, n1, n2, n3: Integer; +begin + GetWindow (x1, y1, x2, y2); + Window (x1 - 1, y1, x2, y2); + TextColor (White); + TextBackground (Blue); + ClrScr; + SetScroll (False); + Fill := GetXMax - 32; + for y := 1 to GetYMax do + begin + GotoXY (1, y); + b := (y - 1) mod 16; + n1 := 0; + for f := 0 to 15 do + begin + TextAttr := f + 16 * b; + n2 := (Fill * (1 + 2 * f) + 16) div 32; + n3 := (Fill * (2 + 2 * f) + 16) div 32; + Write ('' : n2 - n1, NumericBaseDigitsUpper[b], NumericBaseDigitsUpper[f], '' : n3 - n2); + n1 := n3 + end + end +end; + +procedure CharSetDemo (UsePCCharSet: Boolean); +var h, l, y, x1, y1, x2, y2, Fill, n1, n2: Integer; +begin + GetWindow (x1, y1, x2, y2); + Window (x1 - 1, y1, x2, y2); + ClrScr; + SetScroll (False); + SetPCCharSet (UsePCCharSet); + SetControlChars (False); + Fill := GetXMax - 35; + for y := 1 to GetYMax do + begin + GotoXY (1, y); + h := (y - 2) mod 16; + n1 := (Fill + 9) div 18; + if y = 1 then + Write ('' : 3 + n1) + else + Write (16 * h : 3 + n1); + for l := 0 to 15 do + begin + n2 := (Fill * (2 + l) + 9) div 18; + if y = 1 then + Write ('' : n2 - n1, l : 2) + else + Write ('' : n2 - n1 + 1, Chr (16 * h + l)); + n1 := n2 + end + end +end; + +procedure NormalCharSetDemo; +begin + CharSetDemo (False) +end; + +procedure PCCharSetDemo; +begin + CharSetDemo (True) +end; + +procedure FKeyDemoDraw; +var x1, y1, x2, y2: Integer; +begin + GetWindow (x1, y1, x2, y2); + Window (x1, y1, x2 - 1, y2); + ClrScr; + SetScroll (False); + WriteLn ('You can type the following keys'); + WriteLn ('(function keys if present on the'); + WriteLn ('terminal, letters as alternatives):'); + GotoXY (1, 4); + WriteLn ('S, Left : left (wrap-around)'); + WriteLn ('D, Right : right (wrap-around)'); + WriteLn ('E, Up : up (wrap-around)'); + WriteLn ('X, Down : down (wrap-around)'); + WriteLn ('A, Home : go to first column'); + WriteLn ('F, End : go to last column'); + WriteLn ('R, Page Up : go to first line'); + WriteLn ('C, Page Down: go to last line'); + WriteLn ('Y, Ctrl-PgUp: first column and line'); + GotoXY (1, 13); + WriteLn ('B, Ctrl-PgDn: last column and line'); + WriteLn ('Z, Ctrl-Home: clear screen'); + WriteLn ('N, Ctrl-End : clear to end of line'); + WriteLn ('V, Insert : insert a line'); + WriteLn ('T, Delete : delete a line'); + WriteLn ('# : beep'); + WriteLn ('* : flash'); + WriteLn ('Tab, Enter, Backspace, other'); + WriteLn (' normal characters: write text') +end; + +procedure FKeyDemoKey (Key: TKey); +const TabSize = 8; +var + ch: Char; + NewX: Integer; +begin + case LoCaseKey (Key) of + Ord ('s'), kbLeft : if WhereX = 1 then GotoXY (GetXMax, WhereY) else GotoXY (WhereX - 1, WhereY); + Ord ('d'), kbRight : if WhereX = GetXMax then GotoXY (1, WhereY) else GotoXY (WhereX + 1, WhereY); + Ord ('e'), kbUp : if WhereY = 1 then GotoXY (WhereX, GetYMax) else GotoXY (WhereX, WhereY - 1); + Ord ('x'), kbDown : if WhereY = GetYMax then GotoXY (WhereX, 1) else GotoXY (WhereX, WhereY + 1); + Ord ('a'), kbHome : Write (chCR); + Ord ('f'), kbEnd : GotoXY (GetXMax, WhereY); + Ord ('r'), kbPgUp : GotoXY (WhereX, 1); + Ord ('c'), kbPgDn : GotoXY (WhereX, GetYMax); + Ord ('y'), kbCtrlPgUp: GotoXY (1, 1); + Ord ('b'), kbCtrlPgDn: GotoXY (GetXMax, GetYMax); + Ord ('z'), kbCtrlHome: ClrScr; + Ord ('n'), kbCtrlEnd : ClrEOL; + Ord ('v'), kbIns : InsLine; + Ord ('t'), kbDel : DelLine; + Ord ('#') : Beep; + Ord ('*') : Flash; + kbTab : begin + NewX := ((WhereX - 1) div TabSize + 1) * TabSize + 1; + if NewX <= GetXMax then GotoXY (NewX, WhereY) else WriteLn + end; + kbCR : WriteLn; + kbBkSp : Write (chBkSp, ' ', chBkSp); + else ch := Key2Char (Key); + if ch <> #0 then Write (ch) + end +end; + +procedure KeyDemoDraw; +begin + WriteLn ('Press some keys ...') +end; + +procedure KeyDemoKey (Key: TKey); +var ch: Char; +begin + ch := Key2Char (Key); + if ch <> #0 then + begin + Write ('Normal key'); + if IsPrintable (ch) then Write (' `', ch, ''''); + WriteLn (', ASCII #', Ord (ch)) + end + else + WriteLn ('Special key ', Ord (Key2Scan (Key))) +end; + +procedure IOSelectPeriodical; +var + CurrentTime: TimeStamp; + s: String (8); + i: Integer; +begin + GetTimeStamp (CurrentTime); + with CurrentTime do + WriteStr (s, Hour : 2, ':', Minute : 2, ':', Second : 2); + for i := 1 to Length (s) do + if s[i] = ' ' then s[i] := '0'; + GotoXY (1, 12); + Write ('The time is: ', s) +end; + +procedure IOSelectDraw; +begin + WriteLn ('IOSelect is a way to handle I/O from'); + WriteLn ('or to several places simultaneously,'); + WriteLn ('without having to use threads or'); + WriteLn ('signal/interrupt handlers or waste'); + WriteLn ('CPU time with busy waiting.'); + WriteLn; + WriteLn ('This demo shows how IOSelect works'); + WriteLn ('in connection with CRT. It displays'); + WriteLn ('a clock, but still reacts to user'); + WriteLn ('input immediately.'); + IOSelectPeriodical +end; + +procedure ModifierPeriodical; +const + Pressed: array [Boolean] of String [8] = ('Released', 'Pressed'); + ModifierNames: array [1 .. 7] of record + Modifier: Integer; + Name: String (17) + end = + ((shLeftShift, 'Left Shift'), + (shRightShift, 'Right Shift'), + (shLeftCtrl, 'Left Control'), + (shRightCtrl, 'Right Control'), + (shAlt, 'Alt (left)'), + (shAltGr, 'AltGr (right Alt)'), + (shExtra, 'Extra')); +var + ShiftState, i: Integer; +begin + ShiftState := GetShiftState; + for i := 1 to 7 do + with ModifierNames[i] do + begin + GotoXY (1, 4 + i); + ClrEOL; + Write (Name, ':'); + GotoXY (20, WhereY); + Write (Pressed[(ShiftState and Modifier) <> 0]) + end +end; + +procedure ModifierDraw; +begin + WriteLn ('Modifier keys (NOTE: only'); + WriteLn ('available on some systems;'); + WriteLn ('X11: only after key press):'); + ModifierPeriodical +end; + +procedure ChecksDraw; +begin + WriteLn ('(O)S shell'); + WriteLn ('OS shell with (C)learing'); + WriteLn ('(R)efresh check'); + Write ('(S)ound check') +end; + +procedure ChecksKey (Key: TKey); +var + i, j: Integer; + WasteTime: Real; attribute (volatile); + + procedure DoOSShell; + var + Result: Integer; + Shell: TString; + begin + Shell := GetShellPath (Null); + {$I-} + Result := Execute (Shell); + {$I+} + if (InOutRes <> 0) or (Result <> 0) then + begin + ClrScr; + if InOutRes <> 0 then + WriteLn (GetIOErrorMessage, ' while trying to execute `', Shell, '''.') + else + WriteLn ('`', Shell, ''' returned status ', Result, '.'); + Write ('Any key to continue.'); + BlockCursor; + Discard (GetKey (-1)) + end + end; + +begin + case LoCase (Key2Char (Key)) of + 'o': begin + if PopUpConfirm (36, 12, 'You will now get an OS shell. Unless' + NewLine + + 'CRTDemo is running in its own (GUI)' + NewLine + + 'window, the shell will run on the' + NewLine + + 'same screen as CRTDemo which is not' + NewLine + + 'cleared before the shell is started.' + NewLine + + 'If possible, the screen contents are' + NewLine + + 'restored to the state before CRTDemo' + NewLine + + 'was started. After leaving the shell' + NewLine + + 'in the usual way (usually by enter-' + NewLine + + 'ing `exit''), you will get back to' + NewLine + + 'the demo. to abort, any other' + NewLine + + 'key to start.') then + begin + RestoreTerminal (True); + DoOSShell + end; + ClosePopUpWindow + end; + 'c': begin + if PopUpConfirm (36, 9, 'You will now get an OS shell. Unless' + NewLine + + 'CRTDemo is running in its own (GUI)' + NewLine + + 'window, the screen will be cleared,' + NewLine + + 'and the cursor will be moved to the' + NewLine + + 'top before the shell is started.' + NewLine + + 'After leaving the shell in the usual' + NewLine + + 'way (usually by entering `exit''),' + NewLine + + 'you will get back to the demo. ' + NewLine + + 'to abort, any other key to start.') then + begin + RestoreTerminalClearCRT; + DoOSShell + end; + ClosePopUpWindow + end; + 'r': begin + if PopUpConfirm (36, 11, 'The program will now get busy with' + NewLine + + 'some dummy computations. However,' + NewLine + + 'CRT output in the form of dots will' + NewLine + + 'still appear continuously one by one' + NewLine + + '(rather than the whole line at once' + NewLine + + 'in the end). While running, the test' + NewLine + + 'cannot be interrupted. to' + NewLine + + 'abort, any other key to start.') then + begin + SetCRTUpdate (UpdateRegularly); + BlockCursor; + WriteLn; + WriteLn; + for i := 1 to GetXMax - 2 do + begin + Write ('.'); + for j := 1 to 400000 do WasteTime := Random + end; + SetCRTUpdate (UpdateInput); + WriteLn; + Write ('Press any key.'); + Discard (GetKey (-1)) + end; + ClosePopUpWindow + end; + 's': begin + if PopUpConfirm (32, 4, 'You will now hear some sounds if' + NewLine + + 'supported (otherwise there will' + NewLine + + 'just be a short pause). to' + NewLine + + 'abort, any other key to start.') then + begin + BlockCursor; + for i := 0 to 7 do + begin + Sound (Round (440 * 2 ** (Round (i * 12 / 7 + 0.3) / 12))); + if GetKey (400000) in [kbEsc, kbAltEsc] then Break + end; + NoSound + end; + ClosePopUpWindow + end; + end +end; + +type + PWindowList = ^TWindowList; + TWindowList = record + Next, Prev: PWindowList; + Panel, FramePanel: TPanel; + WindowType: Integer; + x1, y1, xs, ys: Integer; + State: (ws_None, ws_Moving, ws_Resizing); + end; + +TKeyProc = procedure (Key: TKey); +TProcedure = procedure; + +const + MenuNameLength = 16; + WindowTypes: array [0 .. 9] of record + DrawProc, + PeriodicalProc: procedure; + KeyProc : TKeyProc; + Name : String (MenuNameLength); + Color, + Background, + MinSizeX, + MinSizeY, + PrefSizeX, + PrefSizeY : Integer; + RedrawAlways, + WantCursor : Boolean + end = +((MainDraw , nil , nil , 'CRT Demo' , LightGreen, Blue , 26, 7, 0, 0, False, False), + (StatusDraw , nil , StatusKey , 'Status' , White , Red , 38, 16, 0, 0, True, True), + (TextAttrDemo , nil , nil , 'Text Attributes' , White , Blue , 32, 16, 64, 16, False, False), + (NormalCharSetDemo, nil , nil , 'Character Set' , Black , Green , 35, 17, 53, 17, False, False), + (PCCharSetDemo , nil , nil , 'PC Character Set', Black , Brown , 35, 17, 53, 17, False, False), + (KeyDemoDraw , nil , KeyDemoKey , 'Keys' , Blue , LightGray, 29, 5, -1, -1, False, True), + (FKeyDemoDraw , nil , FKeyDemoKey, 'Function Keys' , Blue , LightGray, 37, 22, -1, -1, False, True), + (ModifierDraw , ModifierPeriodical, nil , 'Modifier Keys' , Black , Cyan , 29, 11, 0, 0, True, False), + (IOSelectDraw , IOSelectPeriodical, nil , 'IOSelect Demo' , White , Magenta , 38, 12, 0, 0, False, False), + (ChecksDraw , nil , ChecksKey , 'Various Checks' , Black , Red , 26, 4, 0, 0, False, False)); + +MenuMax = High (WindowTypes); +MenuXSize = MenuNameLength + 4; +MenuYSize = MenuMax + 2; + +var + WindowList: PWindowList = nil; + + procedure RedrawFrame (p: PWindowList); + begin + with p^, WindowTypes[WindowType] do + begin + PanelActivate (FramePanel); + Window (x1, y1, x1 + xs - 1, y1 + ys - 1); + ClrScr; + case State of + ws_None : if p = WindowList then + FrameWin (' ' + Name + ' ', DoubleFrame, True) + else + FrameWin (' ' + Name + ' ', SingleFrame, False); + ws_Moving : FrameWin (' Move Window ', SingleFrame, True); + ws_Resizing: FrameWin (' Resize Window ', SingleFrame, True); + end + end + end; + + procedure DrawWindow (p: PWindowList); + begin + with p^, WindowTypes[WindowType] do + begin + RedrawFrame (p); + PanelActivate (Panel); + Window (x1 + 2, y1 + 1, x1 + xs - 2, y1 + ys - 2); + ClrScr; + DrawProc + end + end; + + procedure RedrawAll; + var + LastPanel: TPanel; + p: PWindowList; + x2, y2: Integer; + begin + LastPanel := GetActivePanel; + PanelActivate (MainPanel); + TextBackground (Blue); + ClrScr; + p := WindowList; + if p <> nil then + repeat + with p^ do + begin + PanelActivate (FramePanel); + GetWindow (x1, y1, x2, y2); { updated automatically by CRT } + xs := x2 - x1 + 1; + ys := y2 - y1 + 1 + end; + DrawWindow (p); + p := p^.Next + until p = WindowList; + PanelActivate (LastPanel) + end; + + procedure CheckScreenSize; + var + LastPanel: TPanel; + MinScreenSizeX, MinScreenSizeY, i: Integer; + SSize: TPoint; + begin + LastPanel := GetActivePanel; + PanelActivate (MainPanel); + HideCursor; + MinScreenSizeX := MenuXSize; + MinScreenSizeY := MenuYSize; + for i := Low (WindowTypes) to High (WindowTypes) do + with WindowTypes[i] do + begin + MinScreenSizeX := Max (MinScreenSizeX, MinSizeX + 2); + MinScreenSizeY := Max (MinScreenSizeY, MinSizeY + 2) + end; + SSize := ScreenSize; + Window (1, 1, SSize.x, SSize.y); + if (SSize.x < MinScreenSizeX) or (SSize.y < MinScreenSizeY) then + begin + NormVideo; + ClrScr; + RestoreTerminal (True); + WriteLn (StdErr, 'Sorry, your screen is too small for this demo (', SSize.x, 'x', SSize.y, ').'); + WriteLn (StdErr, 'You need at least ', MinScreenSizeX, 'x', MinScreenSizeY, ' characters.'); + Halt (2) + end; + PanelActivate (LastPanel); + RedrawAll + end; + + procedure Die; attribute (noreturn); + begin + NoSound; + RestoreTerminalClearCRT; + WriteLn (StdErr, 'You''re trying to kill me. Since I have break checking turned off,'); + WriteLn (StdErr, 'I''m not dying, but I''ll do you a favour and terminate now.'); + Halt (3) + end; + + function GetKey (TimeOut: Integer) = Key: TKey; + var + NeedSelect, SelectValue: Integer; + SimulateBlockCursorCurrent: TSimulateBlockCursorKind; + SelectInput: array [1 .. 1] of PAnyFile = (@Input); + NextSelectTime: MicroSecondTimeType = 0; attribute (static); + TimeOutTime: MicroSecondTimeType; + LastPanel: TPanel; + p: PWindowList; + begin + LastPanel := GetActivePanel; + if TimeOut < 0 then + TimeOutTime := High (TimeOutTime) + else + TimeOutTime := GetMicroSecondTime + TimeOut; + NeedSelect := 0; + if TimeOut >= 0 then + Inc (NeedSelect); + SimulateBlockCursorCurrent := SimulateBlockCursorKind; + if SimulateBlockCursorCurrent <> bc_None then + Inc (NeedSelect); + p := WindowList; + repeat + if @WindowTypes[p^.WindowType].PeriodicalProc <> nil then + Inc (NeedSelect); + p := p^.Next + until p = WindowList; + p := WindowList; + repeat + with p^, WindowTypes[WindowType] do + if RedrawAlways then + begin + PanelActivate (Panel); + ClrScr; + DrawProc + end; + p := p^.Next + until p = WindowList; + if NeedSelect <> 0 then + repeat + CRTUpdate; + SelectValue := IOSelectRead (SelectInput, Max (0, Min (NextSelectTime, TimeOutTime) - GetMicroSecondTime)); + if SelectValue = 0 then + begin + case SimulateBlockCursorCurrent of + bc_None : ; + bc_Blink : SimulateBlockCursor; + bc_Static: begin + SimulateBlockCursor; + SimulateBlockCursorCurrent := bc_None; + Dec (NeedSelect) + end + end; + NextSelectTime := GetMicroSecondTime + 120000; + p := WindowList; + repeat + with p^, WindowTypes[WindowType] do + if @PeriodicalProc <> nil then + begin + PanelActivate (Panel); + PeriodicalProc + end; + p := p^.Next + until p = WindowList + end; + until (NeedSelect = 0) or (SelectValue <> 0) or ((TimeOut >= 0) and (GetMicroSecondTime >= TimeOutTime)); + if NeedSelect = 0 then + SelectValue := 1; + if SelectValue = 0 then + Key := 0 + else + Key := ReadKeyWord; + if SimulateBlockCursorKind <> bc_None then + SimulateBlockCursorOff; + if IsDeadlySignal (Key) then Die; + if Key = kbScreenSizeChanged then CheckScreenSize; + PanelActivate (LastPanel) + end; + + function Menu = n: Integer; + var + i, ax, ay: Integer; + Key: TKey; + Done: Boolean; + SSize: TPoint; + begin + n := 1; + repeat + SSize := ScreenSize; + ax := (SSize.x - MenuXSize) div 2 + 1; + ay := (SSize.y - MenuYSize) div 2 + 1; + PanelNew (ax, ay, ax + MenuXSize - 1, ay + MenuYSize - 1, False); + SetControlChars (True); + TextColor (Blue); + TextBackground (LightGray); + FrameWin (' Select Window ', DoubleFrame, True); + IgnoreCursor; + PanelNew (ax + 1, ay + 1, ax + MenuXSize - 2, ay + MenuYSize - 2, False); + ClrScr; + TextColor (Black); + SetScroll (False); + Done := False; + repeat + for i := 1 to MenuMax do + begin + GotoXY (1, i); + if i = n then + TextBackground (Green) + else + TextBackground (LightGray); + ClrEOL; + Write (' ', WindowTypes[i].Name); + ChangeTextAttr (2, i, 1, Red + $10 * GetTextBackground) + end; + Key := GetKey (-1); + case LoCaseKey (Key) of + kbUp : if n = 1 then n := MenuMax else Dec (n); + kbDown : if n = MenuMax then n := 1 else Inc (n); + kbHome, + kbPgUp, + kbCtrlPgUp, + kbCtrlHome : n := 1; + kbEnd, + kbPgDn, + kbCtrlPgDn, + kbCtrlEnd : n := MenuMax; + kbCR : Done := True; + kbEsc, kbAltEsc : begin + n := -1; + Done := True + end; + Ord ('a') .. Ord ('z'): begin + i := MenuMax; + while (i > 0) and (LoCase (Key2Char (Key)) <> LoCase (WindowTypes[i].Name[1])) do Dec (i); + if i > 0 then + begin + n := i; + Done := True + end + end; + end + until Done or (Key = kbScreenSizeChanged); + ClosePopUpWindow + until Key <> kbScreenSizeChanged + end; + + procedure NewWindow (WindowType, ax, ay: Integer); + var + p, LastWindow: PWindowList; + MaxX1, MaxY1: Integer; + SSize: TPoint; + begin + New (p); + if WindowList = nil then + begin + p^.Prev := p; + p^.Next := p + end + else + begin + p^.Prev := WindowList; + p^.Next := WindowList^.Next; + p^.Prev^.Next := p; + p^.Next^.Prev := p; + end; + p^.WindowType := WindowType; + with p^, WindowTypes[WindowType] do + begin + SSize := ScreenSize; + if PrefSizeX > 0 then xs := PrefSizeX else xs := MinSizeX; + if PrefSizeY > 0 then ys := PrefSizeY else ys := MinSizeY; + xs := Min (xs + 2, SSize.x); + ys := Min (ys + 2, SSize.y); + MaxX1 := SSize.x - xs + 1; + MaxY1 := SSize.y - ys + 1; + if ax = 0 then x1 := Random (MaxX1) + 1 else x1 := Min (ax, MaxX1); + if ay = 0 then y1 := Random (MaxY1) + 1 else y1 := Min (ay, MaxY1); + if (ax = 0) and (PrefSizeX < 0) then Inc (xs, Random (SSize.x - x1 - xs + 2)); + if (ax = 0) and (PrefSizeY < 0) then Inc (ys, Random (SSize.y - y1 - ys + 2)); + State := ws_None; + PanelNew (1, 1, 1, 1, False); + FramePanel := GetActivePanel; + SetControlChars (True); + TextColor (Color); + TextBackground (Background); + PanelNew (1, 1, 1, 1, False); + SetPCCharSet (False); + Panel := GetActivePanel; + end; + LastWindow := WindowList; + WindowList := p; + if LastWindow <> nil then RedrawFrame (LastWindow); + DrawWindow (p) + end; + + procedure OpenWindow; + var WindowType: Integer; + begin + WindowType := Menu; + if WindowType >= 0 then NewWindow (WindowType, 0, 0) + end; + + procedure NextWindow; + var LastWindow: PWindowList; + begin + LastWindow := WindowList; + WindowList := WindowList^.Next; + PanelTop (WindowList^.FramePanel); + PanelTop (WindowList^.Panel); + RedrawFrame (LastWindow); + RedrawFrame (WindowList) + end; + + procedure PreviousWindow; + var LastWindow: PWindowList; + begin + PanelMoveAbove (WindowList^.Panel, MainPanel); + PanelMoveAbove (WindowList^.FramePanel, MainPanel); + LastWindow := WindowList; + WindowList := WindowList^.Prev; + RedrawFrame (LastWindow); + RedrawFrame (WindowList) + end; + + procedure CloseWindow; + var p: PWindowList; + begin + if WindowList^.WindowType <> 0 then + begin + p := WindowList; + NextWindow; + PanelDelete (p^.FramePanel); + PanelDelete (p^.Panel); + p^.Next^.Prev := p^.Prev; + p^.Prev^.Next := p^.Next; + Dispose (p) + end + end; + + procedure MoveWindow; + var + Done, Changed: Boolean; + SSize: TPoint; + begin + with WindowList^ do + begin + Done := False; + Changed := True; + State := ws_Moving; + repeat + if Changed then DrawWindow (WindowList); + Changed := True; + case LoCaseKey (GetKey (-1)) of + Ord ('s'), kbLeft : if x1 > 1 then Dec (x1); + Ord ('d'), kbRight : if x1 + xs - 1 < ScreenSize.x then Inc (x1); + Ord ('e'), kbUp : if y1 > 1 then Dec (y1); + Ord ('x'), kbDown : if y1 + ys - 1 < ScreenSize.y then Inc (y1); + Ord ('a'), kbHome : x1 := 1; + Ord ('f'), kbEnd : x1 := ScreenSize.x - xs + 1; + Ord ('r'), kbPgUp : y1 := 1; + Ord ('c'), kbPgDn : y1 := ScreenSize.y - ys + 1; + Ord ('y'), kbCtrlPgUp: begin + x1 := 1; + y1 := 1 + end; + Ord ('b'), kbCtrlPgDn: begin + SSize := ScreenSize; + x1 := SSize.x - xs + 1; + y1 := SSize.y - ys + 1 + end; + kbCR, + kbEsc, kbAltEsc : Done := True; + else Changed := False + end + until Done; + State := ws_None; + DrawWindow (WindowList) + end + end; + + procedure ResizeWindow; + var + Done, Changed: Boolean; + SSize: TPoint; + begin + with WindowList^, WindowTypes[WindowType] do + begin + Done := False; + Changed := True; + State := ws_Resizing; + repeat + if Changed then DrawWindow (WindowList); + Changed := True; + case LoCaseKey (GetKey (-1)) of + Ord ('s'), kbLeft : if xs > MinSizeX + 2 then Dec (xs); + Ord ('d'), kbRight : if x1 + xs - 1 < ScreenSize.x then Inc (xs); + Ord ('e'), kbUp : if ys > MinSizeY + 2 then Dec (ys); + Ord ('x'), kbDown : if y1 + ys - 1 < ScreenSize.y then Inc (ys); + Ord ('a'), kbHome : xs := MinSizeX + 2; + Ord ('f'), kbEnd : xs := ScreenSize.x - x1 + 1; + Ord ('r'), kbPgUp : ys := MinSizeY + 2; + Ord ('c'), kbPgDn : ys := ScreenSize.y - y1 + 1; + Ord ('y'), kbCtrlPgUp: begin + xs := MinSizeX + 2; + ys := MinSizeY + 2 + end; + Ord ('b'), kbCtrlPgDn: begin + SSize := ScreenSize; + xs := SSize.x - x1 + 1; + ys := SSize.y - y1 + 1 + end; + kbCR, + kbEsc, kbAltEsc : Done := True; + else Changed := False + end + until Done; + State := ws_None; + DrawWindow (WindowList) + end + end; + + procedure ActivateCursor; + begin + with WindowList^, WindowTypes[WindowType] do + begin + PanelActivate (Panel); + if WantCursor then + SetCursorShape (CursorShape) + else + HideCursor + end; + SetScroll (ScrollState) + end; + +var + Key: TKey; + ScreenShot, Done: Boolean; + +begin + ScreenShot := ParamStr (1) = '--screenshot'; + if ParamCount <> Ord (ScreenShot) then + begin + RestoreTerminal (True); + WriteLn (StdErr, ParamStr (0), ': invalid argument `', ParamStr (Ord (ScreenShot) + 1), ''''); + Halt (1) + end; + CRTSavePreviousScreen (True); + SetCRTUpdate (UpdateInput); + MainPanel := GetActivePanel; + CheckScreenSize; + OrigScreenSize := ScreenSize; + if ScreenShot then + begin + CursorShape := CursorBlock; + NewWindow (6, 1, 1); + NewWindow (2, 1, MaxInt); + NewWindow (8, MaxInt, 1); + NewWindow (5, 1, 27); + KeyDemoKey (Ord ('f')); + KeyDemoKey (246); + KeyDemoKey (kbDown); + NewWindow (3, MaxInt, 13); + NewWindow (4, MaxInt, 31); + NewWindow (7, MaxInt, MaxInt); + NewWindow (9, MaxInt, 33); + NewWindow (0, 1, 2); + NewWindow (1, 1, 14); + ActivateCursor; + OpenWindow + end + else + NewWindow (0, 3, 2); + Done := False; + repeat + ActivateCursor; + Key := GetKey (-1); + case LoCaseKey (Key) of + Ord ('3'), kbF3 : OpenWindow; + Ord ('4'), kbF4 : CloseWindow; + Ord ('5'), kbF5 : PreviousWindow; + Ord ('6'), kbF6 : NextWindow; + Ord ('7'), kbF7 : MoveWindow; + Ord ('8'), kbF8 : ResizeWindow; + Ord ('q'), kbEsc, + kbAltEsc: Done := True; + else + if WindowList <> nil then + with WindowList^, WindowTypes[WindowType] do + if @KeyProc <> nil then + begin + TextColor (Color); + TextBackground (Background); + KeyProc (Key) + end + end + until Done +end. -- 2.39.5