From 15e0efc7dc8e01b9416def38bc1f18fdabe70256 Mon Sep 17 00:00:00 2001
From: Stefan Monnier <monnier@iro.umontreal.ca>
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 <monnier@iro.umontreal.ca>
+
+ * progmodes/pascal.el: Declare `ind' as dyn-bound (bug#10264).
+
2011-12-13 Martin Rudalics <rudalics@gmx.at>
* 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 <frank@pascal.gnu.de>
+
+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. <ESC> 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. <ESC>' + 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. <ESC> 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). <ESC> 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