MODULE Services;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
changes = ""
issues = ""
**)
IMPORT SYSTEM, Kernel;
CONST
now* = 0; immediately* = -1; (** DoLater notBefore **)
resolution* = 1000;
scale = resolution DIV Kernel.timeResolution;
corr = resolution MOD Kernel.timeResolution;
TYPE
Action* = POINTER TO ABSTRACT RECORD
notBefore: LONGINT;
next: Action (* next element in linear list *)
END;
ActionHook* = POINTER TO ABSTRACT RECORD (Kernel.Hook) END;
StdHook = POINTER TO RECORD (ActionHook) END;
VAR
actionHook-: ActionHook;
actions: Action; (* list of actions *)
candidates: Action; (* list of action candidates in IterateOverActions,
NIL during normal execution of commands *)
hasImmediates: BOOLEAN; (* this is a hint: one or more actions in some ring may be immediate actions *)
trapCnt: INTEGER;
PROCEDURE Ticks* (): LONGINT;
VAR t: LONGINT;
BEGIN
t := Kernel.Time();
RETURN t * scale + t * corr DIV Kernel.timeResolution
END Ticks;
(** Action **)
PROCEDURE (a: Action) Do- (), NEW, ABSTRACT;
PROCEDURE In (l, a: Action): BOOLEAN;
BEGIN
WHILE (l # NIL) & (l # a) DO l := l.next END;
RETURN l # NIL
END In;
PROCEDURE Incl (VAR l: Action; a: Action);
BEGIN
IF l # NIL THEN a.next := l END;
l := a
END Incl;
PROCEDURE Excl (VAR l: Action; a: Action);
VAR p0, p1: Action;
BEGIN
IF l = a THEN
l := a.next; a.next := NIL
ELSIF l # NIL THEN
p0 := l; p1 := p0.next;
(* (p0 # NIL) & (p0 # a) *)
WHILE (p1 # NIL) & (p1 # a) DO p0 := p1; p1 := p0.next END;
IF p1 = a THEN p0.next := a.next; a.next := NIL END
END
END Excl;
PROCEDURE Exec (a: Action);
VAR t: Kernel.Type;
BEGIN
t := Kernel.TypeOf(a);
IF t.mod.refcnt >= 0 THEN (* execute action if its module is not unloaded *)
a.Do (* warning: here the actions and candidates lists may be modified, or a trap may occur! *)
END
END Exec;
PROCEDURE Cleanup;
VAR p: Action;
BEGIN
IF candidates # NIL THEN (* trap handling *)
p := candidates; WHILE p.next # NIL DO p := p.next END; (* find last element of candidates list *)
p.next := actions; actions := candidates; candidates := NIL (* prepend candidates list to actions list *)
END;
trapCnt := Kernel.trapCount (* all traps are handled now *)
END Cleanup;
PROCEDURE DoLater* (a: Action; notBefore: LONGINT);
(** Register action a. If a is already registered, its notBefore value is updated instead. **)
BEGIN
ASSERT(a # NIL, 20);
IF ~In(actions, a) & ~In(candidates, a) THEN
Incl(actions, a)
END;
a.notBefore := notBefore; (* if a was already in a list, this statement updates the notBefore value *)
IF notBefore = immediately THEN hasImmediates := TRUE END
END DoLater;
PROCEDURE RemoveAction* (a: Action);
(** Unregister action a. If a is not registered, nothing happens **)
BEGIN
IF a # NIL THEN
Excl(actions, a);
Excl(candidates, a)
END
END RemoveAction;
PROCEDURE IterateOverActions (time: LONGINT);
VAR p: Action;
BEGIN
Cleanup; (* trap handling, if necessary *)
(* candidates = NIL *)
candidates := actions; actions := NIL; (* move action list to candidates list *)
WHILE candidates # NIL DO (* for every candidate: execute it or put it back into actions list *)
p := candidates; candidates := p.next; (* remove head element from candidates list *)
IF (0 <= p.notBefore) & (p.notBefore <= time) OR (p.notBefore <= time) & (time < 0) THEN
p.next := NIL; Exec(p) (* warning: p may call DoLater or RemoveAction,
which change the lists! *)
ELSE
p.next := actions; actions := p (* move to actions list for later processing *)
END
END
END IterateOverActions;
PROCEDURE (h: ActionHook) Step*, NEW, ABSTRACT;
PROCEDURE (h: ActionHook) Loop*, NEW, ABSTRACT;
PROCEDURE (h: StdHook) Step;
BEGIN
IF (candidates = NIL) OR (trapCnt < Kernel.trapCount) THEN
IterateOverActions(Ticks())
END
END Step;
PROCEDURE (h: StdHook) Loop;
BEGIN
IF hasImmediates THEN
ASSERT((candidates = NIL) OR (trapCnt < Kernel.trapCount), 100);
IterateOverActions(immediately);
hasImmediates := FALSE
END
END Loop;
(* type handling functions *)
PROCEDURE ThisDesc (IN type: ARRAY OF CHAR; load: BOOLEAN): Kernel.Type;
CONST record = 1; pointer = 3;
VAR m: Kernel.Module; t: Kernel.Type; i, j: INTEGER; ch: CHAR;
typ: Kernel.Name; mod: ARRAY 256 OF CHAR;
BEGIN
ASSERT(type # "", 20);
i := 0; ch := type[0];
WHILE (ch # ".") & (ch # 0X) DO mod[i] := ch; INC(i); ch := type[i] END;
ASSERT(ch = ".", 21);
mod[i] := 0X; INC(i); t := NIL;
IF load THEN
m := Kernel.ThisMod(mod)
ELSE typ := SHORT(mod$); m := Kernel.ThisLoadedMod(typ)
END;
IF m # NIL THEN
j := 0; REPEAT ch := type[i]; typ[j] := SHORT(ch); INC(i); INC(j) UNTIL ch = 0X;
t := Kernel.ThisType(m, typ);
IF t = NIL THEN typ[j - 1] := "^"; typ[j] := 0X; t := Kernel.ThisType(m, typ) END
END;
IF t # NIL THEN
IF t.id MOD 4 = pointer THEN t := t.base[0] END;
IF t.id MOD 4 # record THEN t := NIL END
END;
RETURN t
END ThisDesc;
PROCEDURE GetTypeName* (IN rec: ANYREC; OUT type: ARRAY OF CHAR);
VAR i, j: INTEGER; ch: CHAR; t: Kernel.Type; name: Kernel.Name;
BEGIN
t := Kernel.TypeOf(rec);
Kernel.GetTypeName(t, name); type := t.mod.name$;
i := 0; ch := type[0]; WHILE ch # 0X DO INC(i); ch := type[i] END;
type[i] := "."; INC(i);
j := 0; REPEAT ch := name[j]; type[i] := ch; INC(i); INC(j) UNTIL ch = 0X;
IF type[i - 2] = "^" THEN type[i - 2] := 0X END
END GetTypeName;
PROCEDURE SameType* (IN ra, rb: ANYREC): BOOLEAN;
BEGIN
RETURN Kernel.TypeOf(ra) = Kernel.TypeOf(rb)
END SameType;
PROCEDURE IsExtensionOf* (IN ra, rb: ANYREC): BOOLEAN;
VAR ta, tb: Kernel.Type;
BEGIN
ta := Kernel.TypeOf(ra); tb := Kernel.TypeOf(rb);
RETURN ta.base[tb.id DIV 16 MOD 16] = tb
END IsExtensionOf;
PROCEDURE Is* (IN rec: ANYREC; IN type: ARRAY OF CHAR): BOOLEAN;
VAR ta, tb: Kernel.Type;
BEGIN
ta := Kernel.TypeOf(rec); tb := ThisDesc(type, FALSE);
IF tb # NIL THEN RETURN ta.base[tb.id DIV 16 MOD 16] = tb
ELSE RETURN FALSE
END
END Is;
PROCEDURE Extends* (IN type, base: ARRAY OF CHAR): BOOLEAN;
VAR ta, tb: Kernel.Type;
BEGIN
ASSERT((type # "") & (base # ""), 20);
ta := ThisDesc(type, TRUE); tb := ThisDesc(base, FALSE);
IF (ta # NIL) & (tb # NIL) THEN RETURN ta.base[tb.id DIV 16 MOD 16] = tb
ELSE RETURN FALSE
END
END Extends;
PROCEDURE Level* (IN type: ARRAY OF CHAR): INTEGER;
VAR t: Kernel.Type;
BEGIN
t := ThisDesc(type, TRUE);
RETURN t.id DIV 16 MOD 16
END Level;
PROCEDURE TypeLevel* (IN rec: ANYREC): INTEGER;
VAR t: Kernel.Type;
BEGIN
t := Kernel.TypeOf(rec);
IF t = NIL THEN RETURN -1
ELSE RETURN t.id DIV 16 MOD 16
END
END TypeLevel;
PROCEDURE AdrOf* (IN rec: ANYREC): INTEGER;
BEGIN
RETURN SYSTEM.ADR(rec)
END AdrOf;
PROCEDURE Collect*;
BEGIN
Kernel.FastCollect
END Collect;
PROCEDURE Init;
VAR h: StdHook;
BEGIN
NEW(h); actionHook := h
END Init;
BEGIN
Init
END Services.