Amiga MA Magazine 1998 #6/amigamamagazinepolishissue1998.iso/coders/jËzyki_programowania/oberon/system/oberon.mod

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.