MODULE SystemGeneration;  (* Ch. Jacobi, HH. Naegeli *)

 (* Version of 23.1.80 *)
 (* last modification 18.03.81*)

  FROM SYSTEM IMPORT WORD, ADR;
  FROM Files IMPORT Create,Lookup,ReadBlock,WriteBlock,
             Close,Release,FileName;
  FROM TTIO IMPORT Read, Write, WriteString, WriteLn;
  FROM FileNames IMPORT ReadFileName, typedfields;
  IMPORT PDP11;

 CONST NWordsBitMap = 10B; (* length of bit map (in words) *)

 VAR LastUsableAddressValue: CARDINAL; 

 TYPE 
  FlagType = (EntryPointFlag,CodeFlag,LinkerTableFlag,
              DebuggerTableFlag,OldLoadKeyFlag,NewLoadKeyFlag,
              FirstFreeLocFlag,OldFirstFreeLocFlag,
              MaxFlag); (* to be deleted in M15 *)

  FlagSet = SET OF FlagType;

 VAR
  ch: CHAR;
  EntryPoint[40B],StackStart[42B],JobStatus[44B],
  HighMemoryMark[50B]: CARDINAL;
  BitMap[360B]: ARRAY [1..NWordsBitMap] OF CARDINAL;
  RTS[400B]: ARRAY [1..1] OF CARDINAL;
  SystemEntryPointValue,FirstFreeLoc,SystemLoadKeyValue,
  InitEntryPointValue,RTSEnd: CARDINAL;
  modFile, rtsFile: FileName;

 
  PROCEDURE Halt(l: ARRAY OF CHAR);
  BEGIN
    WriteString(" ---- ");
    WriteString(l);
    WriteLn;
    HALT
  END Halt;

  PROCEDURE ReadOct(VAR i: WORD);
    VAR num : CARDINAL;
        ch : CHAR;
  BEGIN
    LOOP
      Read(ch);
      WHILE ch = ' ' DO Write(ch); Read(ch) END;
      num := 0;
      IF ch = 15C THEN (* default value *)
        Write('0');
      ELSE
        WHILE (ch >= '0') AND (ch <= '7') AND (num <= 17777B) DO
          num := num * 10B + (ORD(ch) - ORD('0'));
          Write(ch);
          Read(ch);
        END;
      END;
      IF ch = 15C THEN
        WriteLn;
        i := WORD(num);
        EXIT;
      END;
      (* error in input *)
      WHILE ch <> 15C DO Read(ch) END;
      Write('?');
    END; (* LOOP *)
  END ReadOct;

MODULE Reader;

 IMPORT Halt,Lookup,ReadBlock,Release,RTS,RTSEnd,WriteString,WriteLn,
  EntryPoint,InitEntryPointValue,BitMap,NWordsBitMap,
  ReadFileName,typedfields,
  Read, modFile, rtsFile, LastUsableAddressValue, ReadOct, WORD, ADR;
 
 EXPORT OpenRead,OpenRTSRead,StartRead,ReadWord,ReadAndCheck,
  ReadRTSWord,Eof,CloseRead;

 CONST File = 5;
  BuffLast = 255;

 VAR Buffer: ARRAY [0..BuffLast] OF WORD; BlockNr,LastRTSBlockNr: CARDINAL;
  BuffLength,Index,Limit,Reply: INTEGER; Checksum: CARDINAL;
  
  PROCEDURE OpenRead;
    VAR c: CHAR;
  BEGIN
    WriteString(" Stack start address"); WriteLn;
    WriteString(" (or 0 for default: 131000B) > ");
    ReadOct(LastUsableAddressValue);
    IF LastUsableAddressValue=0 THEN
      LastUsableAddressValue := 131000B
    END;
    LOOP
      WriteString(" Modula-2 program load file > ");
      ReadFileName(modFile,"DK MOD   LOD");
      REPEAT Read(c) UNTIL c=15C;
      WriteLn;
      IF typedfields * {0..2} = {} THEN (* no file name *)
        WriteString(" ---- no default file");
        WriteLn;
      ELSE
        Lookup(File,modFile,Reply);
        IF Reply > 0 THEN
          EXIT;
        ELSE
          WriteString(" ---- file not found"); WriteLn;
          Release(File);
        END;
      END;
    END; (* LOOP *)
    StartRead;
  END OpenRead;

  PROCEDURE OpenRTSRead;
    VAR i: CARDINAL; c: CHAR;
  BEGIN 
    LOOP
      WriteString(" RTS save file (default: SY:RTS.M2S) > ");
      ReadFileName(rtsFile, "DK RTS   SAV");
      REPEAT Read(c) UNTIL c=15C;
      IF typedfields * {0..2} = {} THEN (* default name *)
        rtsFile := "SY RTS   M2S";
        WriteString("SY:RTS.M2S");
      END;
      WriteLn;
      Lookup(File, rtsFile, Reply);
      IF Reply > 0 THEN
        EXIT;
      ELSE
        WriteString(" ---- file not found"); WriteLn;
        Release(File);
      END;
    END; (* LOOP *)
    BlockNr := 0; ReadRTSSector;
    InitEntryPointValue := CARDINAL(Buffer[ADR(EntryPoint) DIV 2]);
    FindRTSEnd;
    FOR i := 1 TO ADR(RTS) DIV CARDINAL(2*BuffLength) DO
      ReadRTSSector;
    END;
    Index := ADR(RTS) DIV 2 MOD CARDINAL(BuffLength);
  END OpenRTSRead;

 PROCEDURE FindRTSEnd;
  VAR Pattern,i,p: CARDINAL;

   PROCEDURE NextPattern;
    BEGIN Pattern := Pattern DIV 2;
     IF Pattern = 0 THEN Pattern := 100000B;
     ELSIF Pattern = 200B THEN INC(p);
     END;
    END NextPattern;

  BEGIN
   Pattern := 200B; p := ADR(BitMap) DIV 2;
   FOR i := 0 TO NWordsBitMap*16-1 DO
    IF BITSET(Pattern)*BITSET(Buffer[p]) # {} THEN
     LastRTSBlockNr := i;
    END;
    NextPattern;
   END;
   RTSEnd := (LastRTSBlockNr+1)*CARDINAL(2*BuffLength) -2;
  END FindRTSEnd;

 PROCEDURE StartRead;
  BEGIN BlockNr := 0; Checksum := 0; ReadSector;
  END StartRead;

 PROCEDURE ReadSector;
  BEGIN ReadBlock(File,ADR(Buffer),BlockNr,BuffLength,Limit);
   INC(BlockNr); Index := 0;
   IF Limit < BuffLength THEN Limit := 0;
   ELSE Limit := INTEGER(Buffer[BuffLast]);
   END;
  END ReadSector;

 PROCEDURE ReadRTSSector;
  BEGIN ReadBlock(File,ADR(Buffer),BlockNr,BuffLength,Limit);
   IF Limit < BuffLength THEN
    Halt("EOF reached on .SAV input file");
   END;
   INC(BlockNr); Index := 0;
  END ReadRTSSector;

 PROCEDURE ReadWord(VAR fWord: WORD);
  BEGIN fWord := Buffer[Index]; INC(Index);
   IF (Index=Limit) AND (Limit=BuffLast) THEN ReadSector END;
   (*$T-*) INC(Checksum,CARDINAL(fWord)); (*$T=*)
  END ReadWord;

 PROCEDURE ReadAndCheck;
  BEGIN
   IF Checksum # CARDINAL(Buffer[Index]) THEN
    Halt("Checksum error on .LOD input file");
   END;
   INC(Index);
   IF (Index=Limit) AND (Limit=BuffLast) THEN ReadSector END;
  END ReadAndCheck;

 PROCEDURE ReadRTSWord(VAR fWord: WORD);
  BEGIN
   fWord := Buffer[Index]; INC(Index);
   IF (Index=Limit) AND (BlockNr<=LastRTSBlockNr) THEN ReadRTSSector END;
  END ReadRTSWord;

 PROCEDURE Eof(): BOOLEAN;
  BEGIN RETURN Index>=Limit;
  END Eof;

 PROCEDURE CloseRead;
  BEGIN Release(File);
  END CloseRead;

 BEGIN BuffLength := BuffLast+1;
END Reader;

(*---------------------------------------------------------------------*)

MODULE Writer;
 FROM PDP11 IMPORT InitialStart, LoaderInfo;
 IMPORT Halt, WORD, ADR,
  LastUsableAddressValue,
  HighMemoryMark,FirstFreeLoc,EntryPoint,
  SystemLoadKeyValue,
  StackStart,JobStatus,
  BitMap,NWordsBitMap,InitEntryPointValue,
  SystemEntryPointValue,Create,ReadBlock,WriteBlock,
  Close, modFile;

 EXPORT OpenWrite,StartWrite,WriteZeroBlock,WriteWord,EndWrite,
  WriteCommunicationArea,CloseWrite;

 CONST File = 6;
  BuffLast = 255;

 VAR Buffer: ARRAY [0..BuffLast] OF CARDINAL; BlockNr,LastInitBlockNr: CARDINAL;
  BuffLength,Index,Limit,Reply: INTEGER;
  CurrAddress: CARDINAL;

 PROCEDURE OpenWrite;
  BEGIN
   modFile[9]  := "S";
   modFile[10] := "A";
   modFile[11] := "V";
   Create(File,modFile,Reply);
   IF Reply < 0 THEN Halt(".SAV file not created") END;
  END OpenWrite;

 PROCEDURE WriteZeroBlock;
  VAR LastCodeBlockNr,Pattern,Limit,p,i: CARDINAL;
  BEGIN
   BlockNr := 0;
   FOR i := 0 TO BuffLast DO Buffer[i] := 0 END;
   Buffer[ADR(StackStart) DIV 2] := LastUsableAddressValue;
   Buffer[ADR(JobStatus) DIV 2] := CARDINAL({12,14});
   Buffer[ADR(HighMemoryMark) DIV 2] := LastUsableAddressValue+2;
   p := ADR(BitMap) DIV 2; Limit := p + NWordsBitMap;
   LastCodeBlockNr := (FirstFreeLoc-1) DIV CARDINAL(2*BuffLength);
   Pattern := 200B;
   FOR i := 0 TO LastCodeBlockNr DO
    IF p >= Limit THEN
     Halt("Attempt to write over end of bit map");
    END;
    INC(Buffer[p],Pattern); Pattern := Pattern DIV 2;
    IF Pattern = 0 THEN Pattern := 100000B;
    ELSIF Pattern = 200B THEN INC(p);
    END;
   END;
   WriteSector;
   LastInitBlockNr := 0;
  END WriteZeroBlock;

 PROCEDURE StartWrite(fWhere: CARDINAL);
  VAR i: CARDINAL;
  BEGIN
   BlockNr := fWhere DIV CARDINAL(2*BuffLength);
   Index := fWhere DIV 2 MOD CARDINAL(BuffLength);
   IF LastInitBlockNr < BlockNr THEN
    REPEAT
     FOR i := 0 TO BuffLast DO Buffer[i] := 0 END; INC(LastInitBlockNr);
     IF LastInitBlockNr < BlockNr THEN
      WriteBlock(File,ADR(Buffer),LastInitBlockNr,BuffLength,Limit);
      IF Limit < BuffLength THEN
        Halt("Not enough space on .SAV output file");
      END;
     END;
    UNTIL LastInitBlockNr = BlockNr;
   ELSE
    ReadBlock(File,ADR(Buffer),BlockNr,BuffLength,Limit);
    IF Limit < BuffLength THEN
      Halt("EOF reached on .LOD input file");
    END;
   END;
  END StartWrite;

 PROCEDURE WriteSector;
  BEGIN
   WriteBlock(File,ADR(Buffer),BlockNr,BuffLength,Limit);
   IF Limit < BuffLength THEN 
      Halt("write at EOF on .SAV output file") END;
   INC(BlockNr); Index := 0;
  END WriteSector;

 PROCEDURE WriteWord(fWord: WORD);
  VAR i: CARDINAL;
  BEGIN
   IF CARDINAL(fWord) # 0 THEN
    IF Buffer[Index] # 0 THEN
      Halt("Both parts of system try to occupy same location");
    END;
    Buffer[Index] := CARDINAL(fWord);
   END;
   INC(Index);
   IF Index = BuffLength THEN
    WriteSector; 
    IF LastInitBlockNr < BlockNr THEN
     FOR i := 0 TO BuffLast DO Buffer[i] := 0 END; INC(LastInitBlockNr);
    ELSE
     ReadBlock(File,ADR(Buffer),BlockNr,BuffLength,Limit);
     IF Limit < BuffLength THEN Halt("EOF reached on .SAV input file") END;
    END;
   END;
  END WriteWord;

 PROCEDURE EndWrite;
  BEGIN
   WriteSector;
  END EndWrite;

 PROCEDURE WriteCommunicationArea;
  BEGIN
   StartWrite(ADR(InitialStart.Entry));
   WriteWord(SystemEntryPointValue);
   EndWrite;
   StartWrite(ADR(InitialStart.StackBottom));
   WriteWord(LastUsableAddressValue);
   EndWrite;
   StartWrite(ADR(InitialStart.StackLimit));
   WriteWord(FirstFreeLoc);
   EndWrite;
   StartWrite(ADR(LoaderInfo));
   WriteWord(SystemLoadKeyValue);
   EndWrite;
  END WriteCommunicationArea;

 PROCEDURE CloseWrite;
  BEGIN Close(File);
  END CloseWrite;

 BEGIN BuffLength := BuffLast + 1;
END Writer;

(*--------------------------------------------------------------------*)

MODULE Transfer;

 IMPORT RTS,ReadWord,ReadRTSWord,Eof,WriteWord,EntryPoint,
  InitEntryPointValue,StartWrite,EndWrite,Halt, WORD, ADR;

 EXPORT TransferRecord,SkipRecord,MergeRTS;

 PROCEDURE TransferRecord(fNWords,fWhere: CARDINAL);
  VAR x: WORD; i: CARDINAL;
  BEGIN
   StartWrite(fWhere);
   FOR i := 1 TO fNWords DO
    ReadWord(x); WriteWord(x);
   END;
   EndWrite;
  END TransferRecord;

 PROCEDURE SkipRecord(fNWords: CARDINAL);
  VAR i: CARDINAL; x: WORD;
  BEGIN
   FOR i := 1 TO fNWords DO ReadWord(x) END;
  END SkipRecord;

 PROCEDURE MergeRTS;
  VAR i,x: CARDINAL;
  BEGIN 
   StartWrite(ADR(EntryPoint));
   WriteWord(InitEntryPointValue);
   EndWrite;
   StartWrite(ADR(RTS));
   WHILE NOT Eof() DO
    ReadRTSWord(x); WriteWord(x);
   END;
   EndWrite;
  END MergeRTS;

END Transfer;

(*---------------------------------------------------------------------*)

VAR
 Found: FlagSet; Flag: FlagType;
 Where,Cardinal,NBytes,i,x: CARDINAL;
BEGIN
 OpenRead;
 Found := FlagSet{};
 WHILE NOT Eof() DO
  ReadWord(x); Flag := FlagType(x); ReadWord(NBytes); ReadWord(Cardinal);
  IF Flag >= MaxFlag THEN Halt(".LOD file has wrong format") END;
  INCL(Found,Flag);
  CASE Flag OF
   EntryPointFlag: SystemEntryPointValue := Cardinal;
  |NewLoadKeyFlag: SystemLoadKeyValue := Cardinal;
  |FirstFreeLocFlag: FirstFreeLoc := Cardinal;
  ELSE (* nothing to do *)
  END;
  SkipRecord((NBytes-6) DIV 2);
  ReadAndCheck;
 END;
 IF NOT (EntryPointFlag IN Found) THEN
  Halt("No entry point block found on .LOD file");
 END;
 IF NOT (NewLoadKeyFlag IN Found) THEN
  Halt("No new key block found on .LOD file");
 END;
 IF NOT (FirstFreeLocFlag IN Found) THEN
  Halt("No first free loc block found on .LOD file");
 END;
 StartRead; OpenWrite;
 WriteZeroBlock;
 WHILE NOT Eof() DO
  ReadWord(x); Flag := FlagType(x); ReadWord(NBytes); ReadWord(Where);
  IF Flag = CodeFlag THEN
   TransferRecord((NBytes-6) DIV 2, Where);
  ELSE SkipRecord((NBytes-6) DIV 2);
  END;
  ReadAndCheck;
 END;
 TransferRecord(0,FirstFreeLoc-1);
 CloseRead;
 OpenRTSRead; MergeRTS; CloseRead;
 WriteCommunicationArea;
 CloseWrite;
 WriteString("end system generation ");
 WriteLn;
END SystemGeneration.