home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga MA Magazine 1998 #6
/
amigamamagazinepolishissue1998.iso
/
coders
/
jËzyki_programowania
/
oberon
/
system
/
oberon.mod
(
.txt
)
< prev
next >
Wrap
Oberon Text
|
1977-12-31
|
17KB
|
507 lines
Syntax20b.Scn.Fnt
ParcElems
Alloc
Syntax24b.Scn.Fnt
Syntax10.Scn.Fnt
Syntax10i.Scn.Fnt
Syntax10b.Scn.Fnt
(* AMIGA *)
MODULE Oberon; (*JG 6.9.90*) (* << RC 19.3.93, shml, cn 2.6.94 *)
IMPORT SYSTEM, Amiga, AmigaDos, Kernel, Modules, Input, Display, Fonts, Viewers, Texts, V24, AmigaIntuition;
CONST
(*message ids*)
consume* = 0; track* = 1; (* InputMsg *)
defocus* = 0; neutralize* = 1; mark* = 2; (* ControlMsg *)
BasicCycle = 20;
ESC = 1BX; SETUP = 0A4X;
TYPE
Painter* = PROCEDURE (x, y: INTEGER);
Marker* = RECORD Fade*, Draw*: Painter END;
Cursor* = RECORD
marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER
END;
ParList* = POINTER TO ParRec;
ParRec* = RECORD
vwr*: Viewers.Viewer;
frame*: Display.Frame;
text*: Texts.Text;
pos*: LONGINT
END;
InputMsg* = RECORD (Display.FrameMsg)
id*: INTEGER;
keys*: SET;
X*, Y*: INTEGER;
ch*: CHAR;
fnt*: Fonts.Font;
col*, voff*: SHORTINT
END;
SelectionMsg* = RECORD (Display.FrameMsg)
time*: LONGINT;
text*: Texts.Text;
beg*, end*: LONGINT
END;
ControlMsg* = RECORD (Display.FrameMsg)
id*, X*, Y*: INTEGER
END;
CopyOverMsg* = RECORD (Display.FrameMsg)
text*: Texts.Text;
beg*, end*: LONGINT
END;
CopyMsg* = RECORD (Display.FrameMsg)
F*: Display.Frame
END;
Task* = POINTER TO TaskDesc;
Handler* = PROCEDURE;
TaskDesc* = RECORD
next: Task;
safe*: BOOLEAN;
time*: LONGINT;
handle*: Handler
END;
User*: ARRAY 8 OF CHAR;
Password*: LONGINT;
Arrow*, Star*: Marker;
Mouse*, Pointer*: Cursor;
FocusViewer*: Viewers.Viewer;
Log*: Texts.Text;
Par*: ParList; (*actual parameters*)
CurTask*, PrevTask: Task;
CurFnt*: Fonts.Font; CurCol*, CurOff*: SHORTINT;
DW, DH, CL, H0, H1, H2, H3: INTEGER;
unitW: INTEGER;
ActCnt: INTEGER; (*action count for GC*)
Mod: Modules.Module;
(*user identification*)
PROCEDURE Code(VAR s: ARRAY OF CHAR): LONGINT;
VAR i: INTEGER; a, b, c: LONGINT;
BEGIN
a := 0; b := 0; i := 0;
WHILE s[i] # 0X DO
c := b; b := a; a := (c MOD 509 + 1) * 127 + ORD(s[i]);
INC(i)
END;
IF b >= 32768 THEN b := b - 65536 END;
RETURN b * 65536 + a
END Code;
PROCEDURE SetUser* (VAR user, password: ARRAY OF CHAR);
BEGIN COPY(user, User); Password := Code(password)
END SetUser;
(*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Kernel.GetClock(t, d)
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
BEGIN Kernel.SetClock(t, d)
END SetClock;
PROCEDURE Time* (): LONGINT;
BEGIN RETURN Input.Time()
END Time;
(*cursor handling*)
PROCEDURE FlipArrow (X, Y: INTEGER);
BEGIN
(*IF X < CL THEN *)
(*IF X > DW - 15 THEN X := DW - 15 END *)
(*ELSE *)
(*IF X > CL + DW - 15 THEN X := CL + DW - 15 END *)
(*END; *)
(*IF Y < 14 THEN Y := 14 ELSIF Y > DH THEN Y := DH END; *)
IF X < CL THEN X := CL ELSIF X > CL + DW-1 THEN X := CL + DW-1 END;
IF Y < 0 THEN Y := 0 ELSIF Y > DH THEN Y := DH END;
Display.CopyPattern(Display.white, Display.arrow, X, Y - 14, 2)
END FlipArrow;
PROCEDURE FlipStar (X, Y: INTEGER);
BEGIN
IF X < CL THEN
IF X < 7 THEN X := 7 ELSIF X > DW - 8 THEN X := DW - 8 END
ELSE
IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 8 THEN X := CL + DW - 8 END
END ;
IF Y < 7 THEN Y := 7 ELSIF Y > DH - 8 THEN Y := DH - 8 END;
Display.CopyPattern(Display.white, Display.star, X - 7, Y - 7, 2)
END FlipStar;
PROCEDURE OpenCursor* (VAR c: Cursor);
BEGIN c.on := FALSE; c.X := 0; c.Y := 0
END OpenCursor;
PROCEDURE FadeCursor* (VAR c: Cursor);
BEGIN IF c.on THEN c.marker.Fade(c.X, c.Y); c.on := FALSE END
END FadeCursor;
PROCEDURE DrawCursor* (VAR c: Cursor; VAR m: Marker; X, Y: INTEGER);
BEGIN
IF c.on & ((X # c.X) OR (Y # c.Y) OR (m.Draw # c.marker.Draw)) THEN
c.marker.Fade(c.X, c.Y); c.on := FALSE
END;
IF ~c.on THEN
m.Draw(X, Y); c.marker := m; c.X := X; c.Y := Y; c.on := TRUE
END
END DrawCursor;
(*display management*)
PROCEDURE RemoveMarks* (X, Y, W, H: INTEGER);
BEGIN
IF (Mouse.X > X - 16) & (Mouse.X < X + W + 16) & (Mouse.Y > Y - 16) & (Mouse.Y < Y + H + 16) THEN
FadeCursor(Mouse)
END;
IF (Pointer.X > X - 8) & (Pointer.X < X + W + 8) & (Pointer.Y > Y - 8) & (Pointer.Y < Y + H + 8) THEN
FadeCursor(Pointer)
END
END RemoveMarks;
PROCEDURE HandleFiller (V: Display.Frame; VAR M: Display.FrameMsg);
BEGIN
WITH V: Viewers.Viewer DO
IF M IS InputMsg THEN
WITH M: InputMsg DO
IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END
END
ELSIF M IS ControlMsg THEN
WITH M: ControlMsg DO
IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END
END
ELSIF M IS Viewers.ViewerMsg THEN
WITH M: Viewers.ViewerMsg DO
IF (M.id = Viewers.restore) & (V.W > 0) & (V.H > 0) THEN
RemoveMarks(V.X, V.Y, V.W, V.H);
Display.ReplConst(Display.black, V.X, V.Y, V.W, V.H, 0)
ELSIF (M.id = Viewers.modify) & (M.Y < V.Y) THEN
RemoveMarks(V.X, M.Y, V.W, V.Y - M.Y);
Display.ReplConst(Display.black, V.X, M.Y, V.W, V.Y - M.Y, 0)
END
END
END
END
END HandleFiller;
PROCEDURE OpenDisplay* (UW, SW, H: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
Input.SetMouseLimits(Viewers.curW + UW + SW, H);
Display.ReplConst(Display.black, Viewers.curW, 0, UW + SW, H, 0);
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(UW, H, Filler); (*init user track*)
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(SW, H, Filler) (*init system track*)
END OpenDisplay;
PROCEDURE DisplayWidth* (X: INTEGER): INTEGER;
BEGIN RETURN DW
END DisplayWidth;
PROCEDURE DisplayHeight* (X: INTEGER): INTEGER;
BEGIN RETURN DH
END DisplayHeight;
PROCEDURE OpenTrack* (X, W: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
NEW(Filler); Filler.handle := HandleFiller;
Viewers.OpenTrack(X, W, Filler)
END OpenTrack;
PROCEDURE UserTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW
END UserTrack;
PROCEDURE SystemTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW + DW DIV 8 * 5
END SystemTrack;
PROCEDURE UY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, 0, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
RETURN max.Y + max.H DIV 2
END UY;
PROCEDURE AllocateUserViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW; Y := UY(X)
END
END AllocateUserViewer;
PROCEDURE SY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, DH, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
IF max.H >= DH - H0 THEN RETURN max.Y + H3 END;
IF max.H >= H3 - H0 THEN RETURN max.Y + H2 END;
IF max.H >= H2 - H0 THEN RETURN max.Y + H1 END;
IF max # bot THEN RETURN max.Y + max.H DIV 2 END;
IF bot.H >= H1 THEN RETURN bot.H DIV 2 END;
RETURN alt.Y + alt.H DIV 2
END SY;
PROCEDURE AllocateSystemViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW + DW DIV 8 * 5; Y := SY(X)
END
END AllocateSystemViewer;
PROCEDURE MarkedViewer* (): Viewers.Viewer;
BEGIN RETURN Viewers.This(Pointer.X, Pointer.Y)
END MarkedViewer;
PROCEDURE PassFocus* (V: Viewers.Viewer);
VAR M: ControlMsg;
BEGIN M.id := defocus; FocusViewer.handle(FocusViewer, M); FocusViewer := V
END PassFocus;
(*command interpretation*)
PROCEDURE Call* (name: ARRAY OF CHAR; par: ParList; new: BOOLEAN; VAR res: INTEGER);
VAR Mod: Modules.Module; P: Modules.Command; i, j: INTEGER;
BEGIN
(*Amiga.Turbo; (* set task priority high *)*) (*<<RD only MainLoop should change the Pri*)
res := 1;
i := 0; j := 0;
WHILE name[j] # 0X DO
IF name[j] = "." THEN i := j END;
INC(j)
END;
IF i > 0 THEN
name[i] := 0X;
IF new THEN Modules.Free(name, FALSE) END;
Mod := Modules.ThisMod(name);
IF Modules.res = 0 THEN
INC(i); j := i;
WHILE name[j] # 0X DO name[j - i] := name[j]; INC(j) END;
name[j - i] := 0X;
P := Modules.ThisCommand(Mod, name);
IF Modules.res = 0 THEN
Par := par; Par.vwr := Viewers.This(par.frame.X, par.frame.Y); P; res := 0
ELSE
res:=Modules.res
END
ELSE res := Modules.res
END
END;
(*Amiga.Idle (* set task priority low *)*) (*<<RD only MainLoop should change the Pri*)
END Call;
PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
VAR M: SelectionMsg;
BEGIN
M.time := -1; Viewers.Broadcast(M); time := M.time;
IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END
END GetSelection;
PROCEDURE GC;
BEGIN
IF ActCnt<=0 THEN
Kernel.GC(TRUE);
ActCnt:=BasicCycle
END
END GC;
PROCEDURE Install* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # PrevTask) & (t.next # T) DO t := t.next END;
IF t.next # T THEN T.next := PrevTask; t.next := T END
END Install;
PROCEDURE Remove* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # T) & (t.next # PrevTask) DO t := t.next END;
IF t.next = T THEN t.next := t.next.next; PrevTask := t.next END;
IF CurTask = T THEN CurTask := PrevTask.next END
END Remove;
PROCEDURE Collect* (count: INTEGER);
BEGIN
ActCnt := count
END Collect;
PROCEDURE SetFont* (fnt: Fonts.Font);
BEGIN
CurFnt := fnt
END SetFont;
PROCEDURE SetColor* (col: SHORTINT);
BEGIN CurCol := col
END SetColor;
PROCEDURE SetOffset* (voff: SHORTINT);
BEGIN CurOff := voff
END SetOffset;
PROCEDURE NotifyTasks; (* << JT *)
Call handler of all those task, which have set their time field to -1.
VAR t0, t1: Task;
BEGIN t0 := PrevTask;
REPEAT
CurTask := PrevTask.next;
IF CurTask.time = -1 THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
t1 := CurTask; CurTask.handle; PrevTask.next := CurTask;
IF CurTask # t1 THEN RETURN END (*detect Remove(CurTask)*)
END;
PrevTask := CurTask
UNTIL CurTask = t0
END NotifyTasks;
PROCEDURE NotifyAllTasks; (* << RD for Time depending MainLoop *)
Call handler of all those task, which have set their time field to -1.
VAR t0, t1: Task; ti: LONGINT;
BEGIN
t0 := PrevTask;
ti:=Input.Time();
REPEAT
CurTask := PrevTask.next;
IF (CurTask.time <= ti) & (CurTask.time # -1) THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
t1 := CurTask; CurTask.handle; PrevTask.next := CurTask;
IF CurTask # t1 THEN RETURN END (*detect Remove(CurTask)*)
END;
PrevTask := CurTask
UNTIL CurTask = t0
END NotifyAllTasks;
PROCEDURE Loop*;
The Oberon loop. The "task scheduler" of Oberon.
TYPE
winptr = POINTER TO AmigaIntuition.Window;
VAR
frame:RECORD END;
V: Viewers.Viewer; M: InputMsg; N: ControlMsg;
prevX, prevY, X, Y: INTEGER; keys: SET; ch: CHAR;
VM: Viewers.ViewerMsg; (* << *)
LastLoopType: BOOLEAN; (* <> *)
win: winptr; (*<<RD*)
PROCEDURE HandleChar(); (*<RD*)
VAR
chint: INTEGER;
dumMod: Modules.Module;
BEGIN
Input.Read(ch);
chint:=ORD(ch);
IF ch = ESC THEN
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer)
ELSIF ch = SETUP THEN
N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N)
ELSIF ch = 0CX THEN (* << Form Feed => refresh display*)
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer);
VM.id := Viewers.suspend; Viewers.Broadcast(VM);
VM.id := Viewers.restore; Viewers.Broadcast(VM)
ELSIF (chint>245) & (chint<255) THEN (*<RD F6-F10, HELP and Clipboard-Keys *)
IF (chint>251) & (Kernel.FKey[13]=NIL) THEN dumMod:=Modules.ThisMod("Clipboard") END;
IF Kernel.FKey[chint-240]#NIL THEN Kernel.FKey[chint-240] END;
ELSIF ch = 0EFX THEN
Amiga.Terminate
ELSE
M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff;
FocusViewer.handle(FocusViewer, M);
DEC(ActCnt); NotifyTasks
END
END HandleChar;
BEGIN
Remember the current stack, so that the Kernel's stack collector knows where to look for pointers.
LastLoopType:=~Amiga.MainLoopType; (* <> *)
Kernel.stackBottom := SYSTEM.ADR(frame); (* << *)
prevX:=-1; prevY:=1;
win:=SYSTEM.VAL(winptr, Amiga.window);
LOOP
IF AmigaIntuition.windowActive IN win.flags THEN
Input.Mouse(keys, X, Y);
ELSE
X:=prevX; Y:=prevY; keys:={};
END;
IF Amiga.MainLoopType THEN (* Time depending MainLoop *)
IF ~LastLoopType THEN Amiga.Turbo; LastLoopType:=TRUE END;
IF Input.Available() > 0 THEN
(*
Handle all special characters, before handling the standard case.
*)
HandleChar(); (*<RD*)
ELSIF keys # {} THEN
(*
As long, as a mouse key is pressed, send messages to the viewer on which the cursor
is placed. Return to the loop only, when all mouse keys have been released.
*)
M.id := track; M.X := X; M.Y := Y; M.keys := keys;
REPEAT
V := Viewers.This(M.X, M.Y); V.handle(V, M);
Input.Mouse(M.keys, M.X, M.Y)
UNTIL M.keys = {};
DEC(ActCnt); NotifyTasks
ELSIF V24.Available() > 0 THEN
(*
Char available at the Serial Device => It is an event => notify ALL tasks
*)
NotifyTasks
ELSE
(*
On mouse coordinate change notify the viewer below the actual mouse position.
*)
IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
M.id := track; M.X := X; M.Y := Y; M.keys := {}; V := Viewers.This(X, Y);
V.handle(V, M);
prevX := X; prevY := Y
END;
(*
Call handler of background task with a time not in the future and advance task pointer to next ready task.
Tasks which are called by NotifiyTask (time=-1) are not called here.
*)
NotifyAllTasks
END;
Amiga.WaitTime(0, Amiga.TicsToWait); (* Wait for a while *)
ELSE (* ever running MainLoop, low Task-Pri *)
(* This is the way nearer the original *)
IF LastLoopType THEN Amiga.Idle; LastLoopType:=FALSE END;
IF Input.Available() > 0 THEN
(*
Handle all special characters, before handling the standard case.
*)
Amiga.Turbo;
HandleChar(); (*<RD*)
Amiga.Idle
ELSIF keys # {} THEN
(*
As long, as a mouse key is pressed, send messages to the viewer on which the cursor
is placed. Return to the loop only, when all mouse keys have been released.
*)
Amiga.Turbo;
M.id := track; M.X := X; M.Y := Y; M.keys := keys;
REPEAT
V := Viewers.This(M.X, M.Y); V.handle(V, M);
Input.Mouse(M.keys, M.X, M.Y)
UNTIL M.keys = {};
DEC(ActCnt); NotifyTasks;
Amiga.Idle
ELSIF V24.Available() > 0 THEN
(*
Char available at the Serial Device => It is an event => notify ALL tasks
*)
NotifyTasks
ELSE
(*
On mouse coordinate change notify the viewer below the actual mouse position.
*)
IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
Amiga.Turbo;
M.id := track; M.X := X; M.Y := Y; M.keys := {}; V := Viewers.This(X, Y);
V.handle(V, M);
prevX := X; prevY := Y;
Amiga.Idle
END;
(*
Call handler of background task with a time not in the future and advance task pointer to next ready task.
Tasks which are called by NotifiyTask (time=-1) are not called here.
*)
CurTask := PrevTask.next;
IF (CurTask.time <= Input.Time()) & (CurTask.time # -1) THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
CurTask.handle; PrevTask.next := CurTask
END;
PrevTask := CurTask
END
END
END
END Loop;
PROCEDURE Init;
BEGIN
User[0] := 0X;
Arrow.Fade := FlipArrow; Arrow.Draw := FlipArrow;
Star.Fade := FlipStar; Star.Draw := FlipStar;
OpenCursor(Mouse); OpenCursor(Pointer);
DW := Display.Width; DH := Display.Height; CL := Display.ColLeft;
H3 := DH - DH DIV 3;
H2 := H3 - H3 DIV 2;
H1 := DH DIV 5;
H0 := DH DIV 10;
unitW := DW DIV 8;
OpenDisplay(unitW * 5, unitW * 3, DH);
FocusViewer := Viewers.This(0, 0);
CurFnt := Fonts.Default;
CurCol := Display.white;
CurOff := 0;
Collect(BasicCycle);
NEW(PrevTask);
PrevTask.handle := GC;
PrevTask.safe := TRUE;
PrevTask.time := -1; (* << (instead of 0) JT *)
PrevTask.next := PrevTask;
Display.SetMode(0, {})
END Init;
BEGIN Init;
(* only if System not in boot file: *)
Mod:=Modules.ThisMod("System")
END Oberon.