TurboModula2/src/compiler/COMPILER.MOD

(* Renamed for readability. Semantics unchanged. Original identifiers: see docs/compiler/ + src/compiler/RENAME-MAP.md. *)
IMPLEMENTATION MODULE COMPILER;
IMPORT SCANNER, Files, SYMTAB, ERRORS, Texts, Terminal, ComLine;
FROM SYSTEM IMPORT ADR, BDOS, IORESULT; (* NOTE: ADDRESS/WORD/BYTE NOT imported here
   although used below — they come via the DEFINITION module's own SYSTEM
   import, which this compiler leaks into the implementation scope; listing
   them again is a hard error ("ADDRESS is declared twice", proven). *)
FROM STORAGE IMPORT FREEMEM;

(* $[+ remove procedure names *)

VAR 
    reserved27: RecordPtr;
    reserved28: RecordPtr;
    reserved29: RecordPtr;
    reserved30: RecordPtr;
    curScopeHead: RecordPtr;
    savedScopeHead: RecordPtr;
    baseScopeHead: RecordPtr;
    bitsetRangeDesc: RecordPtr;
    lastParamList: ArrayPtr;

(* InitCompiler/OpenSourceAndOutput are DEF-declared (no FORWARD here:
   v1.00 rejects a FORWARD duplicating a DEF declaration). *)

PROCEDURE InsertIdent(keyword: ARRAY OF CHAR; kind: CARDINAL):ADDRESS;
VAR ptr : RecordPtr;
BEGIN
  ptr := SCANNER.NewNode(kind);
  SCANNER.CopyStr(ptr^.word1, keyword);
  ptr^.word0 := curScopeHead;
  ptr^.word3 := BITSET{6}; (* was 64 *)
  curScopeHead := ptr;
  RETURN ptr
END InsertIdent;

PROCEDURE DeclConst(keyword: ARRAY OF CHAR; typeDesc: RecordPtr;
                constValue: WORD; kind:CARDINAL);
VAR ptr: RecordPtr;
BEGIN 
  ptr := InsertIdent(keyword, kind);
  ptr^.word2 := typeDesc;
  ptr^.word5 := constValue;
END DeclConst;


PROCEDURE DeclStdProc(keyword: ARRAY OF CHAR; procNo,signature: WORD);
VAR ptr: RecordPtr;
BEGIN
  ptr := InsertIdent(keyword, 5);
  ptr^.word5 := procNo;
  ptr^.high := signature;
END DeclStdProc;

PROCEDURE DeclProc(keyword: ARRAY OF CHAR; procNo: CARDINAL);
BEGIN 
  DeclStdProc(keyword, procNo, 0);
  curScopeHead^.word3 := BITSET{6,7}; (* was 192 *)
END DeclProc;


PROCEDURE DeclFunc(keyword: ARRAY OF CHAR; funcNo: CARDINAL; returnType: RecordPtr);
BEGIN 
  DeclProc(keyword, funcNo);
  curScopeHead^.word2 := returnType;
END DeclFunc;


PROCEDURE NewTypeDesc(typeSize: BITSET; typeId: CARDINAL): RecordPtr;
VAR ptr : RecordPtr;
BEGIN
  ptr := SCANNER.NewSized(typeId);
  ptr^.word3 := typeSize;
  RETURN ptr
END NewTypeDesc;


PROCEDURE DeclType(keyword: ARRAY OF CHAR; tsize: BITSET; id: CARDINAL): ADDRESS;
VAR ptr, ptr2 : RecordPtr;
BEGIN 
  ptr := InsertIdent(keyword, 3);
  ptr2:= NewTypeDesc(tsize, id);
  ptr^.word2 := ptr2;
  ptr2^.word0:= ptr;
  RETURN ptr2
END DeclType;


PROCEDURE InitOperatorTable;
  VAR opIndex: CARDINAL;

  PROCEDURE AddOperator(char1,char2: CHAR; opCode: CARDINAL);
  BEGIN
    ERRORS.opCharTable^[opIndex]   := char1;
    ERRORS.opCharTable^[opIndex+1] := char2;
    ERRORS.opCharTable^[opIndex+2] := CHR(opCode);
    INC(opIndex,3);
  END AddOperator;
BEGIN 
  SCANNER.Allocate(ERRORS.opCharTable, 27);
  opIndex := 0;
  AddOperator(':','=',27);
  AddOperator('.','.', 4);
  AddOperator('<','=',56);
  AddOperator('>','=',57);
  AddOperator('<','>',53);
  AddOperator('(','.',44);
  AddOperator('.',')', 6);
  AddOperator('(',':',45);
  AddOperator(':',')', 7);
END InitOperatorTable;

PROCEDURE InitCharClasses;
CONST DEL = 177C;
VAR chCode: CARDINAL;
    glyphs: ARRAY [0..64] OF CHAR;
    code : CARDINAL;
BEGIN 
  SCANNER.Allocate(SCANNER.charClas, 128);
  chCode := ORD('A');
  REPEAT
    SCANNER.charClas^[chCode]    := ORD(CHR(10));
    SCANNER.charClas^[chCode+32] := ORD(CHR(10));
    INC(chCode);
  UNTIL chCode > ORD('Z');
  chCode := ORD('0'); REPEAT SCANNER.charClas^[chCode] := ORD(CHR(11)); INC(chCode) UNTIL chCode > ORD('9');
  SCANNER.charClas^[ORD('!')] := ORD(CHR(8));
  SCANNER.charClas^[ORD('~')] := ORD(CHR(66));
  SCANNER.charClas^[ORD(DEL)] := ORD(CHR(4));
  SCANNER.charClas^[ORD('"')] := ORD(CHR(12));
  glyphs := " ,:. )]}|;  '                              ([{^     =#<>  +-*  /&";
  code := 0;
  REPEAT
    IF glyphs[code] <> ' ' THEN SCANNER.charClas^[ORD(glyphs[code])]:=ORD(CHR(code)) END;
    INC(code)
  UNTIL code > 64;
END InitCharClasses;

PROCEDURE InitKeywordTable; 
VAR p: POINTER TO ARRAY [0..29] OF CARDINAL;
BEGIN 
  SCANNER.Allocate(keywordTable, 30*2);
  p := keywordTable;
  p^[ 0] :=  730;
  p^[ 1] :=  731;
  p^[ 2] := 1245;
  p^[ 3] := 1206;
  p^[ 4] :=  999;
  p^[ 5] := 1258;
  p^[ 6] := 1127;
  p^[ 7] :=  708;
  p^[ 8] := 1312;
  p^[ 9] := 1234;
  p^[10] :=  979;
  p^[11] :=  990;
  p^[12] :=  991;
  p^[13] :=  747;
  p^[14] :=  257;
  p^[15] := 1248;
  p^[16] :=  993;
  p^[17] :=  304;
  p^[18] :=   49;
  p^[19] := 1229;
  p^[20] := 1230;
  p^[21] := 1231;
  p^[22] := 1236;
  p^[23] := 1024;
  p^[24] := 1281;
  p^[25] :=  770;
  p^[26] :=  772;
  p^[27] :=    0;
  p^[28] :=  195;
  p^[29] :=   80;
END InitKeywordTable;


PROCEDURE DeclarePredefinedTypes; 
VAR p : RecordPtr;
BEGIN 
  curScopeHead := baseScopeHead;
  IntType  := DeclType("INTEGER", BITSET{1}, 2);
  CharType := DeclType("CHAR", BITSET{0}, 0); CharType^.high := 255;
  BooleanType := DeclType("BOOLEAN", BITSET{0}, 0); BooleanType^.high := 1;
  CardType  := DeclType("CARDINAL", BITSET{1}, 2);
  RealType  := DeclType("REAL", BITSET{2}, 8);
  LongrealType := DeclType("LONGREAL", BITSET{3}, 8);
  BitsetType := DeclType("BITSET", BITSET{1}, 4);

  bitsetRangeDesc := NewTypeDesc(BITSET{0}, 1); bitsetRangeDesc^.word2 := CardType; bitsetRangeDesc^.high := 15;
  BitsetType^.word2 := bitsetRangeDesc;

  ProcType := DeclType("PROC", BITSET{2}, 9);
  LongintType := DeclType("LONGINT", BITSET{2}, 7);

  baseScopeHead := curScopeHead;
  curScopeHead := savedScopeHead;
  WordType := DeclType("WORD", BITSET{1}, 3);
  AddressType  := DeclType("ADDRESS", BITSET{1}, 2);
  ByteType := DeclType("BYTE", BITSET{0}, 1); ByteType^.word2 := WordType;
  ByteType^.high := 255;

  p := InsertIdent("PROCESS",3);
  p^.word2 := AddressType;
  addressAlias := AddressType;
  savedScopeHead := curScopeHead;

  charArrayDesc := NewTypeDesc(BITSET{}, 11); charArrayDesc^.word5 := CharType;
END DeclarePredefinedTypes;


PROCEDURE MakeParamList(paramCount: CARDINAL; resultKind: CARDINAL; firstType: RecordPtr): ADDRESS;
VAR p : ArrayPtr;
BEGIN
  SCANNER.Allocate(p, (paramCount+2)*2);
  p^[0] := paramCount;
  p^[1] := resultKind;
  p^[2] := firstType;
  lastParamList := p;
  RETURN p
END MakeParamList;

PROCEDURE DeclareStandardNames; 
BEGIN 
  curScopeHead := baseScopeHead;
  DeclConst("TRUE" ,BooleanType,1,1);
  DeclConst("FALSE",BooleanType,0,1);
  DeclConst("NIL"  ,AddressType ,0,1);

  DeclProc("READ"    , 0);
  DeclProc("READLN"  , 1);
  DeclProc("WRITE"   , 2);
  DeclProc("WRITELN" , 3);
  DeclProc("NEW"     , 4);
  DeclProc("DISPOSE" , 5);
  DeclProc("INC"     , 6);
  DeclProc("DEC"     , 7);
  DeclProc("INCL"    , 8);
  DeclProc("EXCL"    , 9);
  DeclFunc("CARD"    , 0, CardType);
  DeclFunc("INT"     , 1, IntType);
  DeclFunc("LONG"    , 2, LongintType);
  DeclFunc("FLOAT"   , 3, RealType);
  DeclFunc("ABS"     , 4, CardType);
  DeclFunc("DOUBLE"  , 5, LongrealType);
  DeclFunc("ORD"     , 6, CardType);
  DeclFunc("CHR"     , 7, CharType);
  DeclFunc("ODD"     , 8, BooleanType);
  DeclFunc("HIGH"    , 9, CardType);
  DeclFunc("SIZE"    ,11, CardType);
  DeclFunc("VAL"     ,13, CardType);
  DeclFunc("MIN"     ,14, CardType);
  DeclFunc("MAX"     ,15, CardType);
  DeclStdProc("CAP"     , 6, MakeParamList(1, 0, CharType));
  curScopeHead^.word2 := CharType;
  DeclStdProc("HALT"    , 2, NIL);
  DeclStdProc("TRUNC"   , 8, MakeParamList(1, 0, RealType));
  curScopeHead^.word2 := CardType;
  SCANNER.Allocate(stdScopeAnchor, 14);
  stdScopeAnchor^.word0  := NIL;
  stdScopeAnchor^.word1  := curScopeHead;
END DeclareStandardNames;

PROCEDURE DeclareSystemModule; 
VAR p: RecordPtr;
BEGIN
  curScopeHead := savedScopeHead;
  DeclConst("IORESULT"     , CardType, 0300H, 4); curScopeHead^.word3 := BITSET{8}; (* was 256 *)
  DeclConst("HLRESULT"     , CardType, 0302H, 4); curScopeHead^.word3 := BITSET{8}; (* was 256 *)
  DeclConst("BADOVERLAY"   , NIL    , 1, 2);
  DeclConst("OUTOFMEMORY"  , NIL    , 5, 2);
  DeclConst("REALOVERFLOW" , NIL    ,11, 2);
  DeclConst("OVERFLOW"     , NIL    ,12, 2);

  DeclProc("CODE"      ,10);
  DeclFunc("ADR"       ,10, AddressType);
  DeclFunc("TSIZE"     ,12, CardType);
  DeclStdProc("BREAK"     , 0, NIL);
  DeclStdProc("TRANSFER"  ,15, MakeParamList(2, 3, addressAlias)); lastParamList^[3] := addressAlias;
  DeclStdProc("IOTRANSFER",16, MakeParamList(3, 6, AddressType));
  lastParamList^[3] := addressAlias;
  lastParamList^[4] := addressAlias;
  DeclStdProc("NEWPROCESS",17, MakeParamList(4, 1, addressAlias));
  lastParamList^[3] := CardType;
  lastParamList^[4] := AddressType;
  lastParamList^[5] := ProcType;
  p := MakeParamList(2, 0, WordType);
  lastParamList^[3] := WordType;
  DeclStdProc("BDOS"    , 1, p);
  DeclStdProc("BIOS"    ,18, p);
  DeclStdProc("MOVE"    ,19, MakeParamList(3, 0, CardType));
  lastParamList^[3] := AddressType;
  lastParamList^[4] := AddressType;
  DeclStdProc("FILL"    ,20, MakeParamList(3, 0, ByteType));
  lastParamList^[3] := CardType;
  lastParamList^[4] := AddressType;
  DeclStdProc("INP"     ,21, MakeParamList(1, 0, WordType)); curScopeHead^.word2 := CardType;
  DeclStdProc("OUT"     ,22, p);

  SCANNER.Allocate(systemScopeDesc, 14);
  systemScopeDesc^.word0 := stdScopeAnchor;
  systemScopeDesc^.word1 := curScopeHead;

  curScopeHead := NIL;
  DeclStdProc("SYSTEM"  , 0, NIL);
  curScopeHead^.word4 := 6;
  curScopeHead^.word3 := BITSET{0,6,10}; (* was 1089 *)
  curScopeHead^.high := systemScopeDesc^.word1;
  systemModule := curScopeHead;
END DeclareSystemModule;



PROCEDURE DeclareStorageModule; 
VAR p: RecordPtr;
BEGIN 
  curScopeHead := NIL;
  allocateSignature := MakeParamList(2,2,CardType);
  lastParamList^[3] := AddressType;
  p := MakeParamList(1,1,AddressType);
  DeclStdProc("ALLOCATE"  , 10, allocateSignature);
  DeclStdProc("DEALLOCATE", 11, allocateSignature);
  DeclStdProc("MARK"      , 12, p);
  DeclStdProc("RELEASE"   , 13, p);
  DeclStdProc("FREEMEM"   , 14, NIL);
  curScopeHead^.word2 := CardType;
  SCANNER.Allocate(storageScopeDesc, 14);
  storageScopeDesc^.word0 := stdScopeAnchor;
  storageScopeDesc^.word1 := curScopeHead;

  curScopeHead := NIL;
  DeclStdProc("STORAGE"   ,  0, NIL);
  curScopeHead^.word4 := 6;
  curScopeHead^.word3 := BITSET{0,6,10}; (* was 1089 *)
  curScopeHead^.high := storageScopeDesc^.word1;
  storageModule := curScopeHead;
END DeclareStorageModule;

(* $[- retain procedure name because of exception handler *)
PROCEDURE OpenSourceAndOutput; 
CONST DRVROVEC = 29;
VAR cmdToken : ARRAY [0..2] OF CHAR;
    driveCh : CHAR;
BEGIN 
  SCANNER.srcFile := NIL;
  SCANNER.codeFile  := NIL;
  Texts.ReadString(ComLine.commandLine, cmdToken);
  IF NOT Files.Open(SCANNER.srcFile, ComLine.inName) THEN
    Terminal.WriteString(ComLine.inName);
    Terminal.WriteString(" not found.");
    Terminal.WriteLn;
  ELSE
    ComLine.RedirectOutput;
    BDOS(DRVROVEC, 0);
    IF ORD(ComLine.inName[0])-ORD('A') IN BITSET(IORESULT) THEN Files.ResetSys() END;
    ComLine.outName := ComLine.inName;
    SCANNER.ChangeEx(ComLine.outName, "@@@", TRUE);
    Texts.ReadString(ComLine.commandLine, cmdToken);
    IF (cmdToken[1] = ':') AND (cmdToken[2] = 0C) THEN
      driveCh := CAP(cmdToken[0]);
      IF ORD(driveCh)-ORD('A') <= 15 THEN ComLine.outName[0] := driveCh END;
    END;
    Files.Create(SCANNER.codeFile, ComLine.outName);
    Files.NoTrailer(SCANNER.srcFile);
    Files.ReadByte(SCANNER.srcFile, driveCh);
    Files.SetPos(SCANNER.srcFile, LONG(0));
  END;
EXCEPTION Files.UseError:
  Files.ResetSys();
  Files.Create(SCANNER.codeFile, ComLine.outName);
END OpenSourceAndOutput;

(* $[+ remove procedure names *)

PROCEDURE InitCompiler; 
VAR cmdToken: ARRAY [0..2] OF CHAR;
    optCode : CARDINAL;
    compilerOptions[0348H] : BITSET;
BEGIN 
  nativeCodeRequested := FALSE;
  compilationActive := TRUE;
  baseScopeHead := NIL;
  savedScopeHead := NIL;
  InitOperatorTable;
  InitCharClasses;
  InitKeywordTable;
  DeclarePredefinedTypes;
  DeclareStandardNames;
  DeclareSystemModule;
  DeclareStorageModule;
  SCANNER.scanOpt := compilerOptions;
  rangeCheckEnabled := 2 IN SCANNER.scanOpt;
  Texts.ReadString(ComLine.commandLine, cmdToken);
  IF cmdToken[0] = '%' THEN
    optCode := ORD(CAP(cmdToken[1])) - ORD('L');
    IF optCode <= 15 THEN INCL(SCANNER.scanOpt, optCode) END;
  END;
  ERRORS.doSymtabRollback := FALSE;
  SCANNER.Allocate(SYMTAB.moduleTable, 170);
  SCANNER.Allocate(SYMTAB.modStage, 170);
  SCANNER.Allocate(SYMTAB.scopeChain, 34);
  SCANNER.InitScan;
  SCANNER.OpenScop(stdScopeAnchor, 0);
  IF 5 IN SCANNER.scanOpt THEN Texts.WriteCard(3, FREEMEM(), 5) END;
END InitCompiler;
END COMPILER.