(* Release 3.00 *)

(* Copyright (C) 1987..1991 Jensen & Partners International *)

(*# call(seg_name=>null) *)
(*# name(prefix=>c) *)
(*# module(implementation=>off) *)
(*# check(stack=>off,
          index=>off,
          range=>off,
          overflow=>off,
          nil_ptr=>off) *)

IMPLEMENTATION MODULE PMD;

(*%F _OS2 *)
IMPORT Str, CoreSig, CoreIO, CorePMD, CoreMain;
(*%E *)
(*%T _OS2 *)
IMPORT Str, Dos, CoreSig, CoreIO, CorePMD, CoreMain;
(*%E *)

TYPE SegHeader = RECORD
        frame: CARDINAL;
        SegSize: CARDINAL;
        FilePos: LONGCARD;
        BucketSizes: ARRAY [0..15] OF CARDINAL;
     END;

(*%T _OS2 *)
    SelInfo = RECORD
        selector, size: CARDINAL;
    END;

CONST
    MAX_SELS = 256;
VAR
    selectors: ARRAY [0..MAX_SELS] OF SelInfo;
(*%E *)

CONST
    ErrMsg ="Runtime Error - Creating PM_DUMP.$$$";

(*%T _OS2 *)
PROCEDURE Os2Write(handle: CARDINAL; buffer: FarADDRESS; count: CARDINAL): CARDINAL;

VAR
    NumWrit: CARDINAL;
BEGIN
    IF Dos.Write(handle, buffer, count, NumWrit) = 0 THEN
        RETURN NumWrit;
    END;
    RETURN MAX(CARDINAL);
END Os2Write;

PROCEDURE GetSelectors(): CARDINAL;

VAR
    CurSel: CARDINAL;
    attempt, size: CARDINAL;
BEGIN
    CurSel:=0;
    attempt:=0FH;
    WHILE attempt # 0FFFFH DO
        size := CorePMD.lsl(attempt);
        IF size # 0 THEN
            selectors[CurSel].size:=size+1;
            selectors[CurSel].selector:=attempt;
            INC(CurSel);
            IF CurSel = MAX_SELS THEN
                RETURN CurSel;
            END;
        END;
        INC(attempt, 10H);
    END;
    attempt:=07H;
    WHILE attempt # 0FFF7H DO
        size := CorePMD.lsl(attempt);
        IF size # 0 THEN
            selectors[CurSel].size:=size+1;
            selectors[CurSel].selector:=attempt;
            INC(CurSel);
            IF CurSel = MAX_SELS THEN
                RETURN CurSel;
            END;
        END;
        INC(attempt, 10H);
    END;
    RETURN CurSel;
END GetSelectors;

PROCEDURE WriteStruct(VAR State: ProcessState; fh: INTEGER): INTEGER;

BEGIN
    IF Os2Write(fh, FarADR(State), SIZE(ProcessState)) # SIZE(ProcessState) THEN
        RETURN -1;
    END;
    RETURN 0;
END WriteStruct;
(*%E *)

(*%F _OS2 *)
PROCEDURE WriteStruct(VAR State: ProcessState; fh: INTEGER): INTEGER;

BEGIN
    IF CoreIO._write(fh, ADR(State), SIZE(ProcessState)) # SIZE(ProcessState) THEN
        RETURN -1;
    END;
    RETURN 0;
END WriteStruct;
(*%E *)

PROCEDURE compress(VAR header: SegHeader; fh: INTEGER): INTEGER;

VAR
    SegSize: LONGINT;
    offset: CARDINAL;
    OutSize, BucketNo, BucketSize, NumWritize, NumWrit: CARDINAL;
BEGIN
    SegSize:= LONGCARD(header.SegSize);
    IF SegSize = 0 THEN
        SegSize:=10000H;
    END;
    offset:=0;
    BucketNo:=0;
    WHILE SegSize > 0 DO
        IF SegSize > 1000H THEN
            OutSize:=1000H;
        ELSE
            OutSize:= CARDINAL(SegSize);
        END;
        BucketSize:= CorePMD._Pack(OutSize, [header.frame: offset]);
        header.BucketSizes[BucketNo]:=BucketSize;
(*%F _OS2 *)
        IF CoreIO._dos_write(fh, FarADR(CorePMD._p), BucketSize, NumWrit) # 0 THEN
(*%E *)
(*%T _OS2 *)
        IF Os2Write(fh, FarADR(CorePMD._p), BucketSize) # BucketSize THEN
(*%E *)
            RETURN -1;
        END;
        DEC(SegSize, 1000H);
        INC(offset, 1000H);
        INC(BucketNo);
    END;
    RETURN 0;
END compress;

(*%F _OS2 *)
PROCEDURE WriteCore(fh: INTEGER; top, bottom: CARDINAL);

VAR
    h: SegHeader;
    TotalParas: CARDINAL;
    Segment: CARDINAL;
    SegTotal: CARDINAL;
    SegNum: CARDINAL;
    NumToWrite: CARDINAL;
BEGIN
    Segment:=bottom;
    SegNum:=0;
    TotalParas:=top-bottom;
    SegTotal:=(TotalParas+0FFFH) DIV 01000H;
    IF CoreIO.lseek(fh, LONGCARD((SIZE(ProcessState)+SIZE(CARDINAL)+(SIZE(SegHeader)*SegTotal))-1), 0) # 0 THEN END;
    CoreIO._write(fh, ADR(Segment), 1);
    LOOP
        IF TotalParas = 0 THEN EXIT END;
        h.frame:=Segment;
        IF TotalParas < 1000H THEN
            NumToWrite:=TotalParas
        ELSE
            NumToWrite:= 1000H;
        END;
        h.SegSize:=NumToWrite<<4;
        h.FilePos:=CoreIO.lseek(fh, 0, 2);
        IF compress(h, fh) = -1 THEN
            SegTotal:=0;
            EXIT;
        END;
        IF CoreIO.lseek(fh, LONGCARD(SIZE(ProcessState)+SIZE(CARDINAL)+SIZE(SegHeader)*SegNum), 0) # 0 THEN END;
        INC(SegNum);
        CoreIO._write(fh, ADR(h), SIZE(SegHeader));
        INC(Segment, NumToWrite);
        DEC(TotalParas, NumToWrite);
    END;
    IF CoreIO.lseek(fh, (SIZE(ProcessState)), 0) # 0 THEN END;
    CoreIO._write(fh, ADR(SegTotal), SIZE(CARDINAL));
    RETURN;
END WriteCore;

PROCEDURE _PMDbody(VAR state: ProcessState);

TYPE
    A2 = ARRAY [0..1] OF CHAR;
VAR
    fh: INTEGER;
    Ln: A2;
BEGIN
    Ln[0]:= CHAR(0DH);
    Ln[1]:= CHAR(0AH); (* NB *)
    IF CoreMain._argc # 0 THEN
        Str.Copy(state.ProgName, CoreMain._argv[0]^);
    END;
    fh:=CoreIO._creat_trunc("PM_DUMP.$$$", 0);
    IF fh >= 0 THEN
        IF CoreIO._write(2, ADR(ErrMsg), Str.Length(ErrMsg)) # 0 THEN END;
        IF CoreIO._write(2, ADR(Ln), 2) # 0 THEN END;
        IF WriteStruct(state, fh) = 0 THEN
            WriteCore(fh, state.TopLim, state.PSP);
        END;
        IF CoreIO._close(fh) # 0 THEN END;
    END;
    RETURN;
END _PMDbody;
(*%E *)

(*%T _OS2 *)
PROCEDURE WriteCore(fh: INTEGER);

VAR
    h: SegHeader;
    Segment, SegTotal: CARDINAL;

BEGIN
    Segment:=0;
    SegTotal:=GetSelectors();
    IF CoreIO.lseek(fh, LONGCARD((SIZE(ProcessState)+SIZE(CARDINAL)+(SIZE(SegHeader)*SegTotal))-1), 0) # 0 THEN END;
    IF Os2Write(fh, FarADR(Segment), 1) # 0 THEN END;
    LOOP
        IF Segment = SegTotal THEN EXIT END;
        h.frame:=selectors[Segment].selector;
        h.SegSize:=selectors[Segment].size;
        h.FilePos:=CoreIO.lseek(fh, 0, 2);
        IF compress(h, fh) = -1 THEN
            SegTotal:=0;
            EXIT;
        END;
        IF CoreIO.lseek(fh, LONGCARD(SIZE(ProcessState)+SIZE(CARDINAL)+SIZE(SegHeader)*Segment), 0) # 0 THEN END;
        IF Os2Write(fh, FarADR(h), SIZE(SegHeader)) # 0 THEN END;
        INC(Segment);
    END;
    IF CoreIO.lseek(fh, (SIZE(ProcessState)), 0) # 0 THEN END;
    IF Os2Write(fh, FarADR(SegTotal), SIZE(CARDINAL)) # 0 THEN END;
    RETURN;
END WriteCore;

PROCEDURE _PMDbody(VAR state: ProcessState);

TYPE
    A2 = ARRAY [0..1] OF CHAR;
VAR
    fh: CARDINAL;
    action: CARDINAL;
    Ln: A2;
BEGIN
    Ln[0]:= CHAR(0DH);
    Ln[1]:= CHAR(0AH); (* NB *)
    IF CoreMain._argc # 0 THEN
        Str.Copy(state.ProgName, CoreMain._argv[0]^);
    END;
    IF Dos.Open("PM_DUMP.$$$", fh, action, LONGCARD(0),
                0, 012H, 012H, LONGCARD(0)) = 0 THEN
        IF Os2Write(2, FarADR(ErrMsg), Str.Length(ErrMsg)) # 0 THEN END;
        IF Os2Write(2, FarADR(Ln), 2) # 0 THEN END;
        IF WriteStruct(state, fh) = 0 THEN
            WriteCore(fh);
        END;
        IF CoreIO._close(fh) # 0 THEN END;
    END;
    RETURN;
END _PMDbody;
(*%E *)

PROCEDURE UserFatalError(ErrorCode: CARDINAL);

BEGIN
    CoreSig._FatalError(CoreSig._FatalErrorPos(), ErrorCode);
END UserFatalError;


BEGIN
    includePMD:=1;
END PMD.