7Syntax10.Scn.FntH}qHistoryElemsNewHistory#Syntax10.Scn.FntYY16: F9 - WhiteOnBlack, F11 - BlackOnWhite, F12 - InitPalette should now work idempotentlyTSyntax10b.Scn.Fnt Syntax10i.Scn.Fnt  D GC#=/s ;.$.   '=  2  ,  O p A")#)?#F{   "   ;+[     # !& XMarkElemsAlloc P  i>8FoldElemsNew8  88 8     ! %"&%$  J'Lc8Syntax8.Scn.Fnt   /8Y8  8)8  8)..8 8H     " &#'&%  8 ]? }      * 9;LU   (Ux yfP3^4  8$Syntax10i.Scn.FntWin95#88$Syntax10i.Scn.FntWinNT with new shell#8= V 8$Syntax10i.Scn.FntWin95#88$Syntax10i.Scn.FntWinNT with new shell#8J}  t  8Sz6'(:)y&*"*MODULE Win32; (* MH Feb 1993 / 7.12..94 *)(* CM 08.09.95 *)(*CS 22.5.96 *) IMPORT Kernel, Modules, S := SYSTEM, C := Console, ShowError, Registry; CONST ML* = 2; MM* = 1; MR* = 0; Bold* = 0; Italics* = 1; kbBufSize = 32; msBufSize = 128; NULL = 0; FF = 0CX; CR = 0DX; LF = 0AX; TYPE ADDRESS = LONGINT; HANDLE = LONGINT; HWND = HANDLE; HDC = HANDLE; LPSZ = ADDRESS; COLORREF* = LONGINT; Pattern* = LONGINT (* = PatternPtr *); PatternPtr* = POINTER TO PatternDesc; PatternDesc* = RECORD x*, y*: LONGINT; (* offset in bitmap *) w*, h*: INTEGER; bitmap*: HANDLE; next: PatternPtr; END ; MetricDesc* = RECORD dx*, x*, y*, filler: INTEGER; p*: PatternDesc; END ; Font* = POINTER TO Bytes; Bytes* = RECORD metrics*: ARRAY 256 OF MetricDesc; hfont*: LONGINT; (* handle to GDI font on screen *) family*: ARRAY 32 OF CHAR; size*: LONGINT; style*: SET; (* Bold, Italics *) oberon*: BOOLEAN; (* TRUE if font uses Oberon character codes *) END ; MouseState = RECORD x, y: INTEGER; keys: SET END ; Point = RECORD x, y: LONGINT END ; Msg = RECORD (* window message record *) window: HWND; message: LONGINT; wParam: LONGINT; lParam: LONGINT; time: LONGINT; point: Point; END ; WindowProc = PROCEDURE (window: HWND; msg: LONGINT; uParam, lParam: LONGINT): LONGINT; TimerProc = PROCEDURE (window: HWND; message, event, time: LONGINT); WindowClass = RECORD style: LONGINT; wndProc: WindowProc; clsExtra, wndExtra: LONGINT; instance: HANDLE; icon: HANDLE; cursor: HANDLE; bgnd: HANDLE; menuName: LPSZ; className: LPSZ; END ; VersionInfo = RECORD size-: LONGINT; major-: LONGINT; (* e.g., 3 or 4 *) minor-: LONGINT; (* e.g., 51 or 0 *) build: LONGINT; platform-: LONGINT; (* 0: Win32s on Windows 3.1; 1: Win32 on Windows 95 2: Win32 on Windows NT *) str-: ARRAY 128 OF CHAR END ; VAR kbNofChars, kbIn, kbOut: INTEGER; kbBuf: ARRAY kbBufSize OF CHAR; msNofEntries, msIn, msOut: INTEGER; msBuf: ARRAY msBufSize OF MouseState; msLastX, msLastY: INTEGER; msLastKeys: SET; emulateMM: BOOLEAN; TimeOut: LONGINT; (* in ms *) T: ARRAY 256 OF CHAR; WinToOberon-: ARRAY 256 OF CHAR; (* ascii code translation Windows -> Oberon *) OberonToWin-: ARRAY 256 OF CHAR; (* ascii code translation Oberon -> Windows *) ApplicationName, Title: ARRAY 32 OF CHAR; hInstance, hPrevInst: HANDLE; nCmdShow: LONGINT; ShowTitlebar: BOOLEAN; mod: LONGINT; BonWCursor, WonBCursor, CurrentCursor: LONGINT; exit: PROCEDURE (code: LONGINT); ShowMsg: PROCEDURE (msg: LONGINT); HideMsg: PROCEDURE; GetTickCount-: PROCEDURE (): LONGINT; SetTimer: PROCEDURE (window: HWND; id: LONGINT; timeout: LONGINT; timerproc: TimerProc): LONGINT; PeekMessage: PROCEDURE (msg: ADDRESS; window: HWND; min, max: LONGINT; flag: LONGINT): LONGINT; WaitMessage-: PROCEDURE; GetInputState-: PROCEDURE(): LONGINT; DispatchMessage: PROCEDURE (msg: ADDRESS); TranslateMessage: PROCEDURE (msg: ADDRESS); LoadCursor: PROCEDURE (appInst: HANDLE; cursRes: LONGINT): HANDLE; SetCursor: PROCEDURE (cur: HANDLE); LoadIcon: PROCEDURE (appInst: HANDLE; iconRes: LONGINT): HANDLE; RegisterClass: PROCEDURE (winClass: LONGINT); CreateWindow: PROCEDURE (exStyle: LONGINT; className, winName: LPSZ; style: LONGINT; x, y, w, h: LONGINT; parent: HWND; menu: HANDLE; inst: HANDLE; param: LONGINT): HWND; ShowWindow: PROCEDURE (wnd: HWND; cmdShow: LONGINT); UpdateWindow: PROCEDURE (wnd: HWND); UpdateColors: PROCEDURE (hdc: LONGINT); GetActiveWindow: PROCEDURE (): HWND; DestroyWindow: PROCEDURE (window: HWND); CloseWindow: PROCEDURE (window: HWND); PostQuitMessage: PROCEDURE (exitCode: LONGINT); GetClientRect: PROCEDURE (hwnd: HWND; pRect: LONGINT); SystemParametersInfo: PROCEDURE (action, iParam, pParam, winini: LONGINT): BOOLEAN; DefWindowProc: WindowProc; CreateSolidBrush-: PROCEDURE (colorref: COLORREF): HANDLE; CreatePatternBrush-: PROCEDURE (bitmap: LONGINT): HANDLE; CreatePen-: PROCEDURE (style, width: LONGINT; color: COLORREF): HANDLE; SelectObject-: PROCEDURE (hdc: HDC; obj: HANDLE): HANDLE; ValidateRect-: PROCEDURE (hWindow: LONGINT; lpRect: LONGINT); CreateRectRgn: PROCEDURE (left, top, right, bottom: LONGINT ): HANDLE; DeleteObject-: PROCEDURE (obj: LONGINT); GetSystemMetrics-: PROCEDURE (index: LONGINT): LONGINT; GetDeviceCaps-: PROCEDURE (hdc, index: LONGINT): LONGINT; GetDC-: PROCEDURE (win: HWND): HDC; CreateCompatibleDC-: PROCEDURE (hdc: HDC): HDC; ReleaseDC-: PROCEDURE (win: HWND; hdc: HDC); DeleteDC-: PROCEDURE (hdc: HDC); CreateBitmap-: PROCEDURE (w, h: LONGINT; planes: LONGINT; bitsPerPixel: LONGINT; bits: ADDRESS): HANDLE; CreateCompatibleBitmap-: PROCEDURE(hdc: LONGINT; w, h: LONGINT): HANDLE; PatBlt-: PROCEDURE (hdc: HDC; x, y, w, h: LONGINT; rop: LONGINT); BitBlt-: PROCEDURE (hdc: HDC; x, y, w, h: LONGINT; hdcSrc: HDC; xSrc, ySrc: LONGINT; rop: LONGINT); ScrollDC-: PROCEDURE (hdc: LONGINT; dx, dy: LONGINT; recScroll, recClip: LONGINT; hrgnUpdate, recUpdate: LONGINT); GetUpdateRect: PROCEDURE (hwnd, lpRect, bErase: LONGINT); ShowCursor-: PROCEDURE (bShow: LONGINT): LONGINT; TextOut-: PROCEDURE (hdc: HDC; xstart, ystart: LONGINT; str: LPSZ; nofchar: LONGINT); SetTextColor-: PROCEDURE (hdc: HDC; colorref: COLORREF); SetTextAlign-: PROCEDURE (hdc: HDC; mode: LONGINT); SetBkMode-: PROCEDURE (hdc: HDC; mode: LONGINT); SetBkColor-: PROCEDURE (hdc: HDC; col: COLORREF); SetBrushOrgEx-: PROCEDURE (hdc: HDC; x, y: LONGINT; lpPrev: LONGINT); GetStockObject-: PROCEDURE (objno: LONGINT): LONGINT; RealizePalette-: PROCEDURE (hdc: HDC): LONGINT; CreatePalette-: PROCEDURE (ptrLogPalette: LONGINT): LONGINT; SetPaletteEntries-: PROCEDURE (hpal: LONGINT; logIndex, nofEntries: LONGINT; ppe: LONGINT): LONGINT; GetPaletteEntries-: PROCEDURE (hpal: LONGINT; logIndex, nofEntries: LONGINT; ppe: LONGINT); SelectPalette-: PROCEDURE (hdc: HDC; hpal: LONGINT; forceBkgnd: LONGINT): HANDLE; UnrealizeObject: PROCEDURE (obj: LONGINT); GdiSetBatchLimit: PROCEDURE (limit: LONGINT): LONGINT; GdiFlush-: PROCEDURE; ScreenToClient-: PROCEDURE (win: HWND; lpPoint: ADDRESS); SetCapture-: PROCEDURE (hwnd: LONGINT); ReleaseCapture-: PROCEDURE; GetKeyState-: PROCEDURE (virtKey: LONGINT): INTEGER; GetVersion: PROCEDURE (): LONGINT; GetVersionEx: PROCEDURE (versionInfo: LONGINT): BOOLEAN; OpenClipboard-: PROCEDURE (window: HANDLE): BOOLEAN; CloseClipboard-: PROCEDURE; EmptyClipboard-: PROCEDURE; SetClipboardData-: PROCEDURE (uFormat, hData :LONGINT): LONGINT; GetClipboardData-: PROCEDURE (uFormat: LONGINT): LONGINT; GlobalAlloc-: PROCEDURE (type, size :LONGINT): HANDLE; GlobalFree-: PROCEDURE (h: HANDLE); GlobalLock-: PROCEDURE (h: HANDLE): LONGINT; GlobalUnlock-: PROCEDURE (h:HANDLE); AnimatePalette: PROCEDURE (hpal, start, nofentries, ppe: LONGINT): BOOLEAN; MessageBeep-: PROCEDURE (type: LONGINT); SetSystemPaletteUse: PROCEDURE (hdc, usage: LONGINT): LONGINT; GetSystemPaletteEntries: PROCEDURE (hdc, iStartIndex, nEntries, lppe: LONGINT): LONGINT; GetLastError-: PROCEDURE (): LONGINT; MessageBox: PROCEDURE (hwnd, text, caption, style: LONGINT): LONGINT; (* ------------------- Display Output ---------------------- *) CONST BLACKNESS = 00000042H; WHITENESS = 00FF0062H; replace* = 0; paint* = 1; invert* = 2; (* modes *) LineCacheSize* = 256; (** Background modes **) transparent* = 1; opaque* = 2; VAR OS-: VersionInfo; DispW-, DispH-: LONGINT; TitlebarHeight: LONGINT; FrameWidth: LONGINT; Display-: LONGINT; (** handle to Oberon window **) hdcDisp-: LONGINT; (** handle to device context for Oberon window **) Black-, White-: COLORREF; Backg-, Foreg-: COLORREF; BackgRop-, ForegRop-: LONGINT; (* ROP-codes for background and foreground *) UpdateDisplay*: PROCEDURE; cc*: RECORD (** character cache **) pat*: Pattern; font*: Font; ch*: CHAR; dx*, x*, y*: INTEGER; END ; lc*: RECORD (** line cache **) len-: INTEGER; cache: ARRAY LineCacheSize OF CHAR; font: Font; x0, y0, x, col, mode: INTEGER; END ; dc*: RECORD (** device context cache **) hfont*: LONGINT; textCol*: COLORREF; brushCol*: COLORREF; (** color of solid brush, or -1 *) bkCol*: COLORREF; bkMode*: INTEGER; (** transparent, opaque **) penCol*: COLORREF; (** color of solid pen, width 0 **) pat*: PatternPtr; (** pattern of pattern brush, or NIL **) x*, y*, w*, h*: LONGINT; (** cached clipping rectangle in Oberon Display coordinates **) END ; PatternList: PatternPtr; (* list of all created paterns; prevents them from beeing collected *) (* ------ color support -------- *) CONST MaxPaletteSize = 256; PCExplicit = 2X; PCNocollapse = 4X; PCReserved = 1X; (* flags in PaletteEntry *) TYPE PaletteEntry = RECORD; red, green, blue: CHAR; (* 0 .. 0FFH *) flags: CHAR END ; Palette = RECORD version: INTEGER; size: INTEGER; col: ARRAY MaxPaletteSize OF PaletteEntry END ; VAR Pal: Palette; hPalette-: LONGINT; (** handle to logical palette **) Depth-: LONGINT; (** screen depth **) NumColors-: LONGINT; PaletteAvailable-: BOOLEAN; (* ------ printer support -------- *) TYPE PRINTDLG* = RECORD size*: LONGINT; (* set to 66! *) hwndOwner*: LONGINT; hDevMode*: LONGINT; hDevNames*: LONGINT; hdc*: LONGINT; flags*: SET; fromPage*, toPage*: INTEGER; minPage*, maxPage*: INTEGER; nofCopies*: INTEGER; hInstance: LONGINT; (* << caution: improper alignment from here to end ! *) custData: LONGINT; printHook, setupHook: LONGINT; printTemplateName, setupTemplateName: LONGINT; printTemplate, setupTemplate: LONGINT; END ; VAR PD*: PRINTDLG; PageH*, PageW*: LONGINT; (* in printer pixels *) Unit*: LONGINT; (* printer resolution in 1/36000 mm per pixel *) PrintDlg-: PROCEDURE (lppd: LONGINT): BOOLEAN; (* trap handling, CS, 22.5.96 *) TYPE ExceptionRecord* = RECORD code*: LONGINT; flags*: LONGINT; excRec*: LONGINT; addr*: LONGINT; END ; ContextRecord* = RECORD flags*: LONGINT; debRegs*: ARRAY 6 OF LONGINT; floatSaveArea*: ARRAY 112 OF CHAR; SegGs*, SegFs*, SegEs*, SegDs*: LONGINT; Edi*, Esi*, Ebx*, Edx*, Ecx*, Eax*: LONGINT; Ebp*, Eip*, SegCs*, EFlags*, Esp*, SegSs*: LONGINT; END ; ExceptionInfo* = POINTER TO ExceptionPointers; ExceptionPointers* = RECORD exc*: POINTER TO ExceptionRecord; cont*: POINTER TO ContextRecord; END ; TrapHandler* = PROCEDURE (p: ExceptionInfo): LONGINT; (* ------ pattern ---------- *) PROCEDURE PatternTermHandler; VAR p: PatternPtr; BEGIN p := PatternList; WHILE p # NIL DO IF p.bitmap # NULL THEN DeleteObject(p.bitmap) END ; p := p.next; END END PatternTermHandler; PROCEDURE InitTranslations; VAR i, k, bit, val: INTEGER; BEGIN i := 0; WHILE i < 256 DO k := i; bit := 0; val := 0; WHILE bit < 8 DO val := val * 2; IF ODD(k) THEN INC(val) END ; k := k DIV 2; INC(bit); END ; T[i] := CHR(val); INC(i); END ; (* ascii code translation *) i := 0; WHILE i < 256 DO WinToOberon[i] := CHR(i); OberonToWin[i] := CHR(i); INC(i) END ; WinToOberon[8] := CHR(127); WinToOberon[196] := CHR(128); OberonToWin[128] := CHR(196); WinToOberon[214] := CHR(129); OberonToWin[129] := CHR(214); WinToOberon[220] := CHR(130); OberonToWin[130] := CHR(220); WinToOberon[228] := CHR(131); OberonToWin[131] := CHR(228); WinToOberon[246] := CHR(132); OberonToWin[132] := CHR(246); WinToOberon[252] := CHR(133); OberonToWin[133] := CHR(252); WinToOberon[226] := CHR(134); OberonToWin[134] := CHR(226); WinToOberon[234] := CHR(135); OberonToWin[135] := CHR(234); WinToOberon[238] := CHR(136); OberonToWin[136] := CHR(238); WinToOberon[244] := CHR(137); OberonToWin[137] := CHR(244); WinToOberon[251] := CHR(138); OberonToWin[138] := CHR(251); WinToOberon[224] := CHR(139); OberonToWin[139] := CHR(224); WinToOberon[232] := CHR(140); OberonToWin[140] := CHR(232); WinToOberon[236] := CHR(141); OberonToWin[141] := CHR(236); WinToOberon[242] := CHR(142); OberonToWin[142] := CHR(242); WinToOberon[249] := CHR(143); OberonToWin[143] := CHR(249); WinToOberon[233] := CHR(144); OberonToWin[144] := CHR(233); WinToOberon[235] := CHR(145); OberonToWin[145] := CHR(235); WinToOberon[239] := CHR(146); OberonToWin[146] := CHR(239); WinToOberon[231] := CHR(147); OberonToWin[147] := CHR(231); WinToOberon[225] := CHR(148); OberonToWin[148] := CHR(225); WinToOberon[241] := CHR(149); OberonToWin[149] := CHR(241); END InitTranslations; PROCEDURE RotateBytes (VAR b: ARRAY OF S.BYTE); VAR i: LONGINT; BEGIN FOR i := 0 TO LEN(b)-1 DO b[i] := T[ORD(S.VAL(CHAR, b[i]))] END ; END RotateBytes; PROCEDURE NewPattern* ((*VAR*) image: ARRAY OF SET; w, h: INTEGER; VAR pat: Pattern); VAR p: PatternPtr; temp: SET; i, n, p1, p2: LONGINT; wdw: LONGINT; (* width in double words *) BEGIN NEW(p); p.x := 0; p.y := 0; p.w := w; p.h := h; wdw := (w+31) DIV 32; (* turn scanlines upside down *) i := 0; WHILE i < h DIV 2 DO (* swap scanlines i and h-i-1*) p1 := i * wdw + 1; p2 := (h-i-1)* wdw + 1; n := 0; WHILE n < wdw DO temp := image[p1]; image[p1] := image[p2]; image[p2] := temp; INC(p1); INC(p2); INC(n) END ; INC(i) END ; RotateBytes(image); p.bitmap := CreateBitmap(wdw * 32, h, 1, 1, S.ADR(image)+SIZE(SET)); p.next := PatternList; PatternList := p; pat := S.VAL(Pattern, p); END NewPattern; (* ------ color support -------- *) PROCEDURE Match* (red, green, blue: INTEGER; VAR col, r, g, b: INTEGER); (** if ~PaletteAvailable, col = -1, r, g, b receive the values of red, green and blue, otherwise col is the index in the Oberon palette that resembles best the red/green/blue color triple *)  VAR err, err2: LONGINT; i, max, minIdx: INTEGER; PROCEDURE Map (x: INTEGER; VAR y: INTEGER): INTEGER; VAR tmp: INTEGER; BEGIN y := x - 21; IF y MOD 42 <= 21 THEN y := 21 + y DIV 42 * 42 ELSE y := 21 + (y DIV 42 + 1) * 42 END ; RETURN (y - 21) DIV 42 END Map; PROCEDURE Trim (VAR x: INTEGER); BEGIN IF x < 21 THEN x := 21 ELSIF x > 231 THEN x := 231 END END Trim; BEGIN IF PaletteAvailable THEN i := 0; WHILE i <= 15 DO IF (red = ORD(Pal.col[i].red)) & (green = ORD(Pal.col[i].green)) & (blue = ORD(Pal.col[i].blue)) THEN col := i; r := ORD(Pal.col[i].red); g := ORD(Pal.col[i].green); b := ORD(Pal.col[i].blue); RETURN END ; INC(i) END ; Trim(red); Trim(green); Trim(blue); col := 20 + Map(red, r) * 36 + Map(green, g) * 6 + Map(blue, b) ELSE col := -1; r := red; g := green; b := blue END END Match;  PROCEDURE ColorRef* (index: LONGINT): COLORREF;  BEGIN IF PaletteAvailable THEN RETURN S.VAL(COLORREF, S.VAL(SET, index) + S.VAL(SET, 01000000H)) ELSE RETURN S.VAL(COLORREF, Pal.col[index]) END END ColorRef;  PROCEDURE SetColor(i, red, green, blue: INTEGER; mode: CHAR); BEGIN Pal.col[i].red := CHR(red); Pal.col[i].green := CHR(green); Pal.col[i].blue := CHR(blue); Pal.col[i].flags := mode END SetColor; PROCEDURE InitPalette;  VAR i, j: INTEGER; res: LONGINT; used: ARRAY 256 OF BOOLEAN; s: ARRAY 64 OF CHAR; flag: CHAR; col, r, g, b: INTEGER; BEGIN Pal.version := 0300H; IF NumColors > 256 THEN Pal.size := 256 ELSE Pal.size := SHORT(NumColors) END ; SetColor(0, 0FFH, 0FFH, 0FFH, 0X); (* white *) SetColor(1, 255, 0, 0, 0X); (* red *) SetColor(2, 0, 255, 0, 0X); (* green *) SetColor(3, 0, 0, 255, 0X); (* blue*) SetColor(4, 255, 0, 255, 0X); (* magenta *) SetColor(5, 255, 255, 0, 0X); (* yellow *) SetColor(6, 0, 255, 255, 0X); (*cyan *) SetColor(7, 128, 0, 0, 0X); (* dark red *) SetColor(8, 0, 128, 0, 0X); (* dark green *) SetColor(9, 0, 0, 128, 0X); (* dark blue *) SetColor(10, 0A6H, 0CAH, 0F0H, 0X); (* sky blue *) SetColor(11, 0, 080H, 080H, 0X); (* dark cyan *) SetColor(12, 0C0H, 0C0H, 0C0H, 0X); (* light grey *) SetColor(13, 0A0H, 0A0H, 0A4H, 0X); (* medium grey *) SetColor(14, 080H, 080H, 080H, 0X); (* dark grey *) SetColor(15, 0, 0, 0, 0X); (* black *) col := 20; FOR r := 0 TO 5 DO FOR g := 0 TO 5 DO FOR b := 0 TO 5 DO SetColor(col, r * 42 + 21, g * 42 + 21, b * 42 + 21, 0X); INC(col) END END END ; SetColor(20, 0, 0, 0, 0X); (* black, second time, to avoid that black becomes grey after dithering *) SetColor(235, 0FFH, 0FFH, 0FFH, 0X); (* white, second time, to avoid that white becomes grey after dithering *) (* i.e. SetColor(20, 21, 21, 21); SetColor(21, 21, 21, 63); SetColor(22, 21, 21, 105) ... SetColor(26, 21, 63, 21); SetColor(27, 21, 63, 63); SetColor(28, 63, 105) ... SetColor(32, 21, 105, 21); SetColor(33, 21, 105, 63); SetColor(34, 21, 105, 105) ... ... SetColor(230, 231, 231, 21); SetColor(231, 231, 231, 63); SetColor(232, 231, 231, 105) ... *) FOR col := 16 TO 19 DO SetColor(r, col, col, col, 0X) END ; FOR col := 236 TO 247 DO SetColor(r, col, col, col, 0X) END ; Black := ColorRef(15); White := ColorRef(0); Backg := ColorRef(0); Foreg := ColorRef(15); BackgRop := WHITENESS; ForegRop := BLACKNESS; IF PaletteAvailable THEN hPalette := CreatePalette(S.ADR(Pal)) END END InitPalette;  PROCEDURE ^ PutChar(ch: CHAR); PROCEDURE UpdatePalette* (index: LONGINT; red, green, blue: INTEGER);  VAR p: PaletteEntry; n: LONGINT; BEGIN IF (index >= NumColors) OR (index >= 256) THEN RETURN END ; Pal.col[index].red := CHR(red); Pal.col[index].green := CHR(green); Pal.col[index].blue := CHR(blue); Pal.col[index].flags := PCReserved; IF PaletteAvailable THEN n := SetPaletteEntries(hPalette, index, 1, S.ADR(Pal.col[index])); IF n = 0 THEN C.Str("SetPaletteEntries error: "); C.Int(GetLastError()); END ; n := SelectPalette(hdcDisp, hPalette, 0 (*FALSE*)); n := RealizePalette(hdcDisp) END END UpdatePalette;  PROCEDURE BlackOnWhite*;  VAR n: LONGINT; p: PaletteEntry; BEGIN (* formerly UpdatePalette(0, 0FFH, 0FFH, 0FFH); UpdatePalette(15, 0, 0, 0); *) SetColor(0, 255, 255, 255, 0X); SetColor(15, 0, 0, 0, 0X); Black := ColorRef(15); White := ColorRef(0); Backg := ColorRef(0); Foreg := ColorRef(15); BackgRop := WHITENESS; ForegRop := BLACKNESS; dc.textCol := -1; dc.brushCol := -1; dc.bkCol := -1; dc.pat := NIL; dc.penCol := -1; (* invalidate dev context cache *) IF PaletteAvailable THEN n := SelectPalette(hdcDisp, hPalette, 0 (*FALSE*)); n := RealizePalette(hdcDisp) END ; PutChar(FF); CurrentCursor := BonWCursor; END BlackOnWhite;  PROCEDURE WhiteOnBlack*;  VAR n: LONGINT; p: PaletteEntry; BEGIN (* formerly UpdatePalette(15, 0FFH, 0FFH, 0FFH); UpdatePalette(0, 0, 0, 0); *) SetColor(15, 255, 255, 255, 0X); SetColor(0, 0, 0, 0, 0X); Black := ColorRef(0); White := ColorRef(15); Backg := ColorRef(15); Foreg := ColorRef(0); BackgRop := BLACKNESS; ForegRop := WHITENESS; dc.textCol := -1; dc.brushCol := -1; dc.bkCol := -1; dc.pat := NIL; dc.penCol := -1; (* invalidate dev context cache *) IF PaletteAvailable THEN n := SelectPalette(hdcDisp, hPalette, 0 (*FALSE*)); n := RealizePalette(hdcDisp) END ; PutChar(FF); CurrentCursor := WonBCursor; END WhiteOnBlack;  (* formerly PROCEDURE InitColors;  VAR r, g, b, col: INTEGER; BEGIN UpdatePalette(0, 0FFH, 0FFH, 0FFH); (* white *) UpdatePalette(1, 255, 0, 0); (* red *) UpdatePalette(2, 0, 255, 0); (* green *) UpdatePalette(3, 0, 0, 255); (* blue*) UpdatePalette(4, 255, 0, 255); (* magenta *) UpdatePalette(5, 255, 255, 0); (* yellow *) UpdatePalette(6, 0, 255, 255); (*cyan *) UpdatePalette(7, 128, 0, 0); (* dark red *) UpdatePalette(8, 0, 128, 0); (* dark green *) UpdatePalette(9, 0, 0, 128); (* dark blue *) UpdatePalette(10, 0A6H, 0CAH, 0F0H); (* sky blue *) UpdatePalette(11, 0, 080H, 080H); (* dark cyan *) UpdatePalette(12, 0C0H, 0C0H, 0C0H); (* light grey *) UpdatePalette(13, 0A0H, 0A0H, 0A4H); (* medium grey *) UpdatePalette(14, 080H, 080H, 080H); (* dark grey *) UpdatePalette(15, 0, 0, 0); (* black *) col := 20; FOR r := 0 TO 5 DO FOR g := 0 TO 5 DO FOR b := 0 TO 5 DO UpdatePalette(col, r * 42 + 21, g * 42 + 21, b * 42 + 21); INC(col) END END END ; (* i.e. UpdatePalette(20, 21, 21, 21); UpdatePalette(21, 21, 21, 63) ... UpdatePalette(26, 21, 63, 21); UpdatePalette(27, 21, 63, 63) ... UpdatePalette(32, 21, 105, 21); UpdatePalette(33, 21, 105, 63) ... ... UpdatePalette(230, 231, 231, 21); UpdatePalette(231, 231, 231, 63) ... *) FOR col := 16 TO 19 DO UpdatePalette(r, col, col, col) END ; FOR col := 236 TO 247 DO UpdatePalette(r, col, col, col) END ; END InitColors;  *) PROCEDURE GetColor* (col: INTEGER; VAR red, green, blue: INTEGER); VAR p: PaletteEntry; BEGIN IF PaletteAvailable THEN GetPaletteEntries(hPalette, col, 1, S.ADR(p)); red := ORD(p.red); green := ORD(p.green); blue := ORD(p.blue) ELSE red := ORD(Pal.col[col].red); green := ORD(Pal.col[col].green); blue := ORD(Pal.col[col].blue) END END GetColor; PROCEDURE DeletePaletteAndDC; (* installed as termination handler *) BEGIN hPalette := SelectPalette(hdcDisp, GetStockObject(15 (*DEFAULT_PALETTE*)), 0); DeleteObject(hPalette); hPalette := NULL; ReleaseDC(Display, hdcDisp); END DeletePaletteAndDC; (* --------------- device context cacheing ------------------ *) PROCEDURE InitDeviceContext; CONST TABaseline = 24; TALeft = 0; VAR br: HANDLE; n: LONGINT; planes: LONGINT; BEGIN PaletteAvailable := ODD(GetDeviceCaps(hdcDisp, 38 (*RASTERCAPS*)) DIV 100H (*RC_PALETTE*)); C.Ln; IF PaletteAvailable THEN C.Str("Palette available") ELSE C.Str("Palette not available") END ; (* PaletteAvailable := TRUE; (* otherwise it does not work properly !? *) *) Depth := GetDeviceCaps(hdcDisp, 12 (*BITSPIXEL*)); planes := GetDeviceCaps(hdcDisp, 14 (*PLANES*)); NumColors := ASH(1, Depth * planes); InitPalette; IF hPalette # NULL THEN n := SelectPalette(hdcDisp, hPalette, 0 (*FALSE*)); n := RealizePalette(hdcDisp) END ; SetTextAlign(hdcDisp, TABaseline + TALeft); dc.hfont := NULL; SetTextColor(hdcDisp, Foreg); dc.textCol := Foreg; SetBkColor(hdcDisp, Backg); dc.bkCol := Backg; SetBkMode(hdcDisp, opaque); dc.bkMode := opaque; br := SelectObject(hdcDisp, CreateSolidBrush(Backg)); DeleteObject(br); dc.brushCol := Backg; dc.penCol := -1 END InitDeviceContext; PROCEDURE SetBackgCol* (col: COLORREF); BEGIN IF dc.bkCol # col THEN SetBkColor(hdcDisp, col); dc.bkCol := col END ; END SetBackgCol; PROCEDURE SetTextCol* (col: COLORREF); BEGIN IF dc.textCol # col THEN SetTextColor(hdcDisp, col); dc.textCol := col END ; END SetTextCol; PROCEDURE SetBrushColor* (col: COLORREF); VAR br: HANDLE; BEGIN IF dc.brushCol # col THEN br := SelectObject(hdcDisp, CreateSolidBrush(col)); DeleteObject(br); dc.brushCol := col; dc.pat := NIL END ; END SetBrushColor; PROCEDURE SetPenColor* (col: COLORREF); VAR pen: HANDLE; BEGIN IF dc.penCol # col THEN pen := SelectObject(hdcDisp, CreatePen(0 (*solid pen*), 0 (*width 1 pixel*), col)); DeleteObject(pen); dc.penCol := col; END ; END SetPenColor; PROCEDURE SetPatternBrush* (pat: PatternPtr); VAR br: HANDLE; BEGIN IF dc.pat # pat THEN br := SelectObject(hdcDisp, CreatePatternBrush(pat.bitmap)); DeleteObject(br); dc.pat := pat; dc.brushCol := -1; END END SetPatternBrush; PROCEDURE ^ FlushCache*; PROCEDURE SetClippingArea* (x, y, w, h: LONGINT); (** flushes line cache if area changes **) VAR rgn: HANDLE; res: LONGINT; BEGIN IF (dc.x # x) OR (dc.y # y) OR (dc.w # w) OR (dc.h # h) THEN IF lc.len > 0 THEN FlushCache END ; IF w < 0 THEN w := 0 END ; IF h < 0 THEN h := 0 END ; rgn := CreateRectRgn(x, DispH-y, x+w, DispH-(y+h)); res := SelectObject(hdcDisp, rgn); DeleteObject(rgn); dc.x := x; dc.y := y; dc.w := w; dc.h := h; END ; END SetClippingArea; (* -------------- line cache -------------- *) PROCEDURE FlushCache*; VAR colref: LONGINT; dmmy: HANDLE; BEGIN colref := ColorRef(lc.col); IF dc.hfont # lc.font.hfont THEN dmmy := SelectObject(hdcDisp, lc.font.hfont); dc.hfont := lc.font.hfont; END ; IF dc.textCol # colref THEN SetTextColor(hdcDisp, colref); dc.textCol := colref END ; CASE lc.mode OF | paint, replace: (* replace = paint *) IF dc.bkMode # transparent THEN SetBkMode(hdcDisp, transparent); dc.bkMode := transparent END ; TextOut(hdcDisp, lc.x0, DispH-lc.y0, S.ADR(lc.cache), lc.len); ELSE (* invert not implemented *) END ; lc.len := 0; GdiFlush; END FlushCache; PROCEDURE CacheCharacter* (x, y: INTEGER; col: INTEGER; mode: INTEGER); BEGIN IF cc.dx > 0 THEN (* Windows replaces charcters with dx=0 with a default character => inconsistent display *) IF lc.len = 0 THEN lc.cache[0] := cc.ch; lc.len := 1; lc.font := cc.font; lc.col := col; lc.mode := mode; lc.x0 := x - cc.x; lc.y0 := y - cc.y; lc.x := lc.x0 + cc.dx; ELSIF (lc.font # cc.font) OR ((x - cc.x) # lc.x) OR ((y - cc.y) # lc.y0) OR (col # lc.col) OR (mode # lc.mode) OR (lc.len = LineCacheSize) THEN IF lc.len > 0 THEN FlushCache END ; lc.cache[0] := cc.ch; lc.len := 1; lc.font := cc.font; lc.col := col; lc.mode := mode; lc.x0 := x - cc.x; lc.y0 := y - cc.y; lc.x := lc.x0 + cc.dx; ELSE (* append *) lc.cache[lc.len] := cc.ch; INC(lc.len); INC(lc.x, cc.dx) END END END CacheCharacter; (* -------------- raster operatons ------------------ *) PROCEDURE GetClientSize* (VAR w, h: LONGINT); TYPE Rect = RECORD left, top, right, bottom: LONGINT END ; VAR R: Rect; BEGIN GetClientRect(Display, S.ADR(R)); w := R.right - R.left; h := R.bottom - R.top; END GetClientSize; PROCEDURE SyncDisplay*; (** flushes line cache and GDI queue **) BEGIN IF lc.len > 0 THEN FlushCache END ; GdiFlush; END SyncDisplay; PROCEDURE ^ PutChar (ch: CHAR); PROCEDURE RefreshDisplay*; BEGIN PutChar(FF) END RefreshDisplay; (* ------------------ Keyboard Input ----------------------- *) PROCEDURE ^ PollEventQueue; PROCEDURE Available* (): INTEGER; BEGIN SyncDisplay; (*WaitMessage;*) (*IF GetInputState() # 0 THEN*) PollEventQueue (*END*) ; RETURN kbNofChars END Available; PROCEDURE PutChar (ch: CHAR); BEGIN IF (kbNofChars < kbBufSize) THEN kbBuf[kbIn] := ch; kbIn := (kbIn+1) MOD kbBufSize; INC(kbNofChars) END ; END PutChar; PROCEDURE GetChar* (VAR ch: CHAR); BEGIN SyncDisplay; (*WaitMessage;*) WHILE kbNofChars <= 0 DO PollEventQueue END ; DEC(kbNofChars); ch := kbBuf[kbOut]; kbOut := (kbOut+1) MOD kbBufSize; END GetChar; (* --------------------- Mouse Input ---------------------- *) PROCEDURE Mouse* (VAR keys: SET; VAR x, y: INTEGER); BEGIN SyncDisplay; PollEventQueue; IF msNofEntries <= 0 THEN keys := msLastKeys; x := msLastX; y := msLastY; ELSE keys := msBuf[msOut].keys; x := msBuf[msOut].x; y := msBuf[msOut].y; msOut := (msOut + 1) MOD msBufSize; DEC(msNofEntries); END ; END Mouse; (* ------------------ Window Procedure -------------------- *) PROCEDURE keyDown (virtCode: LONGINT): BOOLEAN; BEGIN RETURN GetKeyState(virtCode) < 0; END keyDown; PROCEDURE LOWORD (x: LONGINT): LONGINT; BEGIN RETURN x MOD 10000H; END LOWORD; PROCEDURE HIWORD (x: LONGINT): LONGINT; BEGIN x := S.LSH(x, -16); RETURN S.VAL(LONGINT, S.VAL(SET, x) * S.VAL(SET, 0FFFFH)); END HIWORD; PROCEDURE PollEventQueue; CONST PMRemove = 1; VKShift = 10H; (* virtual key codes *) WMKeyDown = 100H; WMKeyUp = 101H; WMSysKeyDown = 104H; VAR res: LONGINT; msg: Msg; pt: Point; BEGIN res := PeekMessage(S.ADR(msg), NULL, 0, 0, PMRemove); WHILE res # 0 DO IF (msg.message = WMKeyDown) OR (msg.message = WMKeyUp) THEN IF emulateMM & (msg.wParam = 11H) THEN (* CTRL = MM *) IF (msg.message = 100H) & (MM IN msLastKeys) THEN (* ignore repetition of CTRL *) ELSE IF msg.message = 100H THEN IF msLastKeys = {} THEN SetCapture(Display) END ; INCL(msLastKeys, MM) ELSE EXCL(msLastKeys, MM); IF msLastKeys = {} THEN ReleaseCapture END ; END ; pt := msg.point; ScreenToClient(Display, S.ADR(pt)); msLastX := SHORT(pt.x); msLastY := SHORT(DispH - pt.y); IF msNofEntries < msBufSize THEN msBuf[msIn].keys := msLastKeys; msBuf[msIn].x := msLastX; msBuf[msIn].y := msLastY; msIn := (msIn + 1) MOD msBufSize; INC(msNofEntries) END END ELSIF msg.message = WMKeyDown THEN IF emulateMM & keyDown(11H) (*CTRL*) THEN (* CTRL key pressed in combination with some other key: insert virtual events to nullify MM *) IF (msLastKeys # {}) & (msNofEntries < msBufSize-2) THEN pt := msg.point; ScreenToClient(Display, S.ADR(pt)); msLastX := SHORT(pt.x); msLastY := SHORT(DispH - pt.y); msLastKeys := {ML, MM, MR}; msBuf[msIn].keys := {ML, MM, MR}; msBuf[msIn].x := msLastX; msBuf[msIn].y := msLastY; msIn := (msIn + 1) MOD msBufSize; INC(msNofEntries); msLastKeys := {}; msBuf[msIn].keys := {}; msBuf[msIn].x := msLastX; msBuf[msIn].y := msLastY; msIn := (msIn + 1) MOD msBufSize; INC(msNofEntries); END ; END ; CASE msg.wParam OF | 13H: (*PAUSE*) IF keyDown(10H (*SHIFT*)) THEN PutChar(0ADX) (*SHIFT-BREAK*) ELSE PutChar(0ACX) (*BREAK*) END ; | 70H: (*F1*) PutChar(0A4X) (*SETUP*) | 78H: (*F9*) WhiteOnBlack (*PF1*) | 79H: (*F10*) CloseWindow(Display) (*PutChar(0F2X)*) (*PF2*) | 7AH: (*F11*) BlackOnWhite (*PF3*) | 7BH: (*F12*) InitPalette (* formerly InitColors *) (*| 08H: (*BACKSPACE*) PutChar(07FX) (*DEL*)*) | 21H: (* PAGE UP *) PutChar(0C5X) (* CM 08.09.95 *) | 22H: (* PAGE DOWN *) PutChar(0C6X) (* CM 08.09.95 *) | 23H: (* EOL *) PutChar(0C7X) (* CM 08.09.95 *) | 24H: (* HOME *) PutChar(0C8X) (* CM 08.09.95 *) | 25H: (*LEFT ARROW*) PutChar(0C4X) | 26H: (*UP ARROW*) PutChar(0C1X) | 27H: (*RIGHT ARROW*) PutChar(0C3X) | 28H: (*DOWN ARROW*) PutChar(0C2X) (* | 24H: (*HOME*) PutChar(FF); (*redraw screen*) *) (* CM 08.09.95 *) | 2DH: (*INSERT*) PutChar(0A0X); | 2EH: (*DELETE*) PutChar(0A1X); | 71H: (*F2*) IF keyDown(11H) THEN PutChar(93X) (*CTRL NO SCRL*) ELSE PutChar(091X) END ; (*NO SCRL*) | 41H: IF keyDown(11H) THEN (* , *) IF keyDown(VKShift) THEN PutChar(CHR(128)) ELSE PutChar(CHR(131)) END ; END | 4FH: IF keyDown(11H) THEN (* , *) IF keyDown(VKShift) THEN PutChar(CHR(129)) ELSE PutChar(CHR(132)) END END | 55H: IF keyDown(11H) THEN (* , *) IF keyDown(VKShift) THEN PutChar(CHR(130)) ELSE PutChar(CHR(133)) END END | 74H: (* F5 - Cut *) PutChar(0BEX) (* CM 08.09.95 *) | 75H: (* F6 - Copy *) PutChar(0BFX) (* CM 08.09.95 *) | 76H: (* F7 - Paste *) PutChar(0C0X) (* CM 08.09.95 *) ELSE END ; END ELSIF (msg.message = WMSysKeyDown) & (msg.wParam = 79H) & ~ShowTitlebar THEN CloseWindow(Display) END ; TranslateMessage(S.ADR(msg)); DispatchMessage(S.ADR(msg)); res := PeekMessage(S.ADR(msg), NULL, 0, 0, PMRemove); END ; END PollEventQueue; PROCEDURE WndProc (window: HWND; msg: LONGINT; uParam, lParam: LONGINT): LONGINT; CONST WMClose = 10H; WMPaint = 0FH; WMChar = 102H; WMDestroy = 2; WMMouseMove = 200H; WMTimer = 113H; WMQueryNewPalette = 30FH; WMGetMinMaxInfo = 24H; TYPE Rect = RECORD left, top, right, bottom: LONGINT END ; MinMaxInfo = POINTER TO RECORD res, maxSize, maxPos, minTrack, maxTrack: RECORD x, y: LONGINT END END ; VAR n, event, res, EBX, ESI, EDI: LONGINT; r: Rect; rgn: LONGINT; mminfo: MinMaxInfo; BEGIN S.GETREG(3, EBX); S.GETREG(6, ESI); S.GETREG(7, EDI); res := 0; event := HIWORD(uParam); CASE msg OF | WMGetMinMaxInfo: res := 1; IF ~ShowTitlebar THEN res := 0; mminfo := S.VAL(MinMaxInfo, lParam); mminfo.maxPos.y := -(TitlebarHeight + FrameWidth); mminfo.maxSize.y := DispH + TitlebarHeight + 2*FrameWidth; mminfo.maxTrack.y := DispH + TitlebarHeight + 2*FrameWidth; END ; | WMChar: PutChar(WinToOberon[SHORT(uParam)]); | 201H .. 209H: (* all mouse downs and ups *) IF msLastKeys = {} THEN SetCapture(Display) END ; msLastKeys := {}; IF ODD(uParam) THEN INCL(msLastKeys, ML) END ; IF ODD(uParam DIV 10H) THEN INCL(msLastKeys, MM); emulateMM := FALSE END ; IF emulateMM & ODD(uParam DIV 8H) THEN INCL(msLastKeys, MM) END ; (* control key down*) IF ODD(uParam DIV 2) THEN INCL(msLastKeys, MR) END ; IF msLastKeys = {} THEN ReleaseCapture END ; msLastX := SHORT(LOWORD(lParam)); msLastY := SHORT(DispH - HIWORD(lParam)); IF msNofEntries < msBufSize THEN msBuf[msIn].keys := msLastKeys; msBuf[msIn].x := msLastX; msBuf[msIn].y := msLastY; msIn := (msIn + 1) MOD msBufSize; INC(msNofEntries) END ; | WMMouseMove: msLastX := SHORT(LOWORD(lParam)); msLastY := SHORT(DispH - HIWORD(lParam)); SetCursor(CurrentCursor); | WMTimer: (* ignore *) ELSE IF msg = WMQueryNewPalette THEN IF hPalette # NULL THEN n := SelectPalette(hdcDisp, hPalette, 0 (*FALSE*)); n := RealizePalette(hdcDisp) END ELSE CASE msg OF | WMClose: Kernel.quitQ.Handle; Kernel.Exit(0); | WMPaint: IF UpdateDisplay # NIL THEN GetUpdateRect(Display, S.ADR(r), 0); rgn := CreateRectRgn(r.left, r.top, r.right, r.bottom); n := SelectObject(hdcDisp, rgn); DeleteObject(rgn); UpdateDisplay; rgn := CreateRectRgn(0, DispH, DispW, 0); n := SelectObject(hdcDisp, rgn); DeleteObject(rgn); dc.x := 0; dc.y := 0; dc.w := DispW; dc.h := DispH; END ; ValidateRect(window, NULL); | WMDestroy: Kernel.quitQ.Handle; Kernel.Exit(0); | 020H: (*WM_SETCURSOR*) SetCursor(CurrentCursor); ELSE res := DefWindowProc(window, msg, uParam, lParam); END END END ; S.PUTREG(3, EBX); S.PUTREG(6, ESI); S.PUTREG(7, EDI); RETURN res; END WndProc; PROCEDURE LongOr(a, b: LONGINT): LONGINT; VAR res: SET; BEGIN res := S.VAL(SET, a) + S.VAL(SET, b); RETURN S.VAL(LONGINT, res) END LongOr; (* PROCEDURE InitInstance; CONST Def = 80000000H; (* CW_USEDEFAULT *) WSVisible = 010000000H; WSCaption = 0C00000H; WSBorder = 0800000H; WSSysMenu = 080000H; WSMaximize = 01000000H; WSMinimizeBox = 020000H; WSMaximizeBox = 010000H; SMCXScreen = 0; SMCYScreen = 1; SMCYCaption = 4; SMCYBorder = 5; SMCYFrame = 33; SMCXFullScreen = 16; SMCYFullScreen = 17; VAR wnd: HWND; style: LONGINT; timerid: LONGINT; ret: LONGINT; BEGIN style := LongOr(WSCaption, WSSysMenu); style := LongOr(style, WSMaximize); style := LongOr(style, WSMinimizeBox); style := LongOr(style, WSMaximizeBox); HideMsg; DispH := GetSystemMetrics(SMCYFullScreen); DispW := GetSystemMetrics(SMCXFullScreen); TitlebarHeight := GetSystemMetrics(SMCYCaption) - GetSystemMetrics(SMCYBorder); FrameWidth := GetSystemMetrics(SMCYBorder); (*GetSystemMetrics(SMCYFrame);*) wnd := CreateWindow(0, S.ADR(ApplicationName), S.ADR(Title), style, Def, Def, Def, Def, NULL, NULL, hInstance, NULL); timerid := SetTimer(wnd, 1, TimeOut, NIL); Display := wnd; hdcDisp := GetDC(Display); InitDeviceContext; IF (OS.platform = 1) & (OS.major >= 4) OR (OS.platform = 2) & (OS.major >= 4) THEN ShowTitlebar := TRUE ELSE DispH := GetSystemMetrics(SMCYScreen); FrameWidth := GetSystemMetrics(SMCYFrame); IF ShowTitlebar THEN DEC(DispH, TitlebarHeight) END END ; nCmdShow := 3; (* ShowMaximized *) ShowWindow(wnd, nCmdShow); END InitInstance; *) PROCEDURE InitInstance; TYPE Rect = RECORD left, top, right, bottom: LONGINT END ; CONST Def = 80000000H; (* CW_USEDEFAULT *) WSVisible = 010000000H; WSCaption = 0C00000H; WSBorder = 0800000H; WSSysMenu = 080000H; WSMaximize = 01000000H; WSMinimizeBox = 020000H; WSMaximizeBox = 010000H; SMCXScreen = 0; SMCYScreen = 1; SMCYCaption = 4; SMCXBorder = 5; SMCYBorder = 6; SMCYFrame = 33; SMCXFullScreen = 16; SMCYFullScreen = 17; SPIGetWorkArea = 48; VAR wnd: HWND; style: LONGINT; timerid: LONGINT; ret: LONGINT; w, h, x, y: LONGINT; rect: Rect; xFrame, yFrame, yCaption, w2, h2: LONGINT; BEGIN HideMsg; style := LongOr(WSCaption, WSSysMenu); style := LongOr(style, WSMinimizeBox); Kernel.GetAdr(0, "width", w); Kernel.GetAdr(0, "height", h); x := Def; y := Def; xFrame := GetSystemMetrics(SMCXBorder); yFrame := GetSystemMetrics(SMCYBorder); yCaption := GetSystemMetrics(SMCYCaption); IF (OS.platform = 1) & (OS.major >= 4) OR (OS.platform = 2) & (OS.major >= 4) THEN ShowTitlebar := TRUE; IF SystemParametersInfo(SPIGetWorkArea, 0, S.ADR(rect), 0) THEN DispW := rect.right - rect.left; DispH := rect.bottom - rect.top; DEC(DispH, yCaption - yFrame) ELSE DispH := GetSystemMetrics(SMCYFullScreen); DispW := GetSystemMetrics(SMCXFullScreen) END ; IF (w = 0) OR (h = 0) THEN (* show full screen *) w := Def; h := Def; style := LongOr(style, WSMaximize); style := LongOr(style, WSMaximizeBox); nCmdShow := 3 (* ShowMaximized *) ELSE w2 := w; h2 := h; DEC(h2, yCaption); DEC(h2, yFrame); DEC(w2, 2 * xFrame); IF (w2 > DispW) OR (h2 > DispH) THEN w := Def; h := Def; style := LongOr(style, WSMaximize); style := LongOr(style, WSMaximizeBox); nCmdShow := 3 (* ShowMaximized *) ELSE IF w2 < DispW THEN DispW := w2; END ; IF h2 < DispH THEN DispH := h2 END ; nCmdShow := 1 (* ShowNormal *) END END ELSE DispH := GetSystemMetrics(SMCYScreen); DispW := GetSystemMetrics(SMCXScreen); TitlebarHeight := yCaption - yFrame; FrameWidth := GetSystemMetrics(SMCYFrame); IF ShowTitlebar THEN DEC(DispH, TitlebarHeight) END ; w := Def; h := Def; nCmdShow := 3 (* ShowMaximized *) END ; wnd := CreateWindow(0, S.ADR(ApplicationName), S.ADR(Title), style, x, y, w, h, NULL, NULL, hInstance, NULL); timerid := SetTimer(wnd, 1, TimeOut, NIL); Display := wnd; hdcDisp := GetDC(Display); InitDeviceContext; ShowWindow(wnd, nCmdShow) END InitInstance; PROCEDURE InitApplication; CONST OwnDC = 20H; VAR wc: WindowClass; name: ARRAY 32 OF CHAR; BEGIN wc.style := OwnDC; wc.wndProc := WndProc; wc.clsExtra := 0; wc.wndExtra := 0; wc.instance := hInstance; name := "Oberon"; wc.icon := LoadIcon(hInstance, S.ADR(name)); wc.cursor := LoadCursor(hInstance, S.ADR(name)); wc.bgnd := NULL; wc.menuName := NULL; wc.className := S.ADR(ApplicationName); RegisterClass(S.ADR(wc)); BonWCursor := LoadCursor(hInstance, S.ADR(name)); name := "OberonWB"; WonBCursor := LoadCursor(hInstance, S.ADR(name)); CurrentCursor := BonWCursor; END InitApplication; (* ---------------------- general ------------------------- *) PROCEDURE Exit* (err: LONGINT); BEGIN exit(err); END Exit; PROCEDURE Terminate; BEGIN PatternTermHandler; DeletePaletteAndDC; END Terminate; PROCEDURE Trap (p: ExceptionInfo): LONGINT; VAR excode, pc, bp, sp, ref, refend, n: LONGINT; offs: LONGINT; trapno: LONGINT; name: ARRAY 32 OF CHAR; mod: Modules.Module; NilProcVar: BOOLEAN; EBX, ESI, EDI: LONGINT; BEGIN S.GETREG(3, EBX); S.GETREG(6, ESI); S.GETREG(7, EDI); IF Kernel.TrapHandlingLevel = 2 THEN INC(Kernel.TrapHandlingLevel); excode := p.exc.code MOD 10000H; pc := p.exc.addr; bp := p.cont.Ebp; sp := p.cont.Esp; IF pc = 0 THEN (* assume call of procedure variable with value NIL *) NilProcVar := TRUE; S.GET(sp, pc); (* get return address on top of stack *) ELSE NilProcVar := FALSE END ; IF excode = 29 THEN (* Illegal Instruction => Oberon traps *) trapno := p.cont.Eax; C.Int(trapno); CASE trapno OF | 0: C.Str(" (ASSERT failed)"); | 1: C.Str(" (Heap overflow)"); | 15: C.Str(" (invalid case in WITH statement)"); | 16: C.Str(" (invalid case in CASE statement)"); | 17: C.Str(" (function procedure with no return value)"); | 18: C.Str(" (type guard check)"); | 19: C.Str(" (implicit type guard check in record assignment)"); | 20: C.Str(" (integer overflow)"); | 21: C.Str(" (range overflow)"); | 22: C.Str(" (dimension trap)"); ELSE IF trapno >= 30 THEN C.Str(" (programmed HALT)"); ELSE C.Str(" (unknown trap)"); END END ; ELSE C.Int(excode); CASE excode OF | 5: IF NilProcVar THEN C.Str(" (NIL proccedure variable called)") ELSE C.Str(" (access violation)") END ; | 8EH .. 93H: C.Str(" (FPU: "); CASE excode OF | 8EH: C.Str(" divide by zero)"); | 91H: C.Str(" overflow)"); | 93H: C.Str(" underflow)"); ELSE C.Str(" exception "); C.Hex(p.exc.code); C.Ch("H") END ; | 94H: C.Str(" (integer division by zero)"); | 95H: C.Str(" (integer overflow)"); | 96H: C.Str(" (privileged instruction)"); ELSE END ; END ; C.Str(" PC = "); C.Hex(pc); C.Ch("H"); C.Ln; (* stack dump *) ShowError.CallStack(TRUE) ELSE MessageBeep(-1); END ; pc := MessageBox(0, S.ADR("Click on OK to continue"), S.ADR("Bootstrap Trap Handler"), 10010H); S.PUTREG(3, EBX); S.PUTREG(6, ESI); S.PUTREG(7, EDI); RETURN -1 END Trap; PROCEDURE InitTrap; VAR a: LONGINT; h: TrapHandler; BEGIN Kernel.GetAdr(0, "HandleTrap", a); h := Trap; S.PUT(a, h) END InitTrap; BEGIN InitTrap; mod := Kernel.LoadLibrary("Kernel32"); Kernel.GetAdr(mod, "GetTickCount", S.VAL(LONGINT, GetTickCount)); Kernel.GetAdr(mod, "GetVersion", S.VAL(LONGINT, GetVersion)); Kernel.GetAdr(mod, "GetVersionExA", S.VAL(LONGINT, GetVersionEx)); Kernel.GetAdr(mod, "GlobalAlloc", S.VAL(LONGINT, GlobalAlloc)); Kernel.GetAdr(mod, "GlobalFree", S.VAL(LONGINT, GlobalFree)); Kernel.GetAdr(mod, "GlobalLock", S.VAL(LONGINT, GlobalLock)); Kernel.GetAdr(mod, "GlobalUnlock", S.VAL(LONGINT, GlobalUnlock)); Kernel.GetAdr(mod, "GetLastError", S.VAL(LONGINT, GetLastError)); mod := Kernel.LoadLibrary("User32"); Kernel.GetAdr(mod, "DispatchMessageA", S.VAL(LONGINT, DispatchMessage)); Kernel.GetAdr(mod, "PeekMessageA", S.VAL(LONGINT, PeekMessage)); Kernel.GetAdr(mod, "WaitMessage", S.VAL(LONGINT, WaitMessage)); Kernel.GetAdr(mod, "GetInputState", S.VAL(LONGINT, GetInputState)); Kernel.GetAdr(mod, "TranslateMessage", S.VAL(LONGINT, TranslateMessage)); Kernel.GetAdr(mod, "LoadCursorA", S.VAL(LONGINT, LoadCursor)); Kernel.GetAdr(mod, "SetCursor", S.VAL(LONGINT, SetCursor)); Kernel.GetAdr(mod, "LoadIconA", S.VAL(LONGINT, LoadIcon)); Kernel.GetAdr(mod, "RegisterClassA", S.VAL(LONGINT, RegisterClass)); Kernel.GetAdr(mod, "CreateWindowExA", S.VAL(LONGINT, CreateWindow)); Kernel.GetAdr(mod, "GetActiveWindow", S.VAL(LONGINT, GetActiveWindow)); Kernel.GetAdr(mod, "ShowWindow", S.VAL(LONGINT, ShowWindow)); Kernel.GetAdr(mod, "UpdateWindow", S.VAL(LONGINT, UpdateWindow)); Kernel.GetAdr(mod, "DestroyWindow", S.VAL(LONGINT, DestroyWindow)); Kernel.GetAdr(mod, "CloseWindow", S.VAL(LONGINT, CloseWindow)); Kernel.GetAdr(mod, "PostQuitMessage", S.VAL(LONGINT, PostQuitMessage)); Kernel.GetAdr(mod, "GetClientRect", S.VAL(LONGINT, GetClientRect)); Kernel.GetAdr(mod, "SystemParametersInfoA", S.VAL(LONGINT, SystemParametersInfo)); Kernel.GetAdr(mod, "DefWindowProcA", S.VAL(LONGINT, DefWindowProc)); Kernel.GetAdr(mod, "ValidateRect", S.VAL(LONGINT, ValidateRect)); Kernel.GetAdr(mod, "GetDC", S.VAL(LONGINT, GetDC)); Kernel.GetAdr(mod, "ReleaseDC", S.VAL(LONGINT, ReleaseDC)); Kernel.GetAdr(mod, "GetSystemMetrics", S.VAL(LONGINT, GetSystemMetrics)); Kernel.GetAdr(mod, "ScreenToClient", S.VAL(LONGINT, ScreenToClient)); Kernel.GetAdr(mod, "SetTimer", S.VAL(LONGINT, SetTimer)); Kernel.GetAdr(mod, "SetCapture", S.VAL(LONGINT, SetCapture)); Kernel.GetAdr(mod, "ReleaseCapture", S.VAL(LONGINT, ReleaseCapture)); Kernel.GetAdr(mod, "GetKeyState", S.VAL(LONGINT, GetKeyState)); Kernel.GetAdr(mod, "ScrollDC", S.VAL(LONGINT, ScrollDC)); Kernel.GetAdr(mod, "GetUpdateRect", S.VAL(LONGINT, GetUpdateRect)); Kernel.GetAdr(mod, "ShowCursor", S.VAL(LONGINT, ShowCursor)); Kernel.GetAdr(mod, "OpenClipboard", S.VAL(LONGINT, OpenClipboard)); Kernel.GetAdr(mod, "CloseClipboard", S.VAL(LONGINT, CloseClipboard)); Kernel.GetAdr(mod, "SetClipboardData", S.VAL(LONGINT, SetClipboardData)); Kernel.GetAdr(mod, "GetClipboardData", S.VAL(LONGINT, GetClipboardData)); Kernel.GetAdr(mod, "EmptyClipboard", S.VAL(LONGINT, EmptyClipboard)); Kernel.GetAdr(mod, "MessageBeep", S.VAL(LONGINT, MessageBeep)); Kernel.GetAdr(mod, "MessageBoxA", S.VAL(LONGINT, MessageBox)); mod := Kernel.LoadLibrary("GDI32"); Kernel.GetAdr(mod, "CreateSolidBrush", S.VAL(LONGINT, CreateSolidBrush)); Kernel.GetAdr(mod, "CreatePen", S.VAL(LONGINT, CreatePen)); Kernel.GetAdr(mod, "CreatePatternBrush", S.VAL(LONGINT, CreatePatternBrush)); Kernel.GetAdr(mod, "CreateRectRgn", S.VAL(LONGINT, CreateRectRgn)); Kernel.GetAdr(mod, "SelectObject", S.VAL(LONGINT, SelectObject)); Kernel.GetAdr(mod, "DeleteObject", S.VAL(LONGINT, DeleteObject)); Kernel.GetAdr(mod, "CreateBitmap", S.VAL(LONGINT, CreateBitmap)); Kernel.GetAdr(mod, "CreateCompatibleBitmap", S.VAL(LONGINT, CreateCompatibleBitmap)); Kernel.GetAdr(mod, "CreateCompatibleDC", S.VAL(LONGINT, CreateCompatibleDC)); Kernel.GetAdr(mod, "DeleteDC", S.VAL(LONGINT, DeleteDC)); Kernel.GetAdr(mod, "SetTextColor", S.VAL(LONGINT, SetTextColor)); Kernel.GetAdr(mod, "SetTextAlign", S.VAL(LONGINT, SetTextAlign)); Kernel.GetAdr(mod, "SetBkMode", S.VAL(LONGINT, SetBkMode)); Kernel.GetAdr(mod, "SetBkColor", S.VAL(LONGINT, SetBkColor)); Kernel.GetAdr(mod, "SetBrushOrgEx", S.VAL(LONGINT, SetBrushOrgEx)); Kernel.GetAdr(mod, "RealizePalette", S.VAL(LONGINT, RealizePalette)); Kernel.GetAdr(mod, "CreatePalette", S.VAL(LONGINT, CreatePalette)); Kernel.GetAdr(mod, "SetPaletteEntries", S.VAL(LONGINT, SetPaletteEntries)); Kernel.GetAdr(mod, "GetPaletteEntries", S.VAL(LONGINT, GetPaletteEntries)); Kernel.GetAdr(mod, "AnimatePalette", S.VAL(LONGINT, AnimatePalette)); Kernel.GetAdr(mod, "SelectPalette", S.VAL(LONGINT, SelectPalette)); Kernel.GetAdr(mod, "UpdateColors", S.VAL(LONGINT, UpdateColors)); Kernel.GetAdr(mod, "UnrealizeObject", S.VAL(LONGINT, UnrealizeObject)); Kernel.GetAdr(mod, "TextOutA", S.VAL(LONGINT, TextOut)); Kernel.GetAdr(mod, "PatBlt", S.VAL(LONGINT, PatBlt)); Kernel.GetAdr(mod, "BitBlt", S.VAL(LONGINT, BitBlt)); Kernel.GetAdr(mod, "GdiFlush", S.VAL(LONGINT, GdiFlush)); Kernel.GetAdr(mod, "GdiSetBatchLimit", S.VAL(LONGINT, GdiSetBatchLimit)); Kernel.GetAdr(mod, "GetStockObject", S.VAL(LONGINT, GetStockObject)); Kernel.GetAdr(mod, "GetDeviceCaps", S.VAL(LONGINT, GetDeviceCaps)); Kernel.GetAdr(mod, "SetSystemPaletteUse", S.VAL(LONGINT, SetSystemPaletteUse)); Kernel.GetAdr(mod, "GetSystemPaletteEntries", S.VAL(LONGINT, GetSystemPaletteEntries)); mod := Kernel.LoadLibrary("COMDLG32"); Kernel.GetAdr(mod, "PrintDlgA", S.VAL(LONGINT, PrintDlg)); ApplicationName := "Oberon(TM)"; Title := "Oberon for Windows"; Kernel.GetAdr(0, "exit", S.VAL(LONGINT, exit)); Kernel.GetAdr(0, "hInstance", S.VAL(LONGINT, hInstance)); Kernel.GetAdr(0, "hPrevInstance", S.VAL(LONGINT, hPrevInst)); Kernel.GetAdr(0, "nCmdShow", nCmdShow); Kernel.GetAdr(0, "ShowTitlebar", mod); ShowTitlebar := mod # 0; Kernel.GetAdr(0, "ShowMsg", S.VAL(LONGINT, ShowMsg)); Kernel.GetAdr(0, "HideMsg", S.VAL(LONGINT, HideMsg)); ShowMsg(S.ADR("Module body of Win32")); IF hPrevInst = NULL THEN InitApplication END ; mod := GetVersion(); IF mod > 0 THEN OS.platform := 2 ELSE OS.platform := 1 END ; OS.major := mod MOD 100H; OS.minor := (mod DIV 100H) MOD 100H; OS.size := SIZE(VersionInfo); IF (GetVersionEx # NIL) & GetVersionEx(S.ADR(OS)) THEN END; UpdateDisplay := NIL; kbNofChars := 0; kbIn := 0; kbOut := 0; (* keyboard buffer initialisation *) msNofEntries := 0; msIn := 0; msOut := 0; (* mouse buffer initialisation *) msLastX := 0; msLastY := 0; msLastKeys := {}; emulateMM := TRUE; TimeOut := 50; PatternList := NIL; PD.size := 66; PD.hDevMode := NULL; PD.hDevNames := NULL; hPalette := NULL; InitTranslations; InitInstance; Kernel.InstallTermHandler(Terminate); mod := GdiSetBatchLimit(255); END Win32.