(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*       VAX/VMS Implementation          *
*                                       *
*                                       *
*     MVCLi4:                           *
*                                       *
*     Linker interface in Pass 4        *
*                                       * 
*     Version 3.1 of  1-FEB-1983        *
*     Update    2 of 12-JUL-1983        *
*                                       *
*     Based on PDP11 Implementation     *
*     Version M22 of 25.02.81           *
*                                       *
*     Institut fuer Informatik          *
*     ETH-Zentrum                       *
*     CH-8092 Zuerich                   *
*                                       *
****************************************)

(****************************************
* Updates:                              *
* - - - - - - - - - - - - - - - - - - - *
* Nr.  1 of  7-APR-1983 by M. Mall      *
*  Correct error in vector table psect  *
*  generation.                          *
* - - - - - - - - - - - - - - - - - - - *
* Nr.  2 of 12-JUL-1983 by M. Mall      *
*  Correct error in length computation  *
*  for object records.                  *
****************************************)

IMPLEMENTATION MODULE MVCLi4; (* PDP-11            : A. Gorrengourt *)
                              (* VAX-11            : M. Mall        *)
                              (* VAX-11 object code: E. Kisicki     *)

  IMPORT SYSTEM, MVCompiler, MVCPublic, MVCIO4, MVCMnemonicsAndTraps,
         MVCDebug, MVCLs4, LinkerDefinitions, DateTime, Storage;
  FROM SYSTEM IMPORT BYTE;
  FROM MVCompiler IMPORT Idptr, Stringptr, Idset, Idclass, Spellix,
                         mainmodp, sysmodp, globvarnext, stringcount,
                         stringroot, spelltab;
  FROM MVCIO4 IMPORT PutByte, Assert, CompError, Error;
  FROM MVCMnemonicsAndTraps IMPORT Traps;
  FROM Storage IMPORT DEALLOCATE;

  CONST
    maximalSymbolSize = 31;
    maximalCodeSize = 128;

  TYPE
    SymbolSize = [0..maximalSymbolSize];
    SymbolArray = [0..maximalSymbolSize-1];
    SymbolName = ARRAY SymbolArray OF CHAR;

  VAR
    nameLength: CARDINAL;

  PROCEDURE IndexName(findex: CARDINAL;
                      foldnam: ARRAY OF CHAR;
                      VAR fnewnam: ARRAY OF CHAR);

    VAR
      lx, ln: CARDINAL;
      num: ARRAY [0..2] OF CHAR;

  BEGIN
    ln := 0;
    num[0] := CHAR(((findex MOD 1000) DIV 100) + ORD("0"));
    num[1] := CHAR(((findex MOD 100 ) DIV 10 ) + ORD("0"));
    num[2] := CHAR(((findex MOD 10  )        ) + ORD("0"));
    fnewnam[0] := "$";
    IF num[0] <> "0" THEN
      INC(ln);
      fnewnam[ln] := num[0];
    END;
    IF num[1] <> "0" THEN
      INC(ln);
      fnewnam[ln] := num[1];
    END;
    INC(ln);
    fnewnam[ln] := num[2];
    fnewnam[ln+1] := "$";
    FOR lx := 0 TO LEN(foldnam)-1 DO
      IF lx+ln+2 < maximalSymbolSize THEN
        fnewnam[lx+ln+2] := foldnam[lx];
      END;
    END;
    IF LEN(foldnam)+ln+2 < maximalSymbolSize THEN
      fnewnam[LEN(foldnam)+ln+2] := 0C;
    END;
  END IndexName;

  PROCEDURE PutControlledString(fstring: ARRAY OF CHAR;
                                flength: CARDINAL;
                                fsymbol: BOOLEAN);

    VAR
      k: CARDINAL;

  BEGIN
    k := 0;
    WHILE k < flength DO
      IF fsymbol AND (fstring[k] >= "a") THEN
        PutByte(CAP(fstring[k]))
      ELSE PutByte(fstring[k])
      END;
      INC(k)
    END
  END PutControlledString;

  PROCEDURE PutString(fstring: ARRAY OF CHAR);

  BEGIN
    PutControlledString(fstring,LEN(fstring),FALSE)
  END PutString;

  PROCEDURE PutName(fstring: ARRAY OF CHAR);

    VAR
      l: SymbolSize;

  BEGIN
    l := LEN(fstring);
    IF l > 0 THEN
      IF l > maximalSymbolSize THEN
        l := maximalSymbolSize
      END;
      PutByte(l);
      PutControlledString(fstring,l,TRUE)
    ELSE Error(404)
    END;
    nameLength := CARDINAL(l)
  END PutName;

  PROCEDURE Put2Names(fstring1, fstring2: ARRAY OF CHAR);

    VAR
      l, l1, l2: SymbolSize;

  BEGIN
    l1 := LEN(fstring1);
    l2 := LEN(fstring2);
    IF (l1 > 0) AND (l2 > 0) THEN
      IF l1 + l2 + 1 <= maximalSymbolSize THEN
        l := l1 + l2 + 1;
      ELSE 
        IF l1 > maximalSymbolSize DIV 2 THEN
          l := maximalSymbolSize DIV 2;
        ELSE l := l1;
        END;
        l1 := l;
        INC(l);
        IF l2 > maximalSymbolSize DIV 2 THEN
          INC(l,maximalSymbolSize DIV 2);
          l2 := maximalSymbolSize DIV 2
        ELSE 
          INC(l,l2);
        END
      END;
      PutByte(l);
      PutControlledString(fstring1,l1,TRUE);
      PutByte(".");
      PutControlledString(fstring2,l2,TRUE)
    ELSE Error(404)
    END;
    nameLength := CARDINAL(l)
  END Put2Names;

  PROCEDURE SearchSpellTable(fname: Spellix; VAR fstring: ARRAY OF CHAR);

    VAR
      k: CARDINAL;

  BEGIN
    k := 0;
    LOOP
      fstring[k] := spelltab[fname+k];
      IF fstring[k] = " " THEN
        fstring[k] := 0C;
        EXIT
      END;
      IF k = HIGH(fstring) THEN
        EXIT
      END;
      INC(k);
    END
  END SearchSpellTable;

  MODULE LinkerTableHandling;

    FROM MVCMnemonicsAndTraps IMPORT Traps;
    FROM MVCIO4 IMPORT line, firstsy, printlc;
    IMPORT Idptr, mainmodp, Error, Assert, LinkerDirective,
           LinkerTableEntry;

    EXPORT EnterVariable, EnterConstant, EnterSystemData,
           EnterExternal, EnterProcedure, EnterModule, EnterRuntimeSupport,
           EnterLabel, EnterLine, GetLabel, GetLine, CorrectLine,
           UpdateLinkerTable, ResetLinkerTable, NextRelocationPoint;

    CONST
      maximalLinkerTableSize = 300;

    TYPE
      LinkerTableSize = [0..maximalLinkerTableSize];

    VAR
      linkerTable: ARRAY LinkerTableSize OF LinkerTableEntry;
      topOfLinkerTable, actualLinkerTableEntry: CARDINAL;
      labelTable: ARRAY LinkerTableSize OF CARDINAL;
      topOfLabelTable: CARDINAL;
      lineTable: ARRAY LinkerTableSize OF RECORD
                                            linelc: CARDINAL;
                                            linenr: CARDINAL;
                                          END;
      topOfLineTable, actualLine: CARDINAL;
      lastlc: CARDINAL;

    PROCEDURE NextRelocationPoint(VAR flr: LinkerTableEntry): BOOLEAN;

    BEGIN
      IF actualLinkerTableEntry < topOfLinkerTable THEN
        flr := linkerTable[actualLinkerTableEntry];
        INC(actualLinkerTableEntry);
        RETURN TRUE;
      END;
      actualLinkerTableEntry := 0;
      RETURN FALSE;
    END NextRelocationPoint;

    PROCEDURE EnterVariable(flp: CARDINAL; fnptr: Idptr);

    BEGIN
      IF topOfLinkerTable > maximalLinkerTableSize THEN
        Error(404);
        topOfLinkerTable := 0;
      END;
      WITH linkerTable[topOfLinkerTable] DO
        linkpoint := flp;
        dir := RefLocVariable;
        nptr := fnptr;
      END;
      INC(topOfLinkerTable);
    END EnterVariable;

    PROCEDURE EnterConstant(flp: CARDINAL);

    BEGIN
      IF topOfLinkerTable > maximalLinkerTableSize THEN
        Error(404);
        topOfLinkerTable := 0
      END;
      WITH linkerTable[topOfLinkerTable] DO
        linkpoint := flp;
        dir := RefLocConstant;
      END;
      INC(topOfLinkerTable);
    END EnterConstant;

    PROCEDURE EnterSystemData(flp: CARDINAL);

    BEGIN
      IF topOfLinkerTable > maximalLinkerTableSize THEN
        Error(404);
        topOfLinkerTable := 0
      END;
      WITH linkerTable[topOfLinkerTable] DO
        linkpoint := flp;
        dir := RefSystemData;
      END;
      INC(topOfLinkerTable);
    END EnterSystemData;

    PROCEDURE EnterRuntimeSupport(flp: CARDINAL; ftrap: Traps);

    BEGIN
      IF topOfLinkerTable > maximalLinkerTableSize THEN
        Error(404);
        topOfLinkerTable := 0
      END;
      WITH linkerTable[topOfLinkerTable] DO
        linkpoint := flp;
        dir := RefRuntimeSupport;
        trap := ftrap;
      END;
      INC(topOfLinkerTable)
    END EnterRuntimeSupport;

    PROCEDURE EnterExternal(flp: CARDINAL; fnptr: Idptr);

    BEGIN
      IF topOfLinkerTable > maximalLinkerTableSize THEN
        Error(404);
        topOfLinkerTable := 0
      END;
      WITH linkerTable[topOfLinkerTable] DO
        linkpoint := flp;
        dir := RefExtVariable;
        nptr := fnptr;
        nptr^.globmodp^.used := TRUE;
      END;
      INC(topOfLinkerTable)
    END EnterExternal;

    PROCEDURE EnterProcedure(flp: CARDINAL; fprocix: Idptr);

    BEGIN
      IF topOfLinkerTable > maximalLinkerTableSize THEN
        Error(404);
        topOfLinkerTable := 0
      END;
      WITH linkerTable[topOfLinkerTable] DO
        linkpoint := flp;
        IF fprocix^.globmodp = mainmodp THEN
          dir := RefLocProc;
        ELSE dir := RefExtProc;
          fprocix^.used := TRUE;
        END;
        procix := fprocix;
      END;
      INC(topOfLinkerTable);
    END EnterProcedure;

    PROCEDURE EnterModule(flp: CARDINAL; fscmodp: Idptr);

    BEGIN
      IF topOfLinkerTable > maximalLinkerTableSize THEN
        Error(404);
        topOfLinkerTable := 0
      END;
      WITH linkerTable[topOfLinkerTable] DO
        linkpoint := flp;
        dir := RefExtMod;
        modix := fscmodp;
      END;
      INC(topOfLinkerTable);
    END EnterModule;

    PROCEDURE EnterLabel(flp: CARDINAL);

    BEGIN
      IF topOfLabelTable <= maximalLinkerTableSize THEN
        labelTable[topOfLabelTable] := flp;
        INC(topOfLabelTable);
      END;
    END EnterLabel;

    PROCEDURE EnterLine;

    BEGIN
      WITH lineTable[topOfLineTable-1] DO
        IF (linenr < line) THEN
          IF (linelc < printlc) THEN
            lineTable[topOfLineTable].linelc := printlc;
            lineTable[topOfLineTable].linenr := line;
            IF topOfLineTable < maximalLinkerTableSize THEN
              INC(topOfLineTable);
            END;
          ELSIF (printlc = 0) AND (linelc = printlc) THEN
            linenr := line;
          END;
        END;
      END;
    END EnterLine;

    PROCEDURE UpdateLine (flc, delta: CARDINAL);

      VAR
        k: CARDINAL;

    BEGIN
      k := topOfLineTable-1;
      WHILE (k > 0) AND (lineTable[k].linelc >= flc) DO
        INC(lineTable[k].linelc,delta);
        DEC(k);
      END;
    END UpdateLine;

    PROCEDURE CorrectLine;

    BEGIN
      IF firstsy THEN
        WITH lineTable[topOfLineTable-1] DO
          IF linenr < line THEN
            EnterLine;
          ELSIF (linelc < printlc) AND (linenr = line) THEN
            linelc := printlc;
          END;
        END;
      END;
    END CorrectLine;

    PROCEDURE GetLabel(flp: CARDINAL; VAR lab: CARDINAL): BOOLEAN;

    BEGIN
      lab := 0;
      WHILE lab < topOfLabelTable DO
        IF labelTable[lab] = flp THEN
          INC(lab);
          RETURN TRUE;
        ELSE INC(lab);
        END;
      END;
      RETURN FALSE;
    END GetLabel;

    PROCEDURE GetLine(VAR flp: CARDINAL; VAR line: CARDINAL): BOOLEAN;

    BEGIN
      IF actualLine < topOfLineTable THEN
        flp := lineTable[actualLine].linelc;
        line := lineTable[actualLine].linenr;
        INC(actualLine);
        RETURN TRUE;
      END;
      actualLine := 0;
      RETURN FALSE;
    END GetLine;

    PROCEDURE UpdateLinkerTable(initlc, delta: CARDINAL);

      VAR
        k: CARDINAL;

    BEGIN
      k := topOfLinkerTable;
      WHILE k > 0 DO
        DEC(k);
        WITH linkerTable[k] DO
          IF linkpoint >= initlc THEN
            INC(linkpoint,delta)
          END
        END
      END;
      k := topOfLabelTable;
      WHILE k > 0 DO
        DEC(k);
        IF labelTable[k] >= initlc THEN
          INC(labelTable[k],delta)
        END
      END;
      UpdateLine(initlc, delta);
    END UpdateLinkerTable;

    PROCEDURE ResetLinkerTable;

    BEGIN
      topOfLinkerTable := 0;
      actualLinkerTableEntry := 0;
      topOfLabelTable := 0;
      lineTable[0].linenr := line;
      lineTable[0].linelc := 0;
      topOfLineTable := 1;
      actualLine := 0;
    END ResetLinkerTable;

  BEGIN (* LinkerTableHandling *)
    ResetLinkerTable;
    lineTable[0].linenr := 0;
    topOfLineTable := 1;
  END LinkerTableHandling;

  MODULE DataToLinker;

    FROM SYSTEM IMPORT BYTE;
    FROM MVCompiler IMPORT Spellix, spelltab;
    FROM MVCPublic IMPORT MVCompilerVersion, Compilerstatus, source,
                          comptime, compstat;
    FROM MVCIO4 IMPORT PutByte, PutShortWord, PutWord, PutRecord, CompError;
    FROM MVCMnemonicsAndTraps IMPORT Mnemos, Traps;
    FROM MVCDebug IMPORT PutProcedureStart, PutProcedureEnd,
                         PutModuleStart, PutModuleEnd,
                         PutSourceFileCorrelation;
    FROM MVCLs4 IMPORT WriteHeader, WriteObjectCode, WriteTrailer;
    FROM LinkerDefinitions IMPORT DSC$K_DTYPE_Z, OBJ$C_STRLVL, OBJ$C_MAXRECSIZ,
                                  OBJ$C_, OBJ$C_TIR_, OBJ$C_HDR_, OBJ$C_GSD_,
                                  EOM$B_COMCOD, EOM$B_TFRFLG, GSY$V_,
                                  SDF$W_FLAGS, SRF$W_FLAGS, GPS$V_, ENV$V_,
                                  GPS$W_FLAGS, ENV$W_FLAGS, LEPM$W_FLAGS,
                                  IDC$W_FLAGS, EOM$V_,
                                  EPM$W_FLAGS, IDC$V_;
    FROM DateTime IMPORT ConvertTime;
    FROM LinkerTableHandling IMPORT NextRelocationPoint, ResetLinkerTable;

    IMPORT maximalSymbolSize, SymbolName, LinkerDirective, LinkerTableEntry,
           Idptr, Stringptr, Idset, Idclass, maximalCodeSize,
           mainmodp, sysmodp, globvarnext, stringcount, stringroot,
           nameLength, DEALLOCATE, Error, SearchSpellTable, PutName, Put2Names,
           IndexName, PutString, PutControlledString, Assert;

    EXPORT StartProcedure, PutObjectCode, TerminateObjectFile, StartObjectFile;

    CONST
      vectorTableEntrySize = 8;
      maximalVectorTableSize = 255;
      (* averageRelocationSize = 40; *) (*!U2!*)
      systemDataLength = 4;

      GPS$B_ALIGN = 2;

    TYPE
      Psects = (variablePsect, constantPsect, codePsect, vectorTablePsect);
      setOfTraps = SET OF Traps;
      VectorTableSize = [0..maximalVectorTableSize];
      VectorTableEntry = RECORD
                           mask: ARRAY [0..1] OF BYTE;
                           entrypoint: CARDINAL;
                           used: BOOLEAN;
                         END;

    VAR
      topOfVectorTable: VectorTableSize;
      psectLength: ARRAY Psects OF CARDINAL;
      vectorTable: ARRAY VectorTableSize OF VectorTableEntry;
      trapSet: setOfTraps;
      psect: Psects;

    PROCEDURE StartProcedure(fidptr: Idptr);

    BEGIN
      PutProcedureStart(fidptr);
    END StartProcedure;

    PROCEDURE PutObjectCode(VAR fctab: ARRAY OF BYTE;
                                flc: CARDINAL;
                                fpfmp: Idptr);

      VAR
        i, k, l: CARDINAL;
        linkrec: LinkerTableEntry;
        relocation: BOOLEAN;
        newName, bodyName, moduleName: SymbolName;

      PROCEDURE DefineSymbols;

      BEGIN
        WITH fpfmp^ DO
          IF procnum > maximalVectorTableSize THEN
            Error(404)
          ELSE 
            WITH vectorTable[procnum] DO
              mask[0] := fctab[0];
              mask[1] := fctab[1];
              entrypoint := psectLength[codePsect];
              used := TRUE;
              IF procnum > topOfVectorTable THEN
                topOfVectorTable := procnum;
              END;
            END;
          END;
          IF used AND NOT externalaccess THEN
            PutByte(OBJ$C_GSD);
            SearchSpellTable(name,bodyName);
            SearchSpellTable(globmodp^.name,moduleName);
            PutByte(GSD$C_EPM);
            PutByte(DSC$K_DTYPE_Z);
            PutShortWord(EPM$W_FLAGS{GSY$V_WEAK,GSY$V_DEF,GSY$V_REL});
            PutByte(codePsect);
            PutWord(psectLength[codePsect]);
            PutByte(fctab[0]);
            PutByte(fctab[1]);
            IndexName(procnum,bodyName,newName);
            Put2Names(moduleName,newName);
            PutRecord;
          END;
        END;
      END DefineSymbols;

      PROCEDURE PutImmediateCode(fi: CARDINAL);

      BEGIN
        INC(l,fi+1);
        IF l > OBJ$C_MAXRECSIZ THEN
          PutRecord;
          PutByte(OBJ$C_TIR);
          l := fi+2
        END;
        PutByte(-INTEGER(fi));
        WHILE fi > 0 DO
          PutByte(fctab[k]);
          INC(k);
          DEC(fi);
        END;
      END PutImmediateCode;

      PROCEDURE WordValue(): CARDINAL;

        VAR
          template: RECORD
                      CASE BOOLEAN OF
                        FALSE: c: CARDINAL; |
                        TRUE: b1,b2,b3,b4: BYTE
                      END
                    END;

      BEGIN
        WITH template DO
          b1 := fctab[k];
          b2 := fctab[k+1];
          b3 := fctab[k+2];
          b4 := fctab[k+3]
        END;
        RETURN template.c
      END WordValue;

      PROCEDURE WritePsectRef (psect: Psects; offset: CARDINAL);

      BEGIN
        IF offset <= 7FH THEN
          PutByte(TIR$C_STA_PB);
          PutByte(psect);
          PutByte(offset);
          INC(l,4);
        ELSIF offset <= 7FFFH THEN
          PutByte(TIR$C_STA_PW);
          PutByte(psect);
          PutShortWord(offset);
          INC(l,5);
        ELSE 
          PutByte(TIR$C_STA_PL);
          PutByte(psect);
          PutWord(offset);
          INC(l,7);
        END;
        PutByte(TIR$C_STO_PICR);
        INC(k,4);
      END WritePsectRef;

      PROCEDURE WriteAddOffsetRef (offset: CARDINAL);

      BEGIN
        IF offset <= 0FFH THEN
          PutByte(TIR$C_STA_UB);
          PutByte(offset);
          INC(l,4);
        ELSIF offset <= 0FFFFH THEN
          PutByte(TIR$C_STA_UW);
          PutShortWord(offset);
          INC(l,5);
        ELSE 
          PutByte(TIR$C_STA_LW);
          PutWord(offset);
          INC(l,7);
        END;
        PutByte(TIR$C_OPR_ADD);
        PutByte(TIR$C_STO_PICR);
        INC(k,4);
      END WriteAddOffsetRef;

    BEGIN
      k := 0;
      l := 1;
      DefineSymbols;
      PutByte(OBJ$C_TIR);
      IF psectLength[codePsect] = 0 THEN
        PutByte(TIR$C_STA_PB);
        PutByte(codePsect);
        PutByte(0 (* <== offset *) );
        PutByte(TIR$C_CTL_SETRB);
        INC(l,4);
      END;
      relocation := NextRelocationPoint(linkrec);
      WHILE k < flc DO
        IF relocation THEN
          i := linkrec.linkpoint - k - 1
        ELSE i := flc - k
        END;
        WHILE i > 0 DO
          IF i > maximalCodeSize THEN
            PutImmediateCode(maximalCodeSize);
            DEC(i,maximalCodeSize)
          ELSE 
            PutImmediateCode(i);
            i := 0
          END
        END;
        IF relocation THEN
          INC(k);
          IF l + maximalSymbolSize + 3 > OBJ$C_MAXRECSIZ THEN (*!U2!*)
            PutRecord;
            PutByte(OBJ$C_TIR);
            l := 1
          END;
          WITH linkrec DO
            CASE dir OF
              RefLocVariable : 
                WritePsectRef(variablePsect, WordValue() + systemDataLength); |
              RefLocConstant : 
                WritePsectRef(constantPsect, WordValue()); |
              RefSystemData : 
                WritePsectRef(variablePsect, WordValue()); |
              RefRuntimeSupport : 
                PutByte(TIR$C_STA_GBL);
                INCL(trapSet,trap);
                CASE trap OF
                  IllegalPointerError, IndexError, FunctionReturnError,
                  HaltCode : 
                    PutName("LIB$SIGNAL"); |
                  NewProcessCode : 
                    PutName("MOD$NEWPROCESS"); |
                  TransferCode : 
                    PutName("MOD$TRANSFER");
                END;
                PutByte(TIR$C_STO_PICR);
                INC(l,nameLength+3);
                INC(k,4); |
              RefExtVariable : 
                WITH nptr^.globmodp^ DO
                  PutByte(TIR$C_STA_GBL);
                  IF NOT foreign THEN
                    SearchSpellTable(name,moduleName);
                    Put2Names(moduleName,"$data$");
                    INC(l,nameLength+2);
                    WriteAddOffsetRef(WordValue() + systemDataLength);
                  ELSE 
                    SearchSpellTable(nptr^.name,moduleName);
                    PutName(moduleName);
                    INC(l,nameLength+2);
                    WriteAddOffsetRef(WordValue() - nptr^.vaddr);
                  END;
                END; |
              RefLocProc : 
                WITH procix^ DO
                  used := TRUE;
                  WITH vectorTable[procnum] DO
                    IF used THEN
                      WritePsectRef(codePsect,entrypoint);
                    ELSE 
                      PutByte(TIR$C_STA_GBL);
                      SearchSpellTable(globmodp^.name,moduleName);
                      SearchSpellTable(name,bodyName);
                      IF externalaccess THEN
                        Put2Names(moduleName,bodyName);
                      ELSE 
                        IndexName(procnum,bodyName,newName);
                        Put2Names(moduleName,newName);
                      END;
                      PutByte(TIR$C_STO_PICR);
                      INC(l,nameLength+3);
                      INC(k,4);
                    END;
                  END;
                END; |
              RefExtProc : 
                WITH procix^ DO
                  PutByte(TIR$C_STA_GBL);
                  SearchSpellTable(globmodp^.name,moduleName);
                  SearchSpellTable(name,bodyName);
                  IF globmodp^.foreign THEN
                    PutName(bodyName);
                  ELSE Put2Names(moduleName,bodyName);
                  END;
                  PutByte(TIR$C_STO_PICR);
                  INC(l,nameLength+3);
                  INC(k,4);
                END; |
              RefExtMod : 
                WITH modix^ DO
                  PutByte(TIR$C_STA_GBL);
                  SearchSpellTable(name,moduleName);
                  PutName(moduleName);
                  PutByte(TIR$C_STO_PICR);
                  INC(l,nameLength+3);
                  INC(k,4);
                END;
            END; (*CASE*)
          END; (*WITH*)
          relocation := NextRelocationPoint(linkrec);
        END; (*IF relocation*)
      END;
      PutRecord;
      IF machinecodes IN compstat THEN
        WriteObjectCode(fctab,flc,fpfmp);
      END;
      PutProcedureEnd(fpfmp^.procnum,vectorTable[fpfmp^.procnum].entrypoint,
                      flc);
      ResetLinkerTable;
      INC(psectLength[codePsect],flc);
    END PutObjectCode;

    PROCEDURE PutGlobalSymbolDirectory;

      VAR
        lmodp: Idptr;
        lmodname: SymbolName;
        key: ARRAY [0..22] OF CHAR;
        len: CARDINAL;

      PROCEDURE PutImport;

        VAR
          l: CARDINAL;
          lexpp, lnxtidp: Idptr;
          lpfnam: SymbolName;

      BEGIN
        l := 0;
        IF NOT lmodp^.foreign THEN
          PutByte(OBJ$C_GSD);
          PutByte(GSD$C_SYM);
          PutByte(DSC$K_DTYPE_Z);
          PutShortWord(SRF$W_FLAGS{GSY$V_REL});
          PutName(lmodname);
          INC(l,nameLength+6);
          IF lmodp^.used  THEN
            PutByte(GSD$C_SYM);
            PutByte(DSC$K_DTYPE_Z);
            PutShortWord(SRF$W_FLAGS{GSY$V_REL});
            Put2Names(lmodname,"$data$");
            INC(l,nameLength+5);
          END;
          PutByte(GSD$C_IDC);
          PutShortWord(IDC$W_FLAGS{IDC$V_ERRSEV_2});
          Put2Names(lmodname,"$key$");
          INC(l,nameLength+4);
          ConvertTime(lmodp^.modulekey,key); 
          PutName(key);
          INC(l,nameLength+1);
          Put2Names(lmodname,"$key$");
          INC(l,nameLength+1);
        END;
        lexpp := lmodp^.expp;
        WHILE lexpp <> NIL DO
          WITH lexpp^ DO
            IF klass = indrct THEN
              lnxtidp := nxtidp
            ELSE lnxtidp := lexpp
            END;
            WITH lnxtidp^ DO
              IF (klass IN Idset{pures,funcs}) AND used OR
                 (klass = vars) AND lmodp^.foreign THEN
                IF l + maximalSymbolSize + 5 > OBJ$C_MAXRECSIZ THEN (*!U2!*)
                  PutRecord;
                  PutByte(OBJ$C_GSD);
                  l := 1;
                ELSIF l = 0 THEN
                  PutByte(OBJ$C_GSD);
                  l := 1;
                END;
                PutByte(GSD$C_SYM);
                PutByte(DSC$K_DTYPE_Z);
                PutShortWord(SRF$W_FLAGS{GSY$V_REL});
                SearchSpellTable(name,lpfnam);
                IF NOT lmodp^.foreign THEN
                  Put2Names(lmodname,lpfnam);
                ELSE
                  PutName(lpfnam);
                END;
                INC(l,nameLength+5);
              END;
            END;
            lexpp := link;
          END;
        END;
        IF l <> 0 THEN
          PutRecord
        END;
      END PutImport;

      PROCEDURE PutExport;

        VAR
          lexpp, lnxtidp: Idptr;
          l: CARDINAL;
          lpfname: SymbolName;
          firstvar: BOOLEAN;

      BEGIN
        lexpp := lmodp^.expp;
        IF lexpp <> NIL THEN
          l := 0;
          firstvar := TRUE;
          PutByte(OBJ$C_GSD);
          PutByte(GSD$C_EPM);
          PutByte(DSC$K_DTYPE_Z);
          PutShortWord(EPM$W_FLAGS{GSY$V_DEF,GSY$V_REL});
          PutByte(codePsect);
          PutWord(vectorTable[0].entrypoint);
          PutByte(vectorTable[0].mask[0]);
          PutByte(vectorTable[0].mask[1]);
          PutName(lmodname);
          INC(l,nameLength+13);
          PutByte(GSD$C_IDC);
          PutShortWord(IDC$W_FLAGS{IDC$V_ERRSEV_2});
          Put2Names(lmodname,"$key$");
          INC(l,nameLength+4);
          ConvertTime(lmodp^.modulekey,key); 
          PutName(key);
          INC(l,nameLength+1);
          Put2Names(lmodname,"$key$");
          INC(l,nameLength+1);
          WHILE lexpp <> NIL DO
            WITH lexpp^ DO
              IF klass = indrct THEN
                lnxtidp := nxtidp
              ELSE lnxtidp := lexpp
              END;
              WITH lnxtidp^ DO
                IF klass IN Idset{pures,funcs} THEN
                  IF l + maximalSymbolSize + 12 > OBJ$C_MAXRECSIZ THEN (*!U2!*)
                    PutRecord;
                    PutByte(OBJ$C_GSD);
                    l := 1;
                  ELSIF l = 0 THEN
                    PutByte(OBJ$C_GSD);
                    l := 1;
                  END;
                  PutByte(GSD$C_EPM);
                  PutByte(DSC$K_DTYPE_Z);
                  PutShortWord(EPM$W_FLAGS{GSY$V_DEF,GSY$V_REL});
                  PutByte(codePsect);
                  PutWord(vectorTable[procnum].entrypoint);
                  PutByte(vectorTable[procnum].mask[0]);
                  PutByte(vectorTable[procnum].mask[1]);
                  SearchSpellTable(name,lpfname);
                  Put2Names(lmodname,lpfname);
                  INC(l,nameLength+12);
                ELSIF (klass = vars) AND firstvar THEN
                  IF l + maximalSymbolSize + 10 > OBJ$C_MAXRECSIZ THEN (*!U2!*)
                    PutRecord;
                    PutByte(OBJ$C_GSD);
                    l := 1;
                  ELSIF l = 0 THEN
                    PutByte(OBJ$C_GSD);
                    l := 1;
                  END;
                  PutByte(GSD$C_SYM);
                  PutByte(DSC$K_DTYPE_Z);
                  PutShortWord(SDF$W_FLAGS{GSY$V_DEF,GSY$V_REL});
                  PutByte(variablePsect);
                  PutWord(0 (* <== offset *) );
                  Put2Names(lmodname,"$data$");
                  INC(l,nameLength+10);
                  firstvar := FALSE;
                END;
              END;
              lexpp := link;
            END;
          END;
          IF l <> 0 THEN
            PutRecord
          END;
        END;
      END PutExport;

    BEGIN
      lmodp := sysmodp^.link;
      WHILE lmodp <> NIL DO
        WITH lmodp^ DO
          SearchSpellTable(name,lmodname);
          IF lmodp <> mainmodp THEN
            PutImport;
          ELSE PutExport;
          END;
          lmodp := link;
        END;
      END;
    END PutGlobalSymbolDirectory;

    PROCEDURE PutHeader;

      PROCEDURE PutTimeStamp;

        VAR
          tim: ARRAY [0..16] OF CHAR;

      BEGIN
        ConvertTime(comptime,tim); 
        PutString(tim);
        PutString(tim);
      END PutTimeStamp;

      PROCEDURE PutModuleName;

        VAR
          lmodname: SymbolName;

      BEGIN
        SearchSpellTable(mainmodp^.name,lmodname);
        PutName(lmodname);
      END PutModuleName;

      PROCEDURE PutModuleIdent;

      BEGIN
        PutName("V01");
      END PutModuleIdent;

      PROCEDURE PutSubHeader(subhdr: OBJ$C_HDR_);

      BEGIN
        PutByte(MHD$C_MHD);
        PutByte(subhdr);
        CASE subhdr OF
          MHD$C_LNM : 
            PutString(MVCompilerVersion); |
          MHD$C_SRC : 
            PutString(source);
            IF NOT (checks IN compstat) THEN
              PutString("/NOCHECK")
            END;
            IF debugs   IN compstat THEN
              PutString("/DEBUG");
            END;
        END;
        PutRecord;
      END PutSubHeader;

    BEGIN (* PutHeader *)
      PutByte(MHD$C_MHD);
      PutShortWord(OBJ$C_STRLVL);
      PutShortWord(OBJ$C_MAXRECSIZ);
      PutModuleName;
      PutModuleIdent;
      PutTimeStamp;
      PutRecord;
      PutSubHeader(MHD$C_LNM);
      PutSubHeader(MHD$C_SRC);
    END PutHeader;


    PROCEDURE TerminateObjectFile;


      PROCEDURE PutVariablePsect;

      BEGIN
        PutByte(OBJ$C_TIR);
        PutByte(TIR$C_STA_PB);
        PutByte(variablePsect);
        PutByte(0 (* <== offset *) );
        PutByte(TIR$C_CTL_SETRB);
        PutByte(-1);
        PutByte(0 (* <== module initialization bit *) );
        PutRecord;
        psectLength[variablePsect] := globvarnext + systemDataLength;
      END PutVariablePsect;

      PROCEDURE PutConstantPsect;

        TYPE
          AnyString = ARRAY [0..1] OF CHAR;
          AnyStringPtr = POINTER TO AnyString;

        VAR
          chLast: CHAR;
          again: BOOLEAN;
          strp, strpOld: Stringptr;
          l, lCount: CARDINAL;

        PROCEDURE PutAnyString(astrp: AnyStringPtr);

          VAR
            si, ei, n: CARDINAL;
            ch: CHAR;

        BEGIN
          n := 0;
          (*$T-*)
          WHILE astrp^[n] <> 0C DO
            INC(n)
          END;
          (*$T=*)
          INC(n);
          IF l+n+1 > OBJ$C_MAXRECSIZ THEN
            PutRecord;
            PutByte(OBJ$C_TIR);
            l := 1
          END;
          si := 0;
          ei := n;
          WHILE ei-si > 0 DO
            IF ei-si > maximalCodeSize THEN
              PutByte(-INTEGER(maximalCodeSize))
            ELSE 
              PutByte(-INTEGER(ei))
            END;
            INC(l);
            REPEAT
              (*$T-*) ch := astrp^[si] (*$T=*);
              INC(si);
              PutByte(ch)
            UNTIL ch = 0C
          END;
          INC(lCount,n);
          INC(l,n);
          IF ODD(n) THEN
            INC(n)
          END;
          DEALLOCATE(astrp,n)
        END PutAnyString;

      BEGIN (*PutConstantPsect*)
        IF stringcount > 0 THEN
          PutByte(OBJ$C_TIR);
          PutByte(TIR$C_STA_PB);
          PutByte(constantPsect);
          PutByte(0 (* <== offset *) );
          PutByte(TIR$C_CTL_SETRB);
          l := 5;
          lCount := 0;
          again := FALSE;
          strp := stringroot;
          WHILE strp <> NIL DO
            strpOld := strp;
            WITH strp^ DO
              Assert(loadoffset = lCount);
              PutAnyString(AnyStringPtr(valentry));
              strp := slink;
            END;
            DISPOSE(strpOld);
          END;
          Assert(lCount = stringcount);
          IF l + maximalSymbolSize + 2 > OBJ$C_MAXRECSIZ THEN
            PutRecord;
            PutByte(OBJ$C_TIR);
          END;
          PutRecord;
          psectLength[constantPsect] := stringcount;
        END;
      END PutConstantPsect;

      PROCEDURE PutVectorTablePsect;

        VAR
          l: CARDINAL;
          lexpp, lnxtidp: Idptr;
          mainmodname, lpfname: SymbolName;

      BEGIN
        l := 0;
        lexpp := mainmodp^.expp;
        IF lexpp <> NIL THEN
          PutByte(OBJ$C_TIR);
          PutByte(TIR$C_STA_PB);
          PutByte(vectorTablePsect);
          PutByte(0 (* <== offset *) );
          PutByte(TIR$C_CTL_SETRB);
          SearchSpellTable(mainmodp^.name,mainmodname);
          WITH vectorTable[0] DO
            Assert(used);
            PutByte(TIR$C_OPR_REDEF);
            PutName(mainmodname);
            PutByte(TIR$C_STA_EPM);
            PutName(mainmodname);
            PutByte(TIR$C_STO_USW);
            PutByte(-1);
            PutByte(JMP);
            PutByte(TIR$C_STA_PL);
            PutByte(codePsect);
            PutWord(entrypoint+2);
            PutByte(TIR$C_STO_PICR);
          END;
          l := 1;
          WHILE lexpp <> NIL DO
            WITH lexpp^ DO
              IF klass = indrct THEN
                lnxtidp := nxtidp
              ELSE lnxtidp := lexpp
              END;
              WITH lnxtidp^ DO
                IF klass IN Idset{pures,funcs} THEN
                  IF (l MOD 6) = 5 THEN (*!U1!*)
                    PutRecord;
                    PutByte(OBJ$C_TIR);
                  END;
                  WITH vectorTable[procnum] DO
                    Assert(used);
                    SearchSpellTable(name,lpfname);
                    PutByte(TIR$C_OPR_REDEF);
                    Put2Names(mainmodname,lpfname);
                    PutByte(TIR$C_STA_EPM);
                    Put2Names(mainmodname,lpfname);
                    PutByte(TIR$C_STO_USW);
                    PutByte(-1);
                    PutByte(JMP);
                    PutByte(TIR$C_STA_PL);
                    PutByte(codePsect);
                    PutWord(entrypoint+2);
                    PutByte(TIR$C_STO_PICR);
                  END;
                  INC(l);
                END;
              END;
              lexpp := link;
            END;
          END;
          PutRecord;
        END;
        psectLength[vectorTablePsect] := l * vectorTableEntrySize;
      END PutVectorTablePsect;

      PROCEDURE DefinePsects;

      BEGIN

        PutByte(OBJ$C_GSD);

        PutByte(GSD$C_PSC);
        PutByte(GPS$B_ALIGN);
        PutShortWord(GPS$W_FLAGS{GPS$V_PIC,GPS$V_REL,GPS$V_WRT,GPS$V_RD});
        PutWord(psectLength[variablePsect]);
        PutName("modula2.$data$");

        PutByte(GSD$C_PSC);
        PutByte(GPS$B_ALIGN);
        PutShortWord(GPS$W_FLAGS{GPS$V_PIC,GPS$V_REL,GPS$V_SHR,GPS$V_RD});
        PutWord(psectLength[constantPsect]);
        PutName("modula2.$strings$");

        PutByte(GSD$C_PSC);
        PutByte(GPS$B_ALIGN);
        PutShortWord(GPS$W_FLAGS{GPS$V_PIC,GPS$V_REL,GPS$V_SHR,
                                 GPS$V_RD,GPS$V_EXE});
        PutWord(psectLength[codePsect]);
        PutName("modula2.$code$");

        PutByte(GSD$C_PSC);
        PutByte(GPS$B_ALIGN);
        PutShortWord(GPS$W_FLAGS{GPS$V_PIC,GPS$V_REL,GPS$V_SHR,
                                 GPS$V_GBL,GPS$V_RD,GPS$V_EXE});
        PutWord(psectLength[vectorTablePsect]);
        PutName("modula2.$vector$");

        PutRecord;

      END DefinePsects;

      PROCEDURE PutTrailer;

      BEGIN

        IF trapSet <> setOfTraps{} THEN
          PutByte(OBJ$C_GSD);
        END;
        IF (trapSet * setOfTraps{IndexError,
                                 IllegalPointerError,
                                 FunctionReturnError,
                                 HaltCode}) <> setOfTraps{} THEN
          PutByte(GSD$C_SYM);
          PutByte(DSC$K_DTYPE_Z);
          PutShortWord(SRF$W_FLAGS{GSY$V_REL});
          PutName("LIB$SIGNAL");
          PutByte(GSD$C_SYM);
          PutByte(DSC$K_DTYPE_Z);
          PutShortWord(SRF$W_FLAGS{GSY$V_REL});
          PutName("MODULA$_FACILITY");(* <== force loading of error messages *)
        END;
        IF NewProcessCode IN trapSet THEN
          PutByte(GSD$C_SYM);
          PutByte(DSC$K_DTYPE_Z);
          PutShortWord(SRF$W_FLAGS{GSY$V_REL});
          PutName("MOD$NEWPROCESS");
        END;
        IF TransferCode IN trapSet THEN
          PutByte(GSD$C_SYM);
          PutByte(DSC$K_DTYPE_Z);
          PutShortWord(SRF$W_FLAGS{GSY$V_REL});
          PutName("MOD$TRANSFER");
        END;
        IF trapSet <> setOfTraps{} THEN
          PutRecord;
        END;

        PutByte(OBJ$C_EOM);
        PutByte(EOM$C_SUCCES);
        IF vectorTable[mainmodp^.procnum].used THEN
          PutByte(codePsect);
          PutWord(vectorTable[mainmodp^.procnum].entrypoint);
          PutByte(EOM$B_TFRFLG{EOM$V_WKTFR});
        END;
        PutRecord;

      END PutTrailer;

    BEGIN
      IF debugs IN compstat THEN
        PutSourceFileCorrelation
      END;
      PutModuleEnd;
      PutGlobalSymbolDirectory;
      PutVariablePsect;
      PutConstantPsect;
      PutVectorTablePsect;
      DefinePsects;
      PutTrailer;
      IF machinecodes IN compstat THEN
        WriteTrailer;
      END;

    END TerminateObjectFile;

    PROCEDURE StartObjectFile;

    BEGIN

      trapSet := setOfTraps{};

      FOR topOfVectorTable := 0 TO maximalVectorTableSize DO
        vectorTable[topOfVectorTable].used := FALSE;
      END;
      topOfVectorTable := 0;

      psect := variablePsect;
      REPEAT
        psectLength[psect] := 0;
        INC(psect);
      UNTIL psect = vectorTablePsect;

      PutHeader;
      PutModuleStart;

      IF machinecodes IN compstat THEN
        WriteHeader;
      END;
    END StartObjectFile;


  END DataToLinker;

END MVCLi4.