home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC2.6 / Compile.MOD < prev    next >
Encoding:
Text File  |  1994-11-11  |  42.2 KB  |  1,367 lines  |  [TEXT/MEDT]
  1. MODULE Compile; (* NW 6.3.83 / 24.12.85; WH 30.9.87; HS 19.12.91 / 11.11.94 *)
  2.  
  3.   (* Implementation according to Programming in Modula-2, Third corrected Edition. *)
  4.  
  5.   FROM SYSTEM IMPORT VAL;
  6.   FROM Terminal IMPORT BusyRead, Read, Write, WriteLn, WriteString;
  7.   FROM FileSystem IMPORT File, Lookup, ReadChar, Response, Close, Delete;
  8.   FROM FileUtil IMPORT Path, termCh, ReadFileName, ExtLookup,
  9.        GetCurrentPath, AddPath;
  10.   IMPORT FPUControl; (* must be first imported compiler module ! *)
  11.   FROM M2Clock IMPORT Time, GetTime;
  12.   FROM M2DM IMPORT
  13.        WordSize, MaxInt, Standard, rngchk, ovflchk,
  14.        inttyp, cardinttyp, cardtyp, realtyp, chartyp, bitstyp, dbltyp, notyp,
  15.        stringtyp, lrltyp, addrtyp, undftyp, mainmod, sysmod,
  16.        ObjPtr, StrPtr, ParPtr, ConstValue, StrForm, ObjClass;
  17.   FROM M2SM IMPORT
  18.        Symbol, sym, id, numtyp, intval, dblval, realval, lrlval, source, IdBuf,
  19.        scanerr, InitScanner, GetSym, Diff, KeepId, Mark, CloseScanner;
  20.   FROM M2TM IMPORT
  21.        topScope, Scope, NewObj, NewStr, NewPar, NewImp,
  22.        NewScope, CloseScope, Find, FindImport, FindInScope, CheckUDP,
  23.        MarkHeap, ReleaseHeap, InitTableHandler;
  24.   FROM M2RM IMPORT
  25.        ModNo, ModList, RefFile,
  26.        InitRef, InRef, OpenRef, RefPoint, OutUnit, CloseRef;
  27.   FROM M2EM IMPORT
  28.        GlbVarStartAdr, LocVarStartAdr, GlbParStartAdr, LocParStartAdr,
  29.        wlev, AllocVar, AllocPar, AllocFld,
  30.        GenItem, GenIndex, GenField, GenDeRef, GenNeg, GenNot, GenAnd,
  31.        GenOr, GenSingSet, GenSet, GenIn, GenOp, GenWith, GenWith2,
  32.        GenStParam, GenStFct, InitM2EM;
  33.   FROM M2CM IMPORT
  34.        LabelRange, ExitTable, curPrio, GenAssign, GenFJ, GenCFJ, GenBJ, GenCBJ,
  35.        PrepCall, GenParam, GenCall, GenEnter, GenResult, GenReturn,
  36.        GenCase1, GenCase2, GenCase3, GenFor1, GenFor2, GenFor3, GenFor4,
  37.        GenLoop1, GenLoop2, GenExit, GenEnterMod, GenExitMod;
  38.   FROM M2HM IMPORT
  39.        DynArrDesSize, ItemMode, Item, curLev,
  40.        WordVal, CheckRegs, SetregMd, SetconMd, LoadD,
  41.        ConvertTyp, CopyDynArray, GenHalt, Processor, ProcessorID, InitM2HM;
  42.   FROM M2LM IMPORT
  43.        pc, AllocString, AllocBounds, fixup, FixLink,
  44.        FixupWith, OutCodeFile, InitM2LM;
  45.  
  46.  
  47.   (* sym,id,numtyp,intval,dblval,realval,lrlval are implicit results of GetSym *)
  48.  
  49.   CONST NL = 63; (* max name length *)
  50.         NofCases     = 128;
  51.         NofExits      = 16;
  52.         LoopLevels     = 4;
  53.         EnumTypSize    = 1;
  54.         SetTypSize     = WordSize DIV 8;
  55.         PointerTypSize = 4;
  56.         ProcTypSize    = 4;
  57.         ESC = 3C;
  58.  
  59.  
  60.   VAR ch: CHAR;
  61.       pno: INTEGER;
  62.       mno: INTEGER; (* number of local modules, increasing from 1 *)
  63.       isdef, isimp, ok: BOOLEAN;
  64.       FileName, TempName: ARRAY [0..NL] OF CHAR;
  65.       processor: Processor;
  66.       i: INTEGER;
  67.       TM: Time;
  68.       path: Path;
  69.  
  70.  
  71.   PROCEDURE Type(VAR typ: StrPtr); FORWARD;
  72.   PROCEDURE Expression(VAR x: Item); FORWARD;
  73.   PROCEDURE Block(ancestor: ObjPtr; qual: BOOLEAN;
  74.                   VAR adr: INTEGER; VAR L0: CARDINAL); FORWARD;
  75.  
  76.   PROCEDURE err(n: INTEGER);
  77.   BEGIN Mark(n)
  78.   END err;
  79.  
  80.   PROCEDURE CheckSym(s: Symbol; n: INTEGER);
  81.   BEGIN
  82.     IF sym = s THEN GetSym ELSE Mark(n) END
  83.   END CheckSym;
  84.  
  85.   PROCEDURE qualident(VAR obj: ObjPtr);
  86.   BEGIN (*sym = ident*)
  87.     obj := Find(id); GetSym;
  88.     WHILE (sym = period) & (obj # NIL) & (obj^.class = Module) DO
  89.       GetSym;
  90.       IF sym = ident THEN
  91.         obj := FindInScope(id, obj^.root); GetSym;
  92.         IF (obj # NIL) & NOT obj^.exported THEN obj := NIL END
  93.       ELSE err(10)
  94.       END
  95.     END
  96.   END qualident;
  97.  
  98.   PROCEDURE GenVal(VAR x: Item);
  99.   BEGIN (* convert to a boolean value *)
  100.     IF x.mode = cocMd THEN LoadD(x) END;
  101.   END GenVal;
  102.  
  103.   PROCEDURE ConstExpression(VAR x: Item);
  104.   BEGIN Expression(x);
  105.     IF x.mode # conMd THEN
  106.       SetconMd(x, 1D, cardtyp); err(44); (* constant expression expected *)
  107.     END
  108.   END ConstExpression;
  109.  
  110.   PROCEDURE CheckComp(t0, t1: StrPtr);
  111.   BEGIN
  112.     IF (t0 # t1) &
  113.        ((t0 # inttyp) OR (t1 # cardtyp)) &
  114.        ((t0 # cardinttyp) OR (t1 # cardtyp)) THEN err(61) END
  115.   END CheckComp;
  116.  
  117.   PROCEDURE CaseLabelList(Ltyp: StrPtr;
  118.             VAR n: INTEGER; VAR tab: ARRAY OF LabelRange);
  119.     VAR x,y: Item; i,j: INTEGER; f: StrForm;
  120.   BEGIN f := Ltyp^.form;
  121.     IF f = Range THEN Ltyp := Ltyp^.RBaseTyp
  122.     ELSIF f > Enum THEN err(83)
  123.     END;
  124.     LOOP ConstExpression(x); CheckComp(Ltyp, x.typ);
  125.       IF sym = ellipsis THEN
  126.         GetSym; ConstExpression(y); CheckComp(Ltyp, y.typ);
  127.         IF WordVal(x) > WordVal(y) THEN err(63); y := x END;
  128.       ELSE y := x
  129.       END;
  130.       (*enter label range into ordered table*)  i := n;
  131.       IF i < NofCases THEN
  132.         LOOP
  133.           IF i = 0 THEN EXIT END;
  134.           IF tab[i-1].low <= WordVal(y) THEN
  135.             IF tab[i-1].high >= WordVal(x) THEN err(62) END;
  136.             EXIT
  137.           END;
  138.           tab[i] := tab[i-1]; DEC(i)
  139.         END;
  140.         WITH tab[i] DO
  141.           low := WordVal(x); high := WordVal(y); label := pc
  142.         END;
  143.         INC(n)
  144.       ELSE err(92)
  145.       END;
  146.       IF sym = comma THEN GetSym
  147.       ELSIF (sym = number) OR (sym = ident) THEN err(11)
  148.       ELSE EXIT
  149.       END
  150.     END
  151.   END CaseLabelList;
  152.  
  153.   PROCEDURE Subrange(VAR typ: StrPtr);
  154.     VAR x, y: Item; f, g: StrForm;
  155.   BEGIN typ := NewStr(Range); ConstExpression(x); f := x.typ^.form;
  156.     IF f <= Enum THEN typ^.min := WordVal(x) ELSE err(82) END;
  157.     CheckSym(ellipsis, 21); ConstExpression(y); g := y.typ^.form;
  158.     CheckComp(x.typ, y.typ);
  159.     WITH typ^ DO max := WordVal(y);
  160.       IF ((f = Card) & (min < 0)) OR ((g = Card) & (max < 0)) THEN
  161.         err(95); min := max
  162.       ELSIF min > max THEN
  163.         err(63); min := max
  164.       END;
  165.       RBaseTyp := x.typ; size := x.typ^.size;
  166.       IF rngchk THEN AllocBounds(min, max, size, BndAdr) END
  167.     END
  168.   END Subrange;
  169.  
  170.   PROCEDURE SimpleType(VAR typ: StrPtr);
  171.     VAR obj, last: ObjPtr; typ0: StrPtr; n: INTEGER;
  172.   BEGIN typ := undftyp;
  173.     IF sym = ident THEN
  174.       qualident(obj);
  175.       IF (obj # NIL) & (obj^.class = Typ) THEN typ := obj^.typ
  176.         ELSE err(52)
  177.       END;
  178.       IF sym = lbrak THEN
  179.         IF typ^.form = Range THEN typ := typ^.RBaseTyp END;
  180.         GetSym; typ0 := typ; Subrange(typ);
  181.         IF typ^.RBaseTyp # typ0 THEN
  182.           IF (typ0 = inttyp) & (typ^.RBaseTyp = cardtyp) THEN
  183.             typ^.RBaseTyp := inttyp
  184.           ELSE err(61)
  185.           END
  186.         END;
  187.         IF sym = rbrak THEN GetSym ELSE err(16);
  188.           IF sym = rparen THEN GetSym END
  189.         END
  190.       END
  191.     ELSIF sym = lparen THEN
  192.       GetSym; typ := NewStr(Enum); last := NIL; n := 0;
  193.       LOOP
  194.         IF sym = ident THEN
  195.           obj := NewObj(id, Const); KeepId;
  196.           obj^.conval.Ch := VAL(CHAR, n);
  197.           IF n > 255 THEN err(300) END;
  198.           obj^.conval.prev := last; obj^.typ := typ;
  199.           last := obj; INC(n); GetSym
  200.         ELSE err(10)
  201.         END;
  202.         IF sym = comma THEN GetSym
  203.         ELSIF sym = ident THEN err(11)
  204.         ELSE EXIT
  205.         END
  206.       END;
  207.       WITH typ^ DO
  208.         ConstLink := last; NofConst := n; size := EnumTypSize
  209.       END;
  210.       CheckSym(rparen, 15)
  211.     ELSIF sym = lbrak THEN
  212.       GetSym; Subrange(typ);
  213.       IF sym = rbrak THEN GetSym ELSE err(16);
  214.         IF sym = rparen THEN GetSym END
  215.       END
  216.     ELSE err(32)
  217.     END
  218.   END SimpleType;
  219.  
  220.   PROCEDURE FieldListSequence(VAR maxadr: INTEGER; adr: INTEGER);
  221.     VAR fld1, last, tagfldtyp: ObjPtr; typ: StrPtr;
  222.  
  223.     PROCEDURE VariantPart;
  224.       (*variables of Fieldlist used: maxadr, adr*)
  225.       VAR lastadr, N: INTEGER;
  226.           tab: ARRAY [0..NofCases-1] OF LabelRange;
  227.     BEGIN maxadr := adr; N := 0;
  228.       LOOP
  229.         IF sym < bar THEN CaseLabelList(typ, N, tab);
  230.           CheckSym(colon, 13); FieldListSequence(lastadr, adr);
  231.           IF lastadr > maxadr THEN maxadr := lastadr END
  232.         END;
  233.         IF sym = bar THEN GetSym ELSE EXIT END
  234.       END;
  235.       IF sym = else THEN
  236.         GetSym; FieldListSequence(lastadr, adr);
  237.         IF lastadr > maxadr THEN maxadr := lastadr END
  238.       END
  239.     END VariantPart;
  240.  
  241.   BEGIN typ := undftyp;
  242.     IF (sym = ident) OR (sym = case) THEN
  243.       LOOP
  244.         IF sym = ident THEN last := topScope^.last;
  245.           LOOP
  246.             IF sym = ident THEN
  247.               fld1 := NewObj(id, Field); KeepId; GetSym
  248.             ELSE err(10)
  249.             END;
  250.             IF sym = comma THEN GetSym
  251.             ELSIF sym = ident THEN err(11)
  252.             ELSE EXIT
  253.             END
  254.           END;
  255.           CheckSym(colon, 13); Type(typ);
  256.           fld1 := last^.next;
  257.           WHILE fld1 # NIL DO
  258.             fld1^.typ := typ; AllocFld(fld1, adr); fld1 := fld1^.next
  259.           END
  260.         ELSIF sym = case THEN
  261.           GetSym; fld1 := NIL; tagfldtyp := NIL;
  262.           IF sym = ident THEN
  263.             fld1 := NewObj(id, Field); KeepId; GetSym
  264.           END;
  265.           CheckSym(colon, 13);
  266.           IF sym = ident THEN qualident(tagfldtyp)
  267.             ELSE err(10)
  268.           END;
  269.           IF (tagfldtyp # NIL) & (tagfldtyp^.class = Typ) THEN
  270.             typ := tagfldtyp^.typ
  271.           ELSE err(52)
  272.           END;
  273.           IF fld1 # NIL THEN fld1^.typ := typ; AllocFld(fld1, adr) END;
  274.           CheckSym(of, 23); VariantPart; adr := maxadr;
  275.           CheckSym(end, 20)
  276.         END;
  277.         IF sym = semicolon THEN GetSym
  278.         ELSIF sym = ident THEN err(12)
  279.         ELSE EXIT
  280.         END
  281.       END
  282.     END;
  283.     maxadr := adr
  284.   END FieldListSequence;
  285.  
  286.   PROCEDURE FormalType(VAR typ: StrPtr);
  287.     VAR objtyp: ObjPtr;
  288.   BEGIN typ := undftyp;
  289.     IF sym = array THEN
  290.       GetSym; typ := NewStr(Array);
  291.       WITH typ^ DO
  292.         strobj := NIL; size := DynArrDesSize; dyn := TRUE
  293.       END;
  294.       CheckSym(of, 23);
  295.       IF sym = ident THEN
  296.         qualident(objtyp);
  297.         IF (objtyp # NIL) & (objtyp^.class = Typ) THEN
  298.           typ^.ElemTyp := objtyp^.typ
  299.         ELSE err(52)
  300.         END
  301.       ELSE err(10)
  302.       END
  303.     ELSIF sym = ident THEN
  304.       qualident(objtyp);
  305.       IF (objtyp # NIL) & (objtyp^.class = Typ) THEN
  306.         typ := objtyp^.typ
  307.       ELSE typ := undftyp; err(52)
  308.       END
  309.     ELSE err(10)
  310.     END
  311.   END FormalType;
  312.  
  313.   PROCEDURE FormalTypeList(proctyp: StrPtr);
  314.     VAR obj: ObjPtr; par, par0, par1: ParPtr; isvar: BOOLEAN;
  315.   BEGIN par := NIL;
  316.     IF (sym = ident) OR (sym = var) OR (sym = array) THEN
  317.       LOOP
  318.         IF sym = var THEN GetSym; isvar := TRUE ELSE isvar := FALSE END;
  319.         par := NewPar(0, isvar, par); FormalType(par^.typ);
  320.         IF sym = comma THEN GetSym
  321.         ELSIF sym = ident THEN err(11)
  322.         ELSE EXIT
  323.         END
  324.       END
  325.     END;
  326.     CheckSym(rparen, 15); (* reverse list *)
  327.     par1 := NIL; (*reverse list*)
  328.     WHILE par # NIL DO
  329.       par0 := par; par := par0^.next; par0^.next := par1; par1 := par0
  330.     END;
  331.     proctyp^.firstPar := par1;
  332.     IF sym = colon THEN
  333.       GetSym; proctyp^.resTyp := undftyp;
  334.       IF sym = ident THEN qualident(obj);
  335.         IF (obj # NIL) & (obj^.class = Typ) THEN proctyp^.resTyp := obj^.typ
  336.           ELSE err(52)
  337.         END
  338.       ELSE err(10)
  339.       END
  340.     ELSE proctyp^.resTyp := notyp
  341.     END
  342.   END FormalTypeList;
  343.  
  344.   PROCEDURE ArrayType(VAR typ: StrPtr);
  345.     VAR a,b: INTEGER;
  346.   BEGIN typ := NewStr(Array); typ^.dyn := FALSE; a := 0;
  347.     SimpleType(typ^.IndexTyp);
  348.     WITH typ^.IndexTyp^ DO
  349.       IF form # Range THEN
  350.         err(94); form := Range; RBaseTyp := inttyp; min := 0; max := 0
  351.       END;
  352.       a := min; b := max
  353.     END;
  354.     IF sym = of THEN
  355.       GetSym; Type(typ^.ElemTyp)
  356.     ELSIF sym = comma THEN
  357.       GetSym; ArrayType(typ^.ElemTyp)
  358.     ELSE err(23)
  359.     END;
  360.     IF b >= 0 THEN
  361.       IF b - MaxInt >= a THEN err(210); a := b END
  362.     ELSIF a < 0 THEN
  363.       IF b >= a + MaxInt THEN err(210); a := b END
  364.     END;
  365.     a := b-a+1; b := typ^.ElemTyp^.size;
  366.     IF (b = 0) OR (MaxInt DIV b >= a) THEN a := a*b ELSE err(210); a := 4 END;
  367.     typ^.size := VAL(INTEGER, VAL(CARDINAL, -a) MOD 2) + a (*%*)
  368.   END ArrayType;
  369.  
  370.   PROCEDURE Type(VAR typ: StrPtr);
  371.     VAR obj: ObjPtr; btyp: StrPtr;
  372.   BEGIN
  373.     IF sym < lparen THEN err(33);
  374.       REPEAT GetSym UNTIL sym >= lparen
  375.     END;
  376.     IF sym = array THEN
  377.       GetSym; ArrayType(typ)
  378.     ELSIF sym = record THEN
  379.       GetSym; typ := NewStr(Record); NewScope(Typ);
  380.       FieldListSequence(typ^.size, 0); typ^.firstFld := topScope^.next;
  381.       typ^.size := VAL(INTEGER,VAL(CARDINAL,-typ^.size) MOD 2) + typ^.size; (*%*)
  382.       CheckSym(end, 20); CloseScope
  383.     ELSIF sym = set THEN
  384.       GetSym; CheckSym(of, 23);
  385.       typ := NewStr(Set); SimpleType(typ^.SBaseTyp);
  386.       btyp := typ^.SBaseTyp;
  387.       IF btyp^.form = Enum THEN
  388.         IF btyp^.NofConst > WordSize THEN err(209) END
  389.       ELSIF btyp^.form = Range THEN
  390.         IF (btyp^.min < 0) OR (btyp^.max >= WordSize) THEN err(209) END
  391.       ELSE err(60)
  392.       END;
  393.       typ^.size := SetTypSize
  394.     ELSIF sym = pointer THEN
  395.       GetSym; typ := NewStr(Pointer);
  396.       typ^.BaseId := 0; typ^.size := PointerTypSize; CheckSym(to, 24);
  397.       IF sym = ident THEN qualident(obj);
  398.         IF obj = NIL THEN typ^.BaseId := id; KeepId (*forward ref*)
  399.         ELSIF obj^.class = Typ THEN typ^.PBaseTyp := obj^.typ
  400.         ELSE err(52)
  401.         END
  402.       ELSE Type(typ^.PBaseTyp)
  403.       END
  404.     ELSIF sym = procedure THEN
  405.       GetSym; typ := NewStr(ProcTyp); typ^.size := ProcTypSize;
  406.       IF sym = lparen THEN
  407.         GetSym; FormalTypeList(typ)
  408.       ELSE typ^.resTyp := notyp;
  409.       END
  410.     ELSE
  411.       SimpleType(typ)
  412.     END;
  413.     IF (sym < semicolon) OR (else < sym) THEN err(34);
  414.       WHILE (sym < ident) OR (else < sym) & (sym < begin) DO
  415.         GetSym
  416.       END
  417.     END
  418.   END Type;
  419.  
  420.   PROCEDURE selector(VAR x: Item; obj: ObjPtr);
  421.     VAR y: Item;
  422.   BEGIN GenItem(x, obj, Scope);
  423.     LOOP
  424.       IF sym = lbrak THEN GetSym;
  425.         LOOP Expression(y); GenIndex(x, y);
  426.           IF sym = comma THEN GetSym ELSE EXIT END
  427.         END;
  428.         CheckSym(rbrak, 16)
  429.       ELSIF sym = period THEN
  430.         GetSym;
  431.         IF sym = ident THEN
  432.           IF (x.typ # NIL) & (x.typ^.form = Record) THEN
  433.             obj := FindInScope(id, x.typ^.firstFld); GenField(x, obj)
  434.           ELSE err(57)
  435.           END;
  436.           GetSym
  437.         ELSE err(10)
  438.         END
  439.       ELSIF sym = arrow THEN
  440.         GetSym; GenDeRef(x)
  441.       ELSE EXIT
  442.       END
  443.     END
  444.   END selector;
  445.  
  446.   PROCEDURE ActualParameters(VAR x: Item; fpar: ParPtr);
  447.     VAR apar: Item;
  448.   BEGIN
  449.     IF sym # rparen THEN
  450.       LOOP Expression(apar);
  451.         IF fpar # NIL THEN
  452.           GenParam(apar, fpar); fpar := fpar^.next
  453.         ELSE err(64)
  454.         END;
  455.         IF sym = comma THEN GetSym
  456.         ELSIF (lparen <= sym) & (sym <= ident) THEN err(11); GetSym;
  457.         ELSE EXIT
  458.         END
  459.       END
  460.     END;
  461.     IF fpar # NIL THEN err(65) END
  462.   END ActualParameters;
  463.  
  464.   PROCEDURE StandProcCall(VAR p: Item);
  465.     VAR x: Item; m: Standard; n: INTEGER;
  466.   BEGIN m := p.proc^.std; n := 0;
  467.     IF m = Halt THEN GenHalt(0); (* HALT *) ELSE
  468.       CheckSym(lparen, 22);
  469.       LOOP Expression(x); GenVal(x);
  470.         GenStParam(p, x, m, n, sym = comma); INC(n);
  471.         IF sym = comma THEN GetSym ELSIF sym # ident THEN EXIT END
  472.       END;
  473.       CheckSym(rparen, 15); GenStFct(m, n)
  474.     END
  475.   END StandProcCall;
  476.  
  477.   PROCEDURE Element(VAR x: Item);
  478.     VAR e1, e2: Item;
  479.   BEGIN Expression(e1); GenVal(e1);
  480.     IF sym = ellipsis THEN
  481.       GetSym; Expression(e2); GenVal(e2);
  482.       GenSet(x, e1, e2)
  483.     ELSE GenSingSet(x, e1)
  484.     END;
  485.   END Element;
  486.  
  487.   PROCEDURE Sets(VAR x: Item; styp: StrPtr);
  488.     VAR y: Item;
  489.   BEGIN x.typ := styp; y.typ := styp;
  490.     IF sym # rbrace THEN
  491.       Element(x);
  492.       LOOP
  493.         IF sym = comma THEN GetSym
  494.         ELSIF (lparen <= sym) & (sym <= ident) THEN err(11)
  495.         ELSE EXIT
  496.         END;
  497.         Element(y); GenOp(plus, x, y)
  498.       END
  499.     ELSE SetconMd(x, 0D, styp);
  500.     END;
  501.     CheckSym(rbrace, 17)
  502.   END Sets;
  503.  
  504.   PROCEDURE Factor(VAR x: Item);
  505.     VAR obj: ObjPtr; xt: StrPtr; fpar: ParPtr; savedRegs: LONGINT;
  506.   BEGIN
  507.     IF sym < lparen THEN err(31);
  508.       REPEAT GetSym UNTIL sym >= lparen
  509.     END;
  510.     IF sym = ident THEN
  511.       qualident(obj);
  512.       IF sym = lbrace THEN
  513.         GetSym;
  514.         IF (obj # NIL) & (obj^.class = Typ) &
  515.            (obj^.typ^.form = Set) THEN Sets(x, obj^.typ)
  516.         ELSE err(52); Sets(x, bitstyp)
  517.         END
  518.       ELSE
  519.         selector(x, obj);
  520.         IF (x.mode = codMd) & (x.proc^.std # NonStand) THEN StandProcCall(x)
  521.         ELSIF sym = lparen THEN GetSym;
  522.           IF x.mode = typMd THEN
  523.             xt := x.typ; Expression(x); ConvertTyp(xt, x);
  524.             x.typ := xt;
  525.           ELSE PrepCall(x, fpar, savedRegs);
  526.             ActualParameters(x, fpar); GenCall(x, savedRegs);
  527.           END;
  528.           CheckSym(rparen, 15)
  529.         END
  530.       END
  531.     ELSIF sym = number THEN
  532.       GetSym;
  533.       x.mode := conMd;
  534.       CASE numtyp OF
  535.         1: x.typ := cardtyp; x.val.C  := intval
  536.       | 2: x.typ := dbltyp;  x.val.D  := dblval
  537.       | 3: x.typ := chartyp; x.val.Ch := VAL(CHAR, intval)
  538.       | 4: x.typ := realtyp; x.val.R  := realval
  539.       | 5: x.typ := lrltyp;  x.val.X  := lrlval
  540.       END
  541.     ELSIF sym = string THEN
  542.       x.typ := stringtyp; x.mode := conMd;
  543.       AllocString(id, x.val.D0, x.val.D1); x.val.D2 := 0; GetSym
  544.     ELSIF sym = lparen THEN
  545.       GetSym; Expression(x); CheckSym(rparen, 15)
  546.     ELSIF sym = lbrace THEN GetSym; Sets(x, bitstyp)
  547.     ELSIF sym = not THEN
  548.       GetSym; Factor(x); GenNot(x)
  549.     ELSE err(31); SetregMd(x, 0, undftyp);
  550.     END
  551.   END Factor;
  552.  
  553.   PROCEDURE Term(VAR x: Item);
  554.     VAR y: Item; mulop: Symbol;
  555.   BEGIN Factor(x);
  556.     WHILE (times <= sym) & (sym <= and) DO
  557.       mulop := sym; GetSym;
  558.       IF mulop = and THEN GenAnd(x) END;
  559.       Factor(y); GenOp(mulop, x, y)
  560.     END
  561.   END Term;
  562.  
  563.   PROCEDURE SimpleExpression(VAR x: Item);
  564.     VAR y: Item; addop: Symbol;
  565.   BEGIN
  566.     IF sym = minus THEN
  567.       GetSym; Term(x); GenNeg(x)
  568.     ELSE
  569.       IF sym = plus THEN GetSym END;
  570.       Term(x)
  571.     END;
  572.     WHILE (plus <= sym) & (sym <= or) DO
  573.       addop := sym; GetSym;
  574.       IF addop = or THEN GenOr(x) END;
  575.       Term(y); GenOp(addop, x, y)
  576.     END
  577.   END SimpleExpression;
  578.  
  579.   PROCEDURE Expression(VAR x: Item);
  580.     VAR y: Item; relation: Symbol;
  581.   BEGIN SimpleExpression(x);
  582.     IF (eql <= sym) & (sym <= in) THEN
  583.       relation := sym; GetSym;
  584.       GenVal(x);
  585.       SimpleExpression(y);
  586.       GenVal(y);
  587.       IF relation = in THEN GenIn(x,y)
  588.       ELSE GenOp(relation,x,y) END;
  589.     END
  590.   END Expression;
  591.  
  592.   PROCEDURE Priority;
  593.     VAR x: Item;
  594.   BEGIN
  595.     IF sym = lbrak THEN
  596.       GetSym; ConstExpression(x);
  597.       IF (x.typ = cardtyp) & (x.val.C < 16) THEN curPrio := x.val.C
  598.         ELSE err(147)
  599.       END;
  600.       CheckSym(rbrak, 16)
  601.     ELSE curPrio := 0
  602.     END
  603.   END Priority;
  604.  
  605.   PROCEDURE ImportList(impmod: ObjPtr);
  606.     VAR obj: ObjPtr;
  607.   BEGIN
  608.     IF (impmod # NIL) & (impmod^.class # Module) THEN
  609.       err(55); impmod := NIL
  610.     END;
  611.     LOOP
  612.       IF sym = ident THEN
  613.         IF impmod = NIL THEN obj := FindImport(id)
  614.         ELSE obj := FindInScope(id, impmod^.root);
  615.           IF (obj # NIL) & NOT obj^.exported THEN obj := NIL END
  616.         END;
  617.         IF obj # NIL THEN NewImp(topScope, obj) ELSE err(50) END;
  618.         GetSym
  619.       ELSE err(10)
  620.       END;
  621.       IF sym = comma THEN GetSym
  622.       ELSIF sym = ident THEN err(11)
  623.       ELSE EXIT
  624.       END
  625.     END;
  626.     CheckSym(semicolon, 12)
  627.   END ImportList;
  628.  
  629.   PROCEDURE ExportList;
  630.     VAR obj: ObjPtr;
  631.   BEGIN
  632.     LOOP
  633.       IF sym = ident THEN
  634.         obj := NewObj(id, Temp); KeepId; GetSym
  635.       ELSE err(10)
  636.       END;
  637.       IF sym = comma THEN GetSym
  638.       ELSIF sym = ident THEN err(11)
  639.       ELSE EXIT
  640.       END
  641.     END;
  642.     CheckSym(semicolon, 12)
  643.   END ExportList;
  644.  
  645.   PROCEDURE Block(ancestor: ObjPtr; qual: BOOLEAN;
  646.                   VAR adr: INTEGER; VAR L0: CARDINAL);
  647.     VAR obj, last: ObjPtr; newtypdef: BOOLEAN;
  648.         id0, s: INTEGER; x: Item; typ: StrPtr;
  649.         L1, exits, loopLev, blockEnd: CARDINAL; exitTab: ExitTable;
  650.  
  651.  
  652.   PROCEDURE ChangeAllRefs(opaS, newS: StrPtr);
  653.     VAR mod: ObjPtr;
  654.  
  655.     PROCEDURE ChangeTyp(VAR t: StrPtr); FORWARD;
  656.  
  657.     PROCEDURE ChangeParams(first: ParPtr);
  658.       VAR par: ParPtr;
  659.     BEGIN par := first;
  660.       WHILE par # NIL DO
  661.         ChangeTyp(par^.typ); par := par^.next;
  662.       END;
  663.     END ChangeParams;
  664.  
  665.     PROCEDURE ChangeFields(first: ObjPtr);
  666.       VAR obj: ObjPtr;
  667.     BEGIN obj := first;
  668.       WHILE obj # NIL DO
  669.         ChangeTyp(obj^.typ); obj := obj^.next;
  670.       END;
  671.     END ChangeFields;
  672.  
  673.     PROCEDURE ChangeTyp(VAR t: StrPtr);
  674.       VAR this: StrPtr;
  675.     BEGIN this := t;
  676.       IF this # NIL THEN
  677.         WITH this^ DO
  678.           CASE form OF
  679.           | Pointer: IF PBaseTyp = opaS THEN PBaseTyp := newS END;
  680.           | ProcTyp: ChangeParams(firstPar); ChangeTyp(resTyp);
  681.           | Opaque:  IF this = opaS THEN t := newS END;
  682.           | Array:   ChangeTyp(ElemTyp);
  683.           | Record:  ChangeFields(firstFld);
  684.           ELSE (* nothing to change for all other variants *)
  685.           END;
  686.         END;
  687.       END;
  688.     END ChangeTyp;
  689.  
  690.     PROCEDURE ChangeObjects(root: ObjPtr);
  691.       VAR obj: ObjPtr;
  692.     BEGIN obj := root;
  693.       WHILE obj # NIL DO
  694.         WITH obj^ DO
  695.           CASE class OF
  696.           | Header, Temp:
  697.           | Const, Typ,
  698.             Var, Field: ChangeTyp(typ); (* change object's main type *)
  699.           | Proc:       ChangeParams(firstParam); ChangeTyp(typ);
  700.           | Code:       ChangeParams(firstArg); ChangeTyp(typ);
  701.           | Module:
  702.           END;
  703.         END;
  704.         obj := obj^.next;
  705.       END;
  706.     END ChangeObjects;
  707.  
  708.   BEGIN
  709.     mod := ModList^.next;
  710.     WHILE mod # NIL DO ChangeObjects(mod^.firstObj); mod := mod^.next END;
  711.     IF ancestor # mainmod THEN err(101) END;
  712.   END ChangeAllRefs;
  713.  
  714.  
  715.   PROCEDURE FormalParameters(proc: ObjPtr);
  716.     VAR isvar: BOOLEAN; size: INTEGER;
  717.         par, par0, par1: ParPtr; typ0: StrPtr;
  718.   BEGIN par := NIL; size := 0;
  719.     IF (sym = ident) OR (sym = var) THEN
  720.       LOOP par1 := par; isvar := FALSE;
  721.         IF sym = var THEN GetSym; isvar := TRUE END;
  722.         LOOP
  723.           IF sym = ident THEN
  724.             par := NewPar(id, isvar, par); KeepId; GetSym
  725.           ELSE err(10)
  726.           END;
  727.           IF sym = comma THEN GetSym
  728.           ELSIF sym = ident THEN err(11)
  729.           ELSIF sym = var THEN err(11); GetSym
  730.           ELSE EXIT
  731.           END
  732.         END;
  733.         CheckSym(colon, 13); FormalType(typ0); par0 := par;
  734.         WHILE par0 # par1 DO
  735.           par0^.typ := typ0; AllocPar(par0, size); par0 := par0^.next;
  736.         END;
  737.         IF sym = semicolon THEN GetSym
  738.         ELSIF sym = ident THEN err(12)
  739.         ELSE EXIT
  740.         END
  741.       END
  742.     END;
  743.     par1 := NIL; (*reverse list*)
  744.     WHILE par # NIL DO
  745.       par0 := par; par := par0^.next; par0^.next := par1; par1 := par0
  746.     END;
  747.     proc^.firstParam := par1; proc^.pd^.size := ABS(size); (*of param area*)
  748.     CheckSym(rparen, 15)
  749.   END FormalParameters;
  750.  
  751.   PROCEDURE CheckParameters(proc: ObjPtr);
  752.     VAR isvar: BOOLEAN;
  753.         par, par0, par1: ParPtr; typ0: StrPtr;
  754.   BEGIN par0 := proc^.firstParam;
  755.     IF (sym = ident) OR (sym = var) THEN
  756.       LOOP par1 := par0; isvar := FALSE;
  757.         IF sym = var THEN GetSym; isvar := TRUE END;
  758.         LOOP
  759.           IF sym = ident THEN
  760.             IF par0 # NIL THEN par0^.name := id; par0 := par0^.next
  761.               ELSE err(66)
  762.             END;
  763.             KeepId; GetSym
  764.           ELSE err(10)
  765.           END;
  766.           IF sym = comma THEN GetSym
  767.           ELSIF sym = ident THEN err(11)
  768.           ELSIF sym = var THEN err(11); GetSym
  769.           ELSE EXIT
  770.           END
  771.         END;
  772.         CheckSym(colon, 13); FormalType(typ0); par := par1;
  773.         WHILE par # par0 DO
  774.           IF (par^.typ # typ0) &
  775.             ((par^.typ^.form # Array) OR (typ0^.form # Array) OR
  776.              (par^.typ^.ElemTyp # typ0^.ElemTyp)) THEN err(69)
  777.           END;
  778.           IF par^.varpar # isvar THEN err(68) END;
  779.           par := par^.next
  780.         END;
  781.         IF sym = semicolon THEN GetSym
  782.         ELSIF sym = ident THEN err(12)
  783.         ELSE EXIT
  784.         END
  785.       END
  786.     END;
  787.     IF par0 # NIL THEN err(70) END;
  788.     CheckSym(rparen, 15)
  789.   END CheckParameters;
  790.  
  791.   PROCEDURE MakeParameterObjects(proc: ObjPtr);
  792.     VAR par: ParPtr; obj: ObjPtr; adr: INTEGER;
  793.   BEGIN par := proc^.firstParam;
  794.     IF curLev = 1 THEN
  795.       adr := GlbParStartAdr + proc^.pd^.size;
  796.     ELSE
  797.       adr := LocParStartAdr + proc^.pd^.size;
  798.     END;
  799.     WHILE par # NIL DO
  800.       obj := NewObj(par^.name, Var); (*name field no longer used*)
  801.       WITH obj^ DO
  802.         typ := par^.typ; vmod := 0; vlev := curLev; varpar := par^.varpar;
  803.         AllocPar(par, adr); vadr := adr;
  804.       END;
  805.       par := par^.next
  806.     END
  807.   END MakeParameterObjects;
  808.  
  809.   PROCEDURE ProcedureDeclaration(VAR proc: ObjPtr);
  810.     VAR i, L0, L1: CARDINAL; adr: INTEGER; par, res: ObjPtr;
  811.   BEGIN
  812.     proc := Find(id);
  813.     IF (proc # NIL) & (proc^.class = Proc) & (proc^.pmod = 0) &
  814.        ((proc^.pd^.adr = 0) & (curLev = 0) & isimp OR (*heading in def mod *)
  815.         proc^.pd^.forward & (proc^.pd^.lev = VAL(INTEGER,curLev))) THEN (*forward*)
  816.       IF proc^.pd^.adr = 0 THEN proc^.pd^.exp := TRUE END;
  817.       CheckSym(ident, 10);
  818.       IF sym = lparen THEN
  819.         GetSym; CheckParameters(proc);
  820.         IF sym = colon THEN GetSym;
  821.           IF sym = ident THEN qualident(res);
  822.             IF (res = NIL) OR (res^.class # Typ) OR (res^.typ # proc^.typ) THEN
  823.               err(71)
  824.             END
  825.           ELSE err(10)
  826.           END
  827.         ELSIF proc^.typ # notyp THEN err(72)
  828.         END
  829.       ELSIF proc^.firstParam # NIL THEN err(73)
  830.       END
  831.     ELSE (*new procedure*)
  832.       proc := NewObj(id, Proc); KeepId;
  833.       WITH proc^ DO
  834.         pmod := 0; typ := notyp; firstParam := NIL;
  835.       END;
  836.       WITH proc^.pd^ DO
  837.         forward := FALSE; exp := FALSE;
  838.         lev := curLev; adr := 0; size := 0; INC(pno); num := pno;
  839.       END;
  840.       CheckSym(ident, 10);
  841.       IF sym = lparen THEN
  842.         GetSym; FormalParameters(proc);
  843.         IF sym = colon THEN
  844.           GetSym; proc^.typ := undftyp;
  845.           IF sym = ident THEN qualident(res);
  846.             IF (res # NIL) & (res^.class = Typ) THEN proc^.typ := res^.typ
  847.             ELSE err(52)
  848.             END
  849.           ELSE err(10)
  850.           END
  851.         END
  852.       END
  853.     END;
  854.     CheckSym(semicolon, 12);
  855.     IF sym = code THEN
  856.       GetSym; DEC(pno);
  857.       WITH proc^ DO
  858.         IF pd^.exp OR pd^.forward THEN err(74) END;
  859.         class := Code; std := NonStand; ConstExpression(x);
  860.         IF x.typ = cardtyp THEN cnum := x.val.C
  861.         ELSE cnum := 0; err(133)
  862.         END;
  863.       END;
  864.       CheckSym(semicolon, 12);
  865.     ELSIF NOT isdef THEN
  866.       i := proc^.pd^.adr;
  867.       MarkHeap; NewScope(Proc); INC(curLev);
  868.       IF sym = forward THEN GetSym;
  869.         WITH proc^.pd^ DO
  870.           IF exp OR forward THEN err(74) END;
  871.           forward := TRUE; exp := FALSE;
  872.           lev := curLev-1; GenFJ(i); adr := i-2;
  873.         END;
  874.         (*MakeParameterObjects(proc)*)
  875.       ELSE MakeParameterObjects(proc);
  876.         IF proc^.pd^.forward THEN fixup(i+2) END;
  877.         proc^.pd^.adr := pc; proc^.pd^.forward := FALSE;
  878.         L0 := 0; GenEnter(L1, proc^.pd^.lev); GenFJ(L0);
  879.         adr := LocVarStartAdr; Block(proc, FALSE, adr, L0); FixupWith(L1, adr);
  880.       END;
  881.       DEC(curLev); CloseScope; ReleaseHeap; CheckSym(semicolon, 12);
  882.     END
  883.   END ProcedureDeclaration;
  884.  
  885.   PROCEDURE ModuleDeclaration(VAR mod: ObjPtr; VAR adr: INTEGER; VAR L0: CARDINAL);
  886.     VAR prio: INTEGER; qual: BOOLEAN; impmod: ObjPtr;
  887.   BEGIN qual := FALSE; CheckSym(ident, 10);
  888.     mod := NewObj(id, Module); KeepId;
  889.     INC(mno); mod^.modno := mno; prio := curPrio; Priority;
  890.     CheckSym(semicolon, 12); NewScope(Module);
  891.     WHILE (sym = from) OR (sym = import) DO impmod := NIL;
  892.       IF sym = from THEN GetSym;
  893.         IF sym = ident THEN
  894.           impmod := FindImport(id); GetSym
  895.         ELSE err(10)
  896.         END;
  897.         CheckSym(import, 30)
  898.       ELSE GetSym
  899.       END;
  900.       ImportList(impmod)
  901.     END;
  902.     IF sym = export THEN GetSym;
  903.       IF sym = qualified THEN GetSym; qual := TRUE END;
  904.       ExportList
  905.     END;
  906.     Block(mod, qual, adr, L0);
  907.     CloseScope; curPrio := prio
  908.   END ModuleDeclaration;
  909.  
  910.  
  911.   PROCEDURE StatSeq;
  912.     VAR obj: ObjPtr; fpar: ParPtr; x, y: Item; L0, L1, s, e: CARDINAL;
  913.         savedRegs: LONGINT;
  914.  
  915.     PROCEDURE CasePart;
  916.       VAR x: Item; n: INTEGER; L0, L1: CARDINAL;
  917.           tab: ARRAY [0..NofCases-1] OF LabelRange;
  918.     BEGIN n := 0;
  919.       Expression(x); GenCase1(x, L0); CheckSym(of, 23);
  920.       LOOP
  921.         IF sym < bar THEN
  922.           CaseLabelList(x.typ, n, tab);
  923.           CheckSym(colon, 13); StatSeq; GenCase2
  924.         END;
  925.         IF sym = bar THEN GetSym ELSE EXIT END
  926.       END;
  927.       L1 := pc;
  928.       IF sym = else THEN
  929.         GetSym; StatSeq; GenCase2
  930.       ELSE GenHalt(1); GenCase2
  931.       END;
  932.       RefPoint; GenCase3(x, L0, L1, n, tab)
  933.     END CasePart;
  934.  
  935.     PROCEDURE ForPart;
  936.       VAR obj: ObjPtr;
  937.           v, e1, e2, e3: Item;
  938.           L0, L1: CARDINAL;
  939.     BEGIN obj := NIL;
  940.       IF sym = ident THEN
  941.         obj := Find(id);
  942.         IF obj # NIL THEN
  943.           IF (obj^.class # Var) OR obj^.varpar OR (obj^.vmod > 0) THEN err(75) END
  944.         ELSE err(50)
  945.         END;
  946.         GetSym
  947.       ELSE err(10)
  948.       END;
  949.       GenItem(v, obj, Scope);
  950.       IF sym = becomes THEN GetSym ELSE err(19);
  951.         IF sym = eql THEN GetSym END
  952.       END;
  953.       Expression(e1); GenVal(e1); GenFor1(v, e1);
  954.       CheckSym(to,24); Expression(e2); GenVal(e2); GenFor2(v, e1, e2);
  955.       IF sym = by THEN
  956.         GetSym; ConstExpression(e3)
  957.       ELSE SetconMd(e3, 1D, cardtyp);
  958.       END;
  959.       GenFor3(v, e2, e3, L0, L1);
  960.       CheckSym(do, 25); StatSeq; GenFor4(v, e2, e3, L0, L1)
  961.     END ForPart;
  962.  
  963.   BEGIN
  964.     LOOP
  965.       IF sym < ident THEN err(35);
  966.         REPEAT GetSym UNTIL sym >= ident
  967.       END;
  968.       IF sym = ident THEN
  969.         RefPoint; qualident(obj); selector(x, obj);
  970.         IF sym = becomes THEN
  971.           GetSym; Expression(y); GenAssign(x, y)
  972.         ELSIF sym = eql THEN
  973.           err(19); GetSym; Expression(y); GenAssign(x, y)
  974.         ELSIF (x.mode = codMd) & (x.proc^.std # NonStand) THEN
  975.           StandProcCall(x);
  976.           IF x.typ # notyp THEN err(76) END
  977.         ELSE PrepCall(x, fpar, savedRegs);
  978.           IF sym = lparen THEN
  979.             GetSym; ActualParameters(x, fpar); CheckSym(rparen, 15)
  980.           ELSIF fpar # NIL THEN err(65)
  981.           END;
  982.           GenCall(x, savedRegs);
  983.           IF x.typ # notyp THEN err(76) END
  984.         END
  985.       ELSIF sym = if THEN
  986.         GetSym; RefPoint; Expression(x); GenCFJ(x, L0);
  987.         CheckSym(then, 27); StatSeq; L1 := 0;
  988.         WHILE (sym = elsif) DO
  989.           GetSym; GenFJ(L1); FixLink(L0); RefPoint; Expression(x);
  990.           GenCFJ(x, L0); CheckSym(then, 27); StatSeq
  991.         END;
  992.         IF sym = else THEN
  993.           GetSym; GenFJ(L1); FixLink(L0); StatSeq
  994.         ELSE FixLink(L0)
  995.         END;
  996.         FixLink(L1); CheckSym(end, 20)
  997.       ELSIF sym = case THEN
  998.         GetSym; RefPoint; CasePart; CheckSym(end, 20)
  999.       ELSIF sym = while THEN
  1000.         GetSym; L1 := pc; RefPoint; Expression(x); GenCFJ(x, L0);
  1001.         CheckSym(do, 25); StatSeq; GenBJ(L1); FixLink(L0);
  1002.         CheckSym(end, 20)
  1003.       ELSIF sym = repeat THEN
  1004.         GetSym; L0 := pc; StatSeq;
  1005.         IF sym = until THEN
  1006.           GetSym; RefPoint; Expression(x); GenCBJ(x, L0)
  1007.         ELSE err(26)
  1008.         END
  1009.       ELSIF sym = loop THEN
  1010.         GetSym; INC(loopLev); GenLoop1(s, e, exits);
  1011.         L0 := pc; StatSeq; GenBJ(L0); CheckSym(end, 20);
  1012.         GenLoop2(s, e, exits, exitTab); DEC(loopLev);
  1013.       ELSIF sym = for THEN
  1014.         GetSym; RefPoint; ForPart; CheckSym(end, 20)
  1015.       ELSIF sym = with THEN
  1016.         GetSym; x.typ := NIL;
  1017.         IF sym = ident THEN
  1018.           qualident(obj); selector(x, obj);
  1019.           IF x.typ^.form = Record THEN
  1020.             NewScope(Typ); GenWith(x, adr); topScope^.name := wlev;
  1021.             topScope^.right := x.typ^.firstFld;
  1022.           ELSE err(57); x.typ := NIL
  1023.           END
  1024.         ELSE err(10)
  1025.         END;
  1026.         CheckSym(do, 25); StatSeq; CheckSym(end, 20);
  1027.         IF x.typ # NIL THEN CloseScope END;
  1028.         GenWith2;
  1029.       ELSIF sym = exit THEN
  1030.         GetSym;
  1031.         IF loopLev > 0 THEN GenExit(exits, exitTab) ELSE err(39) END;
  1032.       ELSIF sym = return THEN GetSym;
  1033.         IF sym < semicolon THEN Expression(x)
  1034.         ELSE
  1035.           x.typ := notyp;
  1036.           IF ancestor^.typ # notyp THEN err(139) END;
  1037.         END;
  1038.         GenResult(x, ancestor, blockEnd)
  1039.       END;
  1040.       CheckRegs;
  1041.       IF sym = semicolon THEN GetSym
  1042.       ELSIF (sym <= ident) OR (if <= sym) & (sym <= for) THEN err(12)
  1043.       ELSE EXIT
  1044.       END
  1045.     END
  1046.   END StatSeq;
  1047.  
  1048.   PROCEDURE CheckExports(obj: ObjPtr);
  1049.   BEGIN
  1050.     IF obj # NIL THEN
  1051.       IF obj^.class = Temp THEN Mark(80)
  1052.       ELSIF ~qual & obj^.exported THEN (*import in outer scope*)
  1053.         NewImp(topScope^.left, obj)
  1054.       END;
  1055.       CheckExports(obj^.left); CheckExports(obj^.right)
  1056.     END
  1057.   END CheckExports;
  1058.  
  1059.   PROCEDURE CheckUDProc(obj: ObjPtr);
  1060.   BEGIN (*check for undefined procedure bodies*)
  1061.     WHILE obj # NIL DO
  1062.       IF (obj^.class = Proc) & (obj^.pmod = 0) &
  1063.          ((obj^.pd^.adr = 0) OR obj^.pd^.forward) THEN err(89)
  1064.       END;
  1065.       obj := obj^.next
  1066.     END
  1067.   END CheckUDProc;
  1068.  
  1069.   BEGIN (*Block*)
  1070.     LOOP
  1071.       IF sym = const THEN
  1072.         GetSym;
  1073.         WHILE sym = ident DO
  1074.           id0 := id; KeepId; GetSym;
  1075.           IF sym = eql THEN
  1076.             GetSym; ConstExpression(x)
  1077.           ELSIF sym = becomes THEN
  1078.             err(18); GetSym; ConstExpression(x)
  1079.           ELSE err(18)
  1080.           END;
  1081.           obj := NewObj(id0, Const); obj^.typ := x.typ; obj^.conval := x.val;
  1082.           IF (x.typ = stringtyp) & (obj^.conval.D2 = 0) THEN
  1083.             obj^.conval.D2 := id; KeepId
  1084.           END;
  1085.           CheckSym(semicolon, 12)
  1086.         END
  1087.       ELSIF sym = type THEN
  1088.         GetSym;
  1089.         WHILE sym = ident DO
  1090.           typ := undftyp; obj := NIL; newtypdef := TRUE;
  1091.           IF isimp & (curLev = 0) THEN
  1092.             obj := Find(id);
  1093.             IF (obj # NIL) & (obj^.class = Typ) & (obj^.typ^.form = Opaque) THEN
  1094.               newtypdef := FALSE
  1095.             END
  1096.           END;
  1097.           IF newtypdef THEN id0 := id; KeepId END;
  1098.           GetSym;
  1099.           IF sym = eql THEN
  1100.             GetSym; Type(typ)
  1101.           ELSIF (sym = becomes) OR (sym = colon) THEN
  1102.             err(18); GetSym; Type(typ)
  1103.           ELSIF NOT isdef THEN err(18)
  1104.           ELSE typ := NewStr(Opaque); typ^.size := PointerTypSize
  1105.           END;
  1106.           IF newtypdef THEN
  1107.             obj := NewObj(id0, Typ); obj^.typ := typ; obj^.mod := mainmod;
  1108.             IF typ^.strobj = NIL THEN typ^.strobj := obj END;
  1109.           ELSIF typ^.size = PointerTypSize THEN ChangeAllRefs(obj^.typ, typ)
  1110.           ELSE err(101)
  1111.           END;
  1112.           CheckUDP(obj, topScope^.right); (* check for undefined pointer types *)
  1113.           CheckSym(semicolon, 12)
  1114.         END
  1115.       ELSIF sym = var THEN
  1116.         GetSym;
  1117.         WHILE sym = ident DO last := topScope^.last; obj := last;
  1118.           LOOP
  1119.             IF sym = ident THEN
  1120.               obj := NewObj(id, Var); KeepId; GetSym
  1121.             ELSE err(10)
  1122.             END;
  1123.             IF sym = comma THEN GetSym
  1124.             ELSIF sym = ident THEN err(11)
  1125.             ELSE EXIT
  1126.             END
  1127.           END;
  1128.           CheckSym(colon, 13); Type(typ);
  1129.           WHILE (last # obj) & (last # NIL) DO
  1130.             last := last^.next;
  1131.             IF last = NIL THEN last := obj END;
  1132.             last^.typ := typ;
  1133.             WITH last^ DO
  1134.               varpar := FALSE; vmod := 0; vlev := curLev;
  1135.             END;
  1136.             AllocVar(last, adr);
  1137.           END;
  1138.           CheckSym(semicolon, 12)
  1139.         END
  1140.       ELSIF sym = procedure THEN
  1141.         GetSym; ProcedureDeclaration(obj)
  1142.       ELSIF sym = module THEN
  1143.         GetSym; ModuleDeclaration(obj, adr, L0); CheckSym(semicolon, 12);
  1144.         GenFJ(L0)
  1145.       ELSE
  1146.         IF (sym # begin) & (sym # end) THEN err(36);
  1147.           REPEAT GetSym UNTIL (sym >= begin) OR (sym = end)
  1148.         END;
  1149.         IF (sym <= begin) OR (sym = eof) THEN EXIT END
  1150.       END
  1151.     END;
  1152.  
  1153.     exits := 0; loopLev := 0; blockEnd := 0;  (* label used in RETURN *)
  1154.     IF NOT isdef THEN
  1155.       IF pc - L0 = 2 THEN pc := pc - 4 ELSE fixup(L0) END;
  1156.     END;
  1157.     IF ancestor^.class = Module THEN
  1158.       CheckExports(topScope^.right);
  1159.       ancestor^.firstObj := topScope^.next; ancestor^.root := topScope^.right
  1160.     ELSE (*procedure*)
  1161.       ancestor^.firstLocal := topScope^.next;
  1162.       obj := topScope^.next;
  1163.       WHILE obj # NIL DO
  1164.         IF (obj^.typ^.form = Array) & obj^.typ^.dyn & NOT obj^.varpar THEN
  1165.           CopyDynArray(obj^.vadr, obj^.typ^.ElemTyp^.size)
  1166.         END;
  1167.         obj := obj^.next
  1168.       END;
  1169.     END;
  1170.     IF NOT isdef THEN CheckUDProc(topScope^.next) END;
  1171.     IF sym = begin THEN
  1172.       IF isdef THEN err(37) END;
  1173.       GetSym; StatSeq; RefPoint
  1174.     END;
  1175.     (*IF ancestor^.class = Proc THEN*)
  1176.       GenReturn(ancestor, blockEnd);
  1177.       IF (ancestor^.class = Proc) & NOT isdef THEN
  1178.         ancestor^.pd^.size := VAL(INTEGER,pc) - ancestor^.pd^.adr
  1179.       END;
  1180.     (*END;*)
  1181.     CheckSym(end, 20); IF NOT scanerr THEN OutUnit(ancestor) END;
  1182.     IF sym = ident THEN
  1183.       IF Diff(id, ancestor^.name) # 0 THEN err(77) END;
  1184.       GetSym
  1185.     ELSE err(10)
  1186.     END
  1187.   END Block;
  1188.  
  1189.   PROCEDURE CompilationUnit;
  1190.     VAR id0, adr: INTEGER; L0: CARDINAL;
  1191.         hdr, importMod: ObjPtr; impok, ok: BOOLEAN;
  1192.         FName, TName: ARRAY [0..NL] OF CHAR;
  1193.         p: Path; f: File; i: INTEGER; path1: Path;
  1194.  
  1195.     PROCEDURE GetFileName(j: INTEGER;
  1196.               VAR FName: ARRAY OF CHAR; ext: ARRAY OF CHAR);
  1197.       VAR i, L: INTEGER;
  1198.     BEGIN i := 0; L := VAL(INTEGER,ORD(IdBuf[j])) + j - 1;
  1199.       WHILE j < L DO
  1200.         INC(j); FName[i] := IdBuf[j]; INC(i)
  1201.       END;
  1202.       j := 0; L := HIGH(ext);
  1203.       WHILE j <= L DO
  1204.        FName[i] := ext[j]; INC(i); INC(j)
  1205.       END;
  1206.       FName[i] := 0C
  1207.     END GetFileName;
  1208.  
  1209.     PROCEDURE ImportModule;
  1210.       VAR adr, pno, i: INTEGER; f: File; p: Path; ok: BOOLEAN;
  1211.     BEGIN
  1212.       IF sym = ident THEN
  1213.         IF Diff(id, sysmod^.name) = 0 THEN importMod := sysmod
  1214.         ELSE
  1215.           GetFileName(id, FileName, ".SBM");
  1216.           InRef(FileName, hdr, adr, pno);
  1217.           WriteLn; WriteString(" - "); WriteString(FileName);
  1218.           IF hdr # NIL THEN importMod := hdr^.right
  1219.           ELSE impok := FALSE;
  1220.             importMod := NIL; WriteString(" not found (or bad)")
  1221.           END
  1222.         END;
  1223.         GetSym
  1224.       ELSE err(10)
  1225.       END;
  1226.     END ImportModule;
  1227.  
  1228.     PROCEDURE Out(n: INTEGER);
  1229.       VAR k: INTEGER;
  1230.           d: ARRAY [0..5] OF INTEGER;
  1231.     BEGIN k := 0; Write(" ");
  1232.       REPEAT d[k] := n MOD 10; n := n DIV 10; INC(k) UNTIL n = 0;
  1233.       REPEAT DEC(k); Write(VAL(CHAR,d[k]+60B)) UNTIL k = 0
  1234.     END Out;
  1235.  
  1236.   BEGIN isdef := FALSE; isimp := FALSE; impok := TRUE;
  1237.     curLev := 0; curPrio := 0; mno := 0;
  1238.     (*FName := "DK.";*) GetSym;
  1239.     IF sym = definition THEN GetSym; isdef := TRUE
  1240.     ELSIF sym = implementation THEN GetSym; isimp := TRUE
  1241.     END;
  1242.     IF sym = module THEN
  1243.       GetSym;
  1244.       IF sym = ident THEN
  1245.         id0 := id; mainmod^.name := id0; KeepId; GetSym;
  1246.         IF NOT isdef THEN Priority END;
  1247.         CheckSym(semicolon, 12); MarkHeap; NewScope(Module);
  1248.         IF isimp THEN
  1249.           GetFileName(id0, FName, ".SBM");
  1250.           InRef(FName, hdr, adr, pno);
  1251.           WriteLn; WriteString(" - "); WriteString(FName);
  1252.           IF hdr # NIL THEN importMod := hdr^.right;
  1253.                topScope^.right := importMod^.root;  (*mainmod*)
  1254.                topScope^.next := hdr^.next; topScope^.last := hdr^.last
  1255.           ELSE importMod := NIL;
  1256.             WriteString(" not found (or bad)"); impok := FALSE
  1257.           END
  1258.         ELSE adr := GlbVarStartAdr; pno := 0; mainmod^.key := sysmod^.key
  1259.         END;
  1260.         WHILE (sym = from) OR (sym = import) DO
  1261.           IF sym = from THEN
  1262.             GetSym; ImportModule; CheckSym(import, 30);
  1263.             ImportList(importMod)
  1264.           ELSE (*sym = import*) GetSym;
  1265.             LOOP ImportModule;
  1266.               IF importMod # NIL THEN NewImp(topScope, importMod) END;
  1267.               IF sym = comma THEN GetSym
  1268.               ELSIF sym # ident THEN EXIT
  1269.               END
  1270.             END;
  1271.             CheckSym(semicolon, 12)
  1272.           END
  1273.         END;
  1274.         IF sym = export THEN
  1275.           GetSym; err(38);
  1276.           WHILE sym # semicolon DO GetSym END;
  1277.           GetSym
  1278.         END;
  1279.         IF impok THEN
  1280.           IF isdef THEN
  1281.             GetFileName(id0, FName, ".SBM");
  1282.           ELSE
  1283.             GetFileName(id0, FName, ".RFM");
  1284.             GenEnterMod(ModList, ModNo, pno); L0 := 0; GenFJ(L0)
  1285.           END;
  1286.           AddPath(path, FName, TName);
  1287.           WriteLn;
  1288.           ExtLookup(RefFile, TName, TRUE, ok);
  1289.           IF ok THEN
  1290.             GetCurrentPath(path1);
  1291.             WriteString(" + "); WriteString(path1); WriteString(FName);
  1292.           ELSE
  1293.             WriteString(" + "); WriteString(FName); WriteString(" not opened")
  1294.           END;
  1295.           OpenRef; Block(mainmod, TRUE, adr, L0);
  1296.           IF sym # period THEN err(14) END;
  1297.           IF NOT scanerr THEN
  1298.             IF NOT isdef THEN
  1299.               GenExitMod;
  1300.               GetFileName(id0, FName, ".OBM"); AddPath(path, FName, TName);
  1301.               WriteLn; WriteString(" + ");
  1302.               OutCodeFile(TName, mainmod^.key, ABS(adr), pno, id0, ModList);
  1303.               GetCurrentPath(path1);
  1304.               WriteString(path1); WriteString(FName); Out(pc);
  1305.             END;
  1306.             CloseRef(adr, pno); Close(RefFile);
  1307.             IF RefFile.res = notdone THEN err(223) END;
  1308.           ELSE Delete(RefFile)
  1309.           END
  1310.         END;
  1311.         CloseScope; ReleaseHeap
  1312.       ELSE err(10)
  1313.       END;
  1314.     ELSE err(28)
  1315.     END;
  1316.     IF scanerr THEN WriteString(" errors detected") END
  1317.   END CompilationUnit;
  1318.  
  1319.  
  1320. BEGIN
  1321.   ProcessorID(processor); WriteString(processor);
  1322.   WriteString(" Modula-2 Compiler V2.6.7."); WriteLn;
  1323.   WriteString("ETH Zuerich, NW/HS/WH, 11-Nov-94."); WriteLn;
  1324.   Lookup(source, 'err.DAT', FALSE); FileName[0] := 0C;
  1325.   IF source.res = done THEN
  1326.     LOOP ReadChar(source, ch);
  1327.       IF ch = 300C THEN i := 0;
  1328.         REPEAT ReadChar(source, ch); FileName[i] := ch; INC(i) UNTIL ch = 0C;
  1329.       ELSE EXIT;
  1330.       END;
  1331.     END;
  1332.     Close(source);
  1333.   END;
  1334.   LOOP rngchk := TRUE; ovflchk := FALSE;
  1335.     WriteString("in> ");
  1336.     ReadFileName(FileName, "MOD", "TEXT", BusyRead, Write, ok);
  1337.     IF NOT ok THEN EXIT END;
  1338.     IF termCh = "/" THEN Write("/");
  1339.       LOOP Read(ch); ch := CAP(ch);
  1340.         IF ch = "R" THEN Write(ch); rngchk := FALSE
  1341.         ELSIF ch = "V" THEN Write(ch); ovflchk := TRUE
  1342.         ELSIF ch <= " " THEN EXIT
  1343.         ELSE Write("?")
  1344.         END
  1345.       END
  1346.     END;
  1347.     ExtLookup(source, FileName, FALSE, ok);
  1348.     IF ok THEN
  1349.       GetCurrentPath(path);
  1350.       AddPath(path, FileName, FileName);
  1351.       GetTime(TM);
  1352.       WITH sysmod^.key^ DO
  1353.         k0 := VAL(INTEGER, TM.day); k1 := VAL(INTEGER, TM.minute);
  1354.         k2 := VAL(INTEGER, TM.millisecond);
  1355.       END;
  1356.       InitScanner(FileName); InitTableHandler; InitRef;
  1357.       InitM2LM; InitM2HM; InitM2EM;
  1358.       CompilationUnit; Close(source);
  1359.     ELSE WriteString(" -- not found");
  1360.     END;
  1361.     WriteLn; FileName[0] := 0C;
  1362.   END;
  1363.   CloseScanner; WriteLn;
  1364.  
  1365.  
  1366. END Compile. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  1367.