IMPLEMENTATION MODULE EVENT ; (************************************************************************** Environnement : SOLARIS 2.3 ------------- Programmeurs : ------------ Pierre L'Ecuyer, Denis Alain, Gaetan Perron, Jean Belanger *****************************************************************************) FROM Storage IMPORT ALLOCATE, DEALLOCATE; FROM MYINOUT IMPORT WriteString, WriteLn, Write; FROM NUM IMPORT WriteLR; FROM SIM IMPORT TimeSimul, Fin; FROM SYSTEM IMPORT ADDRESS; CONST LongName = 32; (* Long. max. de la chaine de caracteres*) (* decrivant un type d'evenement. *) TYPE EventType = POINTER TO RECORD (* Pointe sur un bloc d'informations *) (* associe a un type d'evenement. *) Proc : PROC; (* Procedure associee. *) Descriptor : ARRAY [0..LongName-1] OF CHAR (* Descripteur du type d'evenement. *) END; EventNotice = POINTER TO InfoEventNotice; (* Pointeur sur un avis d'even. *) InfoEventNotice = RECORD Type : EventType; (* Type d'evenement a executer. *) (* Dans la pile des avis libres, = NIL *) When : LONGREAL; (* Temps auquel l'evenement s'executera.*) Attributes : ADDRESS; (* Attributs de l'evenement. *) Prec, (* Pointeur vers l'evenement precedent. *) Succ : EventNotice (* Pointeur vers l'evenement suivant. *) END; VAR FreeNotices : EventNotice; (* Liste des avis d'evenements libres.*) CurrentEvent : EventNotice; (* L'avis d'evenement courant. *) FirstEvent, LastEvent : EventNotice; (* La tete et la queue de la liste *) (* d'evenements. *) Zero : LONGREAL; (* Zero en double precision *) (*****************************************************************************) PROCEDURE Error (Number : CARDINAL); BEGIN WriteString ( '***** ERROR from module EVENT, at time '); WriteLR (TimeSimul, 10, 3, 2); WriteString (' ***** ' ); WriteLn; CASE Number OF 0 : WriteString ("Trying to start the simulation while the"); WriteString (" event list is empty.") | 1 : WriteString ("Trying to schedule an event in the past.") | 2 : WriteString ("Scheduling an event whose type is not created.") | 3 : WriteString ("Trying to cancel an event notice not in the event list") | 4 : WriteString ("Refering to an event notice that does not exist.") END; WriteLn; WriteLn; HALT END Error; PROCEDURE Create ( VAR E : EventType; P : PROC; Name : ARRAY OF CHAR ); (* Cree un type d'evenement E associe a la procedure P. *) VAR n, i : INTEGER; BEGIN NEW (E); WITH E^ DO Proc := P; n := HIGH (Name); IF n >= LongName THEN n := LongName - 1 END; FOR i := 0 TO n DO Descriptor [i] := Name [i] END; FOR i := n+1 TO LongName-1 DO Descriptor [i] := ' ' END END END Create; PROCEDURE NewNotice ( E : EventType; D : LONGREAL; Par : ADDRESS ) : EventNotice; (* Retourne un avis d'evenement pour un nouvel evenement de type E, *) (* prevu pour dans D unites de temps, avec les attributs Par. *) (* C'est evenement n'est pas encore place dans la liste. *) VAR A : EventNotice; BEGIN IF D < Zero THEN Error (1) END; (* Pas de retour dans le passe. *) IF E = NIL THEN Error (2) END; (* Type d'even. non defini. *) IF FreeNotices = NIL THEN NEW(A) (* Cree un nouvel avis d'evenement *) ELSE A := FreeNotices; (* Recupere un ancien avis *) FreeNotices := FreeNotices^.Succ END; WITH A^ DO Type := E; When := TimeSimul + D; Attributes := Par END; RETURN A END NewNotice; PROCEDURE AddNoticeNext (A : EventNotice); (* Ajoute l'avis A au tout debut de la liste d'evenements. *) VAR E : EventNotice; BEGIN A^.Prec := NIL; A^.Succ := FirstEvent; FirstEvent := A; IF LastEvent = NIL THEN LastEvent := A ELSE A^.Succ^.Prec := A END END AddNoticeNext; PROCEDURE AddNotice (A : EventNotice); (* Ajoute l'avis A dans la liste d'evenements, selon l'instant d'occurence *) VAR E : EventNotice; (* L'avis d'even. qui precedera A dans la liste. *) BEGIN E := LastEvent; (* Recherche a partir de la fin. *) WITH A^ DO IF E = NIL THEN (* La liste d'evenements est vide. *) FirstEvent := A; LastEvent := A; Succ := NIL; Prec := NIL ELSE WHILE (( E # NIL ) AND ( E^.When > When )) DO (* Trouve l'endroit d'insertion *) E := E^.Prec END; IF E = NIL THEN (* Insere A au debut de la liste. *) Succ := FirstEvent; Succ^.Prec := A; FirstEvent := A; Prec := NIL ELSE (* Insere A juste apres E. *) Prec := E; Succ := E^.Succ; E^.Succ := A; IF Succ # NIL THEN Succ^.Prec := A ELSE LastEvent := A END END END END END AddNotice; PROCEDURE ScheduleNotice ( E : EventType; D : LONGREAL; Par : ADDRESS; VAR N : EventNotice ); BEGIN N := NewNotice (E, D, Par); AddNotice (N) END ScheduleNotice; PROCEDURE ScheduleNoticeNext ( E : EventType; Par : ADDRESS; VAR N : EventNotice ); BEGIN N := NewNotice (E, Zero, Par); AddNoticeNext (N) END ScheduleNoticeNext; PROCEDURE ScheduleNoticeBefore ( E : EventType; Par : ADDRESS; VAR N : EventNotice; N1 : EventNotice ); BEGIN IF N1 = NIL THEN Error (4) END; WITH N1^ DO IF Type = NIL THEN Error (4) END; N := NewNotice (E, When, Par); N^.Succ := N1; N^.Prec := Prec; IF Prec = NIL THEN FirstEvent := N ELSE Prec^.Succ := N END; Prec := N END END ScheduleNoticeBefore; PROCEDURE ScheduleNoticeAfter ( E : EventType; Par : ADDRESS; VAR N : EventNotice; N1 : EventNotice ); BEGIN IF N1 = NIL THEN Error (4) END; WITH N1^ DO IF Type = NIL THEN Error (4) END; N := NewNotice (E, When, Par); N^.Prec := N1; N^.Succ := Succ; IF Succ = NIL THEN LastEvent := N ELSE Succ^.Prec := N END; Succ := N END END ScheduleNoticeAfter; PROCEDURE FindNoticeSuchThat ( E : EventType; Cond : CondProc ) : EventNotice; VAR N : EventNotice; BEGIN N := FirstEvent; WHILE (N # NIL) AND ((N^.Type # E) OR (NOT Cond (N^.Attributes))) DO N := N^.Succ END; RETURN N END FindNoticeSuchThat; PROCEDURE CancelNotice (VAR N : EventNotice); (* Retire un avis d'evenement N de la liste d'evenements et *) (* recupere l'espace en l'inserant dans une pile *) BEGIN IF N = NIL THEN Error (4) END; WITH N^ DO Type := NIL ; IF Prec = NIL THEN FirstEvent := Succ ; ELSE Prec^.Succ := Succ END ; IF Succ = NIL THEN LastEvent := Prec ELSE Succ^.Prec := Prec END; Succ := FreeNotices (* Recuper l'espace de l'avis d'evenement*) END; FreeNotices := N; N := NIL END CancelNotice; PROCEDURE NoticeType ( N : EventNotice ) : EventType; BEGIN RETURN N^.Type END NoticeType; PROCEDURE NoticeAttrib ( N : EventNotice ) : ADDRESS; BEGIN RETURN N^.Attributes END NoticeAttrib; PROCEDURE NoticeTime ( N : EventNotice ) : LONGREAL; BEGIN RETURN N^.When END NoticeTime; PROCEDURE ScheduleNext ( E : EventType; Par : ADDRESS ); (* Place un avis d'evenement au debut de la liste d'evenements *) VAR A : EventNotice; BEGIN ScheduleNoticeNext (E, Par, A) END ScheduleNext; PROCEDURE Schedule ( E : EventType; D : LONGREAL; Par : ADDRESS ); VAR A : EventNotice; BEGIN ScheduleNotice (E, D, Par, A) END Schedule; PROCEDURE Cancel ( E : EventType; Par : ADDRESS ); VAR N : EventNotice; BEGIN N := FirstEvent; WHILE (N # NIL) AND (( N^.Type # E) OR ( N^.Attributes # Par )) DO N := N^.Succ END; IF N # NIL THEN CancelNotice (N) END END Cancel; PROCEDURE Attrib () : ADDRESS; BEGIN RETURN CurrentEvent^.Attributes END Attrib; PROCEDURE NoticeToAddress ( N : EventNotice ) : ADDRESS; BEGIN RETURN N END NoticeToAddress; PROCEDURE AddressToNotice ( N : ADDRESS ) : EventNotice; BEGIN RETURN N END AddressToNotice; PROCEDURE PrintEventList; VAR E : EventNotice ; I : CARDINAL ; BEGIN IF FirstEvent # NIL THEN E := FirstEvent ; WriteLn; WHILE (E # NIL) DO FOR I := 0 TO LongName-1 DO Write (E^.Type^.Descriptor [I]) END; WriteString (" "); WriteLR (E^.When,15,5,2); WriteLn; E := E^.Succ END; END END PrintEventList; PROCEDURE EmptyEventList; VAR E : EventNotice; BEGIN IF FirstEvent # NIL THEN E := FirstEvent ; WHILE E # NIL DO E^.Type := NIL ; E := E^.Succ END; LastEvent^.Succ := FreeNotices; FreeNotices := FirstEvent; FirstEvent := NIL; LastEvent := NIL END END EmptyEventList; PROCEDURE DeleteType (VAR E : EventType); BEGIN DISPOSE (E) END DeleteType; PROCEDURE SimLoop; BEGIN IF FirstEvent = NIL THEN Error (0) END; (* Aucun evenemment de prevu. *) WHILE NOT Fin DO IF FirstEvent = NIL THEN (* Fin normale si la liste d'evene- *) RETURN END; (* ments se vide *) CurrentEvent := FirstEvent; FirstEvent := FirstEvent^.Succ; IF FirstEvent # NIL THEN FirstEvent^.Prec := NIL (* Reajuste pointeur de liste d'even.*) ELSE LastEvent := NIL (* La liste est vide *) END; WITH CurrentEvent^ DO TimeSimul := When; Type^.Proc; (* Execution de la procedure *) Type := NIL; Succ := FreeNotices; FreeNotices := CurrentEvent ; END END END SimLoop; BEGIN FreeNotices := NIL; FirstEvent := NIL; LastEvent := NIL; CurrentEvent := NIL; Zero := 0.0 END EVENT.