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

    :Program.  	 MemSystem.mod
    :Contents.	 Lowlevel System Support
    :Author.   	 Nicolas Benezan [bne]
    :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
    :Phone.      711/333679
    :Copyright.  Public Domain
    :Language. 	 Modula-2
    :Translator. M2Amiga AMSoft
    :Imports.	 IntuiStruct 1.0 [bne]
    :History.	 V1.0b [bne] 17.06.88 (pre-version, private)
    :History.	 V1.1d [bne] 09.07.88 (+ TaskMem)
    :History.	 V1.1e [bne] 28.10.88 (Bug corrected)
    :Remark.	 works with CLI now !
    
**********************************************************************)

IMPLEMENTATION MODULE MemSystem;

FROM Exec	IMPORT AvailMem,MemReqSet,MemReqs,Forbid,Permit,
		AddHead,Remove,MemList,MemEntry,Node,List,AllocEntry,
                FreeEntry,TaskPtr,FindTask;
FROM ExecSupport IMPORT NewList;
FROM Arts	IMPORT Assert,Terminate,CurrentLevel,TermProcedure,
		wbStarted;
FROM Intuition	IMPORT IDCMPFlagSet,IntuiText,AutoRequest;
FROM Graphics	IMPORT jam1;
FROM IntuiStruct IMPORT StructText;
FROM SYSTEM	IMPORT ADR,ADDRESS;

CONST	NoIDCMP=IDCMPFlagSet{};
        StdMinMem=20*1024;
        StdHysteresis=30*1024;
        ReqWidth=320;
        ReqHeight=72;
        ThisTask=NIL;
        CHIP=MemReqSet{chip,memClear};
        ANY=MemReqSet{memClear};
        NodeName="MemSystemEntry";

TYPE	TaskMemEntry=RECORD
	  memList:MemList;
          memEntry:MemEntry;
        END;
        TaskMemEntryPtr=POINTER TO TaskMemEntry;

VAR	Header,Body,Positive,Negative:IntuiText;

PROCEDURE YesNoRequest(BodyText,PositiveText,NegativeText:ADDRESS;
	PosFlags:IDCMPFlagSet;VAR Answer:BOOLEAN);
BEGIN
  Body.iText:=BodyText;
  Positive.iText:=PositiveText;
  Negative.iText:=NegativeText;
  Answer:=AutoRequest(Window,ADR(Header),ADR(Positive),ADR(Negative),
  	PosFlags,NoIDCMP,ReqWidth,ReqHeight);
END YesNoRequest;

PROCEDURE DeallocTaskMem(VAR Pointer:ADDRESS);
VAR	Task:TaskPtr;
	EntryPtr:TaskMemEntryPtr;
BEGIN
  Task:=FindTask(ThisTask);
  EntryPtr:=ADDRESS(Task^.memEntry.head);
  WHILE (EntryPtr^.memList.node.succ#NIL)
     AND((EntryPtr^.memEntry.addr#Pointer)
      OR(EntryPtr^.memList.numEntries#1)) DO
    EntryPtr:=ADDRESS(EntryPtr^.memList.node.succ);
  END;
  Assert(EntryPtr^.memList.node.succ#NIL,ADR("can't Free() free Memory"));
  Remove(ADDRESS(EntryPtr));
  FreeEntry(ADDRESS(EntryPtr));
  Pointer:=NIL;
END DeallocTaskMem;

PROCEDURE AllocTaskMem(VAR Pointer:ADDRESS;Size:LONGINT;Reqs:MemReqSet);
VAR	Task:TaskPtr;
	Entry:TaskMemEntry;
        EntryPtr:TaskMemEntryPtr;
	Retry:BOOLEAN;

  PROCEDURE LowMemWarning;
  BEGIN
    YesNoRequest(ADR("Low memory warning"),ADR(RETRY),ADR(CANCEL),NoIDCMP,
    	Retry);
  END LowMemWarning;

BEGIN
  REPEAT
    Forbid;
    Task:=FindTask(ThisTask);
    WITH Entry DO
      memList.numEntries:=1;
      memEntry.reqs:=Reqs;
      memEntry.length:=Size;
    END;
    EntryPtr:=ADDRESS(AllocEntry(ADR(Entry)));
    IF LONGINT(EntryPtr)<0 THEN
      Pointer:=NIL;
    ELSE
      Pointer:=EntryPtr^.memEntry.addr;
      EntryPtr^.memList.node.name:=ADR(NodeName);
      AddHead(ADR(Task^.memEntry),ADDRESS(EntryPtr));
    END;
    IF Pointer=NIL THEN
      Permit;
      LowMemWarning;
    ELSIF AvailMem(MemReqSet{chip,largest})<minMemory THEN
      DeallocTaskMem(Pointer);
      Permit;
      LowMemWarning;
    ELSE
      Permit;
    END;
  UNTIL (Pointer#NIL)OR NOT Retry;
END AllocTaskMem;

PROCEDURE DiscardHeap;
VAR	Task:TaskPtr;
	EntryPtr,NextEntryPtr:TaskMemEntryPtr;
BEGIN
  Forbid;
  Task:=FindTask(ThisTask);
  EntryPtr:=ADDRESS(Task^.memEntry.head);
  WHILE EntryPtr#NIL DO
    NextEntryPtr:=ADDRESS(EntryPtr^.memList.node.succ);
    IF EntryPtr^.memList.node.name=ADR(NodeName) THEN
      Remove(ADDRESS(EntryPtr));
      FreeEntry(ADDRESS(EntryPtr));
    END;
    EntryPtr:=NextEntryPtr;
  END;
  Permit;
END DiscardHeap;

PROCEDURE Allocate(VAR Pointer:ADDRESS;Size:LONGINT);
BEGIN
  AllocTaskMem(Pointer,Size,ANY);
END Allocate;

PROCEDURE AllocMem(VAR Pointer:ADDRESS;Size:LONGINT;Chip:BOOLEAN);
VAR	ChipReq:MemReqSet;
BEGIN
  IF Chip THEN
    ChipReq:=CHIP;
  ELSE
    ChipReq:=ANY;
  END;
  AllocTaskMem(Pointer,Size,ChipReq);
END AllocMem;

PROCEDURE Deallocate(VAR Pointer:ADDRESS);
BEGIN
  DeallocTaskMem(Pointer);
END Deallocate;

PROCEDURE ExitQuiet;
BEGIN
  Terminate(CurrentLevel());
END ExitQuiet;

PROCEDURE RecoverableExit(ReqBody,PosText,NegText:ADDRESS);
VAR	recover:BOOLEAN;
BEGIN
  YesNoRequest(ReqBody,PosText,NegText,NoIDCMP,recover);
  IF NOT recover THEN
    ExitQuiet;
  END;
END RecoverableExit;

PROCEDURE DeadEndExit(ReqBody:ADDRESS);
VAR	Dummy:BOOLEAN;
BEGIN
  Body.iText:=ReqBody;
  Negative.iText:=ADR(CANCEL);
  Dummy:=AutoRequest(Window,ADR(Header),NIL,ADR(Negative),
  	NoIDCMP,NoIDCMP,ReqWidth,ReqHeight);
  ExitQuiet;
END DeadEndExit;

BEGIN
  minMemory:=StdMinMem;
  Hysteresis:=StdHysteresis;
  Window:=NIL;
  ErrHeader:="Modula-2 MemSystem";
  StructText(Header,0,1,jam1,15,5,ADR(ErrHeader),ADR(Body));
  StructText(Body,0,1,jam1,15,15,NIL,NIL);
  StructText(Positive,0,1,jam1,6,3,NIL,NIL);
  StructText(Negative,0,1,jam1,6,3,NIL,NIL);
  IF NOT wbStarted THEN
    TermProcedure(DiscardHeap);
  END;
END MemSystem.