(**********************************************************************

    :Program.    IDCMP.mod
    :Contents.   Intuition Direct Communication Message Port handler
    :Author.     Nicolas Benezan [bne]
    :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
    :Phone.      711/333679
    :Copyright.  Public Domain
    :Language.   Modula-2
    :Translator. M2Amiga AMSoft
    :Imports.    Exceptions, TaskMemory [bne]
    :History.    V1.1a [bne] 23.Oct.1988
    :History.    V2.0d [bne] 19.Apr.1989 (+ InstallHandler() )
    :History.    V2.1a [bne] 22.Jul.1989 (bug in Scheduler() fixed)
    :History.    V2.2a [bne] 22.Jul.1989 (+ Window/ModifyIDCMP)
    :History.    V2.3a [bne] 23.Jul.1989 (+ IDCMPHandlerData)

**********************************************************************)

IMPLEMENTATION MODULE IDCMP;

FROM Arts       IMPORT Assert;
FROM Exceptions IMPORT HandlerNodePtr, InstallExcept, RemoveExcept,
                InstallHandler, RemoveHandler, ScheduleHandlers,
                CommonMask, InitTaskExceptions, HandlerProc;
FROM Exec       IMPORT WaitPort, GetMsg, ReplyMsg, PutMsg, MsgPort, Byte,
                MsgPortPtr, NodeType, Forbid, Permit, CopyMemQuick, List,
                Wait, Signal;
FROM ExecSupport IMPORT CreatePort, DeletePort, NewList;
FROM InputEvent IMPORT QualifierSet;
FROM Intuition  IMPORT IntuiMessagePtr, IDCMPFlagSet, IDCMPFlags,
                       WindowPtr, ModifyIDCMP;
FROM SYSTEM     IMPORT ADR, ADDRESS, SHIFT, CAST, LONGSET;
FROM TaskMemory IMPORT Allocate, Deallocate;

TYPE
  IDCMPSchedule=POINTER TO IDCMPScheduleRecord;
  ScheduleRecordPtr=POINTER TO ScheduleRecord;
  ScheduleRecord=RECORD
    handlerList: List;
    input: MsgPortPtr;
    output: MsgPortPtr;
    scheduler: HandlerNodePtr;
    message: IntuiMessagePtr;
  END;
  IDCMPScheduleRecord=RECORD
    window: WindowPtr;
    activeFlags: IDCMPFlagSet;
    immedSchedule: ScheduleRecord;
    taskSchedule: ScheduleRecord;
  END;
  IDCMPHandler=HandlerNodePtr;

VAR
  ScheduleList: List;

PROCEDURE FlagSet2Flags(Flags:IDCMPFlagSet):IDCMPFlags;
  CONST
    Flag0=VAL(IDCMPFlags,0);
  VAR
    Class: IDCMPFlags;
  BEGIN
    Class:=Flag0;
    WHILE NOT(Flag0 IN Flags) DO
      Flags:=CAST(IDCMPFlagSet, SHIFT(CAST(LONGCARD, Flags), -1));
      INC(Class);
    END;
    RETURN Class;
  END FlagSet2Flags;

PROCEDURE EmptyIDCMP(IDCMPort:MsgPortPtr);
  VAR
    Message:IntuiMessagePtr;
  BEGIN
    LOOP
      Message:=GetMsg(IDCMPort);
      IF Message=NIL THEN
        EXIT
      END;
      ReplyMsg(Message);
    END;
  END EmptyIDCMP;

PROCEDURE ActiveFlags(Schedule: IDCMPSchedule): IDCMPFlagSet;
  BEGIN
    RETURN Schedule^.activeFlags;
  END ActiveFlags;

PROCEDURE Scheduler(Signals: LONGSET;
                    DataPtr: ADDRESS): BOOLEAN;
  VAR
    SchedulePtr: ScheduleRecordPtr;
  BEGIN
    SchedulePtr:=DataPtr;
    WITH SchedulePtr^ DO
      LOOP
        message:=GetMsg(input);
        IF message=NIL THEN
          RETURN TRUE;
        END;
        IF NOT ScheduleHandlers(handlerList,
                                CAST(LONGSET, message^.class))
           OR (output=NIL) THEN
          ReplyMsg(message);
        ELSE
          PutMsg(output, message);
        END;
      END;
    END;
  END Scheduler;

PROCEDURE InitScheduler(    Window: WindowPtr;
                        VAR IDCMPort: MsgPortPtr;
                        VAR Schedule: IDCMPSchedule): BOOLEAN;
  BEGIN
    IDCMPort:=Window^.userPort;
    Assert(IDCMPort#NIL, ADR("Window has no IDCMP"));
    IDCMPAllocProc(Schedule, SIZE(Schedule^));
    IF Schedule#NIL THEN
      WITH Schedule^ DO
        window:=Window;
        activeFlags:=IDCMPFlagSet{lonelyMessage};
        ModifyIDCMP(window, activeFlags);
        WITH immedSchedule DO
          NewList(ADR(handlerList));
          input:=IDCMPort;
          output:=CreatePort(NIL, 0);
          IF output#NIL THEN
            IDCMPort:=output;
            Forbid;
            scheduler:=InstallExcept(Scheduler, LONGSET{input^.sigBit},
                                     ADR(immedSchedule), 0);
            IF scheduler#NIL THEN
              WITH taskSchedule DO
                NewList(ADR(handlerList));
                input:=IDCMPort;
                output:=NIL;
                scheduler:=InstallHandler(ScheduleList, Scheduler,
                                          LONGSET{input^.sigBit},
                                          ADR(taskSchedule), 0);
                IF scheduler#NIL THEN
                  Permit;
                  RETURN TRUE
                END;
              END; (* WITH taskSchedule *)
              RemoveExcept(scheduler);
            END; (* IF immedSchedule.scheduler#NIL *)
            Permit;
            DeletePort(output);
          END; (* IF output#NIL *)
        END; (* WITH immedSchedule *)
      END; (* WITH Schedule *)
      IDCMPDeallocProc(Schedule);
    END; (* IF Schedule#NIL *)
    RETURN FALSE
  END InitScheduler;

PROCEDURE DiscardScheduler(    Schedule:IDCMPSchedule;
                           VAR IDCMPort:MsgPortPtr);
  BEGIN
    Forbid;
    WITH Schedule^ DO
      WITH taskSchedule DO
        EmptyIDCMP(input);
        DeletePort(input);
        RemoveHandler(scheduler);
      END;
      WITH immedSchedule DO
        IDCMPort:=input;
        RemoveExcept(scheduler);
      END;
    END;
    Permit;
    IDCMPDeallocProc(Schedule);
  END DiscardScheduler;

PROCEDURE InstallIDCMPHandler(    Schedule: IDCMPSchedule;
                                  Proc: IDCMPHandlerProc;
                                  SensitiveFlags: IDCMPFlagSet;
                                  Priority: Byte;
                                  Flags: HandlerFlagSet;
                                  UserData: ADDRESS;
                              VAR Handler: IDCMPHandler): BOOLEAN;
  VAR
    SchedulePtr: ScheduleRecordPtr;
    DataPtr: IDCMPHandlerDataPtr;
  BEGIN
    IDCMPAllocProc(DataPtr, SIZE(IDCMPHandlerData));
    IF DataPtr#NIL THEN
      WITH Schedule^ DO
        activeFlags:=activeFlags+SensitiveFlags;
        WITH DataPtr^ DO
          userData:=UserData;
          IF immediate IN Flags THEN
            SchedulePtr:=ADR(immedSchedule);
            msgPtrPtr:=ADR(immedSchedule.message);
          ELSE
            SchedulePtr:=ADR(taskSchedule);
            msgPtrPtr:=ADR(taskSchedule.message);
          END;
        END;
        WITH SchedulePtr^ DO
          Handler:=CAST(IDCMPHandler,
                        InstallHandler(handlerList,
                                       CAST(HandlerProc, Proc),
                                       CAST(LONGSET, SensitiveFlags),
                                       DataPtr, Priority));
        END;
        IF Handler#NIL THEN
          ModifyIDCMP(window, activeFlags);
          RETURN TRUE
        END;
      END;
      IDCMPDeallocProc(DataPtr);
    END;
    RETURN FALSE
  END InstallIDCMPHandler;

PROCEDURE RemoveIDCMPHandler(Schedule: IDCMPSchedule;
                             Handler: IDCMPHandler);
  VAR
    HandlerPtr: HandlerNodePtr;
    DataPtr: IDCMPHandlerDataPtr;
  BEGIN
    HandlerPtr:=CAST(HandlerNodePtr, Handler);
    DataPtr:=HandlerPtr^.userData;
    RemoveHandler(HandlerPtr);
    WITH Schedule^ DO
      activeFlags:=CAST(IDCMPFlagSet, CommonMask(immedSchedule.handlerList)
                                     +CommonMask(taskSchedule.handlerList))
                   + IDCMPFlagSet{lonelyMessage};
      ModifyIDCMP(window, activeFlags);
    END;
    IDCMPDeallocProc(DataPtr);
  END RemoveIDCMPHandler;

PROCEDURE ScheduleIDCMPHandlers;
  VAR
    SignalMask,RcvdSignals:LONGSET;
  BEGIN
    SignalMask:=CommonMask(ScheduleList);
    REPEAT
      RcvdSignals:=Wait(SignalMask);
    UNTIL NOT ScheduleHandlers(ScheduleList,RcvdSignals);
  END ScheduleIDCMPHandlers;

BEGIN
  IDCMPAllocProc:=Allocate;
  IDCMPDeallocProc:=Deallocate;
  NewList(ADR(ScheduleList));
  Assert(InitTaskExceptions(),ADR("IDCMP: InitExcept failed"));
END IDCMP.