(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*     Implementation for Lilith         *
*                                       *
*                                       *
*     M2Pass3:                          *
*                                       * 
*     Pass 3                            *
*     Body analysis                     *
*                                       * 
*     Version C18 of 25.09.81           *
*                                       *
*     Institut fuer Informatik          *
*     ETH-Zuerich                       *
*     CH-8092 Zuerich                   *
*                                       *
****************************************)

IMPLEMENTATION MODULE M2Pass3;    (* LG *)

  (* $T+ *)
  FROM WriteStrings IMPORT WriteString, WriteLn;
  FROM MCBase IMPORT
    Idptr, Stptr, Idclass, Idset, Structform, Stset,
    Constval, Levrange, Symbol, intptr, intcarptr, noprio;
  FROM MCP3IO IMPORT
    sy, nptr, PutSy, Error, ErrorLS,
    GetSy, PutGetSy, InitInOut, TermInOut;
  FROM MCP3Ident IMPORT
    FAmong,
    NewImpList, TermImpList, EnterImpList, DisposeImpList,
    SearchId, ExportSearch,
    MarkModScope, ReleaseModScope,
    MarkProcScope, ReleaseProcScope,
    MarkWithScope, ReleaseWithScope, FieldIndex,
    BodyMark, BodyScopes;
  FROM SYSTEM IMPORT TSIZE;
  FROM Storage IMPORT ALLOCATE, DEALLOCATE;
  FROM M2Pass3PV IMPORT
    scalars, oneword, doubleword, charmax, QualIdent, nestlevel;
  FROM P3Exp IMPORT
      Expression, TypeExpression, ExprSequence,
      ParamCheck, StProcCheck,
      ExprComp, AssignComp, AddressComp,
      Selector, PreSelector, Attribut, Attributmode,
      ConstantRange, ConstantVal, PutConst, InitAt;

PROCEDURE Pass3;


  (* MODULE ExpressionSystem; - now in P3Exp *)

  PROCEDURE ModulDeclaration; 
    VAR mptr : Idptr; 

    PROCEDURE ImportList;
      (* analyse import list of a module *) 
      VAR ip, ep : Idptr; 
          frommod : BOOLEAN; 
    BEGIN 
      NewImpList(mptr^.impp); 
      WHILE (sy = importsy) OR (sy = fromsy) DO 
        frommod := sy = fromsy;
        GetSy; 
        IF frommod THEN 
          SearchId(ip); 
          IF (ip = NIL) OR (ip^.klass <> mods) THEN (* skip this list *) 
            Error(105);
            WHILE sy = ident DO GetSy END; 
          ELSE 
            GetSy;
            ep := ip^.expp; 
          END; 
        END; 
        WHILE sy = ident DO (* identifier skipped if module not found *) 
          IF frommod THEN
            ExportSearch(ep,ip); 
            IF ip = NIL THEN Error(71) END; 
          ELSE
            SearchId(ip); 
            IF ip = NIL THEN Error(73) END;
          END; 
          IF ip <> NIL THEN EnterImpList(ip) END; 
          GetSy; 
        END; (* while *) 
      END; (* while *) 
      TermImpList(mptr^.impp); 
    END ImportList; 

  BEGIN mptr := nptr; 
    GetSy;
    ImportList;
    MarkModScope(mptr);
    Block(mptr);
    ReleaseModScope;
    DisposeImpList(mptr^.impp);
    GetSy; (* endblock *)
  END ModulDeclaration;
 
  PROCEDURE Block(bptr : Idptr);
    VAR inloop : BOOLEAN;
        priority : CARDINAL;

    PROCEDURE BlockDeclaration;
      VAR lnptr: Idptr;

    BEGIN lnptr := nptr;
      PutGetSy;
      MarkProcScope(lnptr);
      INC(nestlevel);
      Block(lnptr); 
      ReleaseProcScope;
      DEC(nestlevel);
      PutGetSy; (* endblock *)
    END BlockDeclaration;

    PROCEDURE Statement;

      PROCEDURE StatSeq1(s1 : Symbol);
      BEGIN
        WHILE sy <> s1 DO Statement END
      END StatSeq1; 

      PROCEDURE StatSeq2(s1,s2 : Symbol);
      BEGIN
        WHILE (sy <> s1) AND (sy <> s2) DO Statement END
      END StatSeq2; 

      PROCEDURE StatSeq3(s1,s2,s3 : Symbol);
      BEGIN
        WHILE (sy <> s1) AND (sy <> s2) AND (sy <> s3) DO Statement END
      END StatSeq3; 

      PROCEDURE Assignment;
        VAR at1,at2 : Attribut;
            x : Idptr;
      BEGIN
        InitAt(at1);
        QualIdent(Idset{vars,fields},122,x);
        IF x <> NIL THEN
          PreSelector(x,at1); 
          Selector(at1);
          PutGetSy; (* comma *)
          Expression(at2);
          IF NOT (AssignComp(at1,at2) OR AddressComp(at1,at2)) THEN
            ErrorLS(128)
          END;
        ELSE
          Selector(at1);
          PutGetSy; (* comma *)
          Expression(at2);
        END;
      END Assignment;

      PROCEDURE CallStatement;
        VAR x : Idptr;
            ok : BOOLEAN;
            at : Attribut;
            fp : Idptr;

        PROCEDURE SkipCall;
          (* skip semantical incorrect parts of call *)
          VAR at: Attribut;
        BEGIN
          InitAt(at);
          Selector(at);
          PutGetSy; (* lparent *)
          ExprSequence;
        END SkipCall;

      BEGIN
        IF sy = namesy THEN x := nptr; GetSy; (* module bodies *)
        ELSE QualIdent(Idset{vars,fields,pures,funcs},73,x);
        END;
        IF x <> NIL THEN
          IF (x^.klass = pures) AND x^.isstandard THEN
            IF sy = lparent THEN StProcCheck(x);
            ELSE Error(144); SkipCall;
            END;
          ELSIF (x^.klass = funcs) AND x^.isstandard THEN
            IF sy = lparent THEN ErrorLS(157) ELSE Error(144) END;
            SkipCall;
          ELSE
            PreSelector(x,at);
            IF at.mode = varm THEN
              Selector(at);
            ELSE (* pures, funcs, mods *)
              WITH x^ DO
                IF (priolev <> priority) AND (priolev <> noprio) THEN
                  IF (priority = noprio) OR (priority < priolev) THEN
                    externalaccess := TRUE;
                  ELSE
                    ErrorLS(161);
                  END;
                END;
              END;
            END;
            ok := TRUE;
            IF at.atp = NIL THEN fp := NIL; (* may be a module call *)
            ELSE
              WITH at.atp^ DO
                IF (form = proctypes) AND (rkind <> funcs) THEN
                  fp := fstparam;
                ELSE ErrorLS(157); ok := FALSE;
                END;
              END; (* WITH *) 
            END;
            ok := ok AND (sy = lparent);
            IF ok THEN
              PutGetSy; (* lparent *)
              ParamCheck(fp);
            ELSE
              IF sy <> lparent THEN Error(144) END;
              SkipCall;
            END;
          END;
        ELSE (* x = NIL *)
          SkipCall;
        END;
      END CallStatement;

      PROCEDURE IfStatement;
        VAR at : Attribut;
      BEGIN
        LOOP TypeExpression(at,Stset{bools});
          StatSeq3(endsy,elsesy,elsifsy);
          IF sy <> elsifsy THEN EXIT END;
          PutGetSy; 
        END;
        IF sy = elsesy THEN PutGetSy; StatSeq1(endsy) END;
        PutGetSy; (* endsy *) 
      END IfStatement;

      PROCEDURE WithStatement;
        VAR x : Idptr;
            ltp : Stptr;
            at : Attribut;
            isrecord : BOOLEAN;
      BEGIN
        QualIdent(Idset{vars,fields},122,x);
        IF x <> NIL THEN PreSelector(x,at);
          Selector(at);
        ELSE InitAt(at);
          Selector(at);
        END;
        ltp := at.atp;
        isrecord := FAmong(ltp,Stset{records}); 
        IF isrecord THEN MarkWithScope(ltp^.fieldp);
        ELSE ErrorLS(121);
        END;
        StatSeq1(endsy);
        IF isrecord THEN ReleaseWithScope END;
        PutGetSy;
      END WithStatement;

      PROCEDURE CaseStatement;
        VAR at1,at2 : Attribut;
            c1, c2 : Constval;
      BEGIN
        TypeExpression(at1,scalars);
        WHILE sy = ofsy DO
          PutGetSy; 
          REPEAT
            WITH at2 DO
              mode := constm;
              ConstantRange(atp,c1,c2); 
              IF ExprComp(at1,at2) THEN
                PutConst(atp,c1);
                IF atp = intptr THEN
                  WHILE INTEGER(c1.value) < INTEGER(c2.value) DO
                    IF c1.value = 177777B THEN c1.value := 0 ELSE INC(c1.value) END;
                    PutConst(atp,c1);
                  END;
                ELSE
                  WHILE c1.value < c2.value DO
                    INC(c1.value);
                    PutConst(atp,c1);
                  END;
                END;
              ELSE ErrorLS(128);
              END;
            END;
          UNTIL sy = colon;
          PutGetSy; 
          StatSeq3(ofsy,elsesy,endsy);
        END;
        IF sy = elsesy THEN PutGetSy; StatSeq1(endsy) END;
        PutGetSy; (* endsy *) 
      END CaseStatement;

      PROCEDURE LoopStatement;
        VAR oldinloop : BOOLEAN;
      BEGIN
        oldinloop := inloop;
        inloop := TRUE;
        StatSeq1(endsy);
        PutGetSy;
        inloop := oldinloop;
      END LoopStatement;

      PROCEDURE ExitStatement;
      BEGIN
        IF NOT inloop THEN ErrorLS(151) END;
      END ExitStatement;

      PROCEDURE ReturnStatement;
        VAR at1,at2 : Attribut;
      BEGIN (* expression in parenthesis *)
        CASE bptr^.klass OF
          funcs : (* function block *)
            IF sy <> lparent THEN Error(153)
            ELSE
              PutGetSy; (* lparent *)
              Expression(at1);
              at2.atp := bptr^.idtyp^.funcp;
              at2.mode := varm;
              IF NOT (AssignComp(at2,at1) OR AddressComp(at1,at2)) THEN
                ErrorLS(155)
              END;
              PutGetSy; (* rparent *)
            END;
         |pures, mods : (* procedure or module block *)
            IF sy = lparent THEN Error(154); Expression(at1) END;
        END;
      END ReturnStatement;

      PROCEDURE ForStatement; 
        VAR at1,at2: Attribut;
            ip : Idptr;
            sp : Stptr;
            lval : Constval;
      BEGIN
        QualIdent(Idset{vars},122,ip); (* single identifier expected *)
        IF ip <> NIL THEN
          PreSelector(ip,at1); 
          Selector(at1);
          IF NOT FAmong(at1.atp,scalars) THEN ErrorLS(139) END;
        ELSE
          InitAt(at1); Selector(at1);
        END;
        PutGetSy; (* comma *)
        LOOP
          TypeExpression(at2,scalars);
          IF NOT AssignComp(at1,at2) THEN Error(128) END;
          IF sy = tosy THEN PutGetSy ELSE EXIT END;
        END; (* LOOP *)
        IF sy = bysy THEN
          PutGetSy; 
          ConstantVal(sp,lval);
          PutConst(sp,lval);
          IF NOT FAmong(sp,Stset{ints,cards}) THEN ErrorLS(156) END;
        END;
        StatSeq1(endsy);
        PutGetSy;
      END ForStatement;

      PROCEDURE RepeatStatement;
        VAR at : Attribut;
      BEGIN StatSeq1(untilsy); PutGetSy;
       TypeExpression(at,Stset{bools});
      END RepeatStatement;

      PROCEDURE WhileStatement;
        VAR at : Attribut;
      BEGIN TypeExpression(at,Stset{bools});
        StatSeq1(endsy); PutGetSy;
      END WhileStatement;

      VAR lsy : Symbol; (* leading symbol in statement *)

    BEGIN (* Statement *)
      lsy := sy; PutGetSy;
      CASE lsy OF
        becomes: Assignment;
       |call: CallStatement;
       |ifsy: IfStatement; 
       |withsy: WithStatement
       |casesy: CaseStatement
       |loopsy: LoopStatement
       |whilesy: WhileStatement
       |repeatsy: RepeatStatement
       |forsy: ForStatement
       |returnsy: ReturnStatement
       |exitsy: ExitStatement
      ELSE (* nothing *)
      END;
    END Statement;

    PROCEDURE CodeSequence;

      CONST maxcodebuff = 50;

      TYPE Codebuffer = ARRAY [1..maxcodebuff] OF CARDINAL;
           Codeptr = POINTER TO Codebuffer;

      VAR codes , entry : Codeptr;
          ix : CARDINAL;

      PROCEDURE Code;
        CONST maxcodeval = 377B;
        VAR ctp : Stptr;
            cval : Constval;
      BEGIN
        ConstantVal(ctp,cval);
        IF FAmong(ctp,Stset{ints,cards}) THEN
          IF (ctp = intcarptr) AND (cval.value <= maxcodeval) THEN
            IF ix < maxcodebuff THEN
              INC(ix);
              codes^[ix] := cval.value;
            ELSE
              ErrorLS(159);
            END;
          ELSE
            ErrorLS(160);
          END;
        ELSE
          ErrorLS(156);
        END;
      END Code;

    BEGIN (* CodeSequence *)
      NEW(codes);
      ix := 0;
      WHILE sy <> endblock DO Code END;
      IF bptr^.klass <> mods THEN
        bptr^.codeproc := TRUE;
        bptr^.codelength := ix;
        IF ix > 0 THEN
          ALLOCATE(entry,ix*TSIZE(CARDINAL));
          (* array structure is overlayed for entry *)
          WHILE ix > 0 DO
            entry^[ix] := codes^[ix];
            DEC(ix);
          END;
        ELSE
          entry := NIL;
        END;
        bptr^.codeentry := CARDINAL(entry);
      END;
      DISPOSE(codes);
    END CodeSequence;

  BEGIN (* Block *) 
    IF sy = codesy THEN
      PutGetSy;
      CodeSequence;
    ELSE
      REPEAT
        IF sy = proceduresy THEN BlockDeclaration;
        ELSIF sy = modulesy THEN ModulDeclaration
        END;
      UNTIL (sy = beginsy) OR (sy = endblock);
      inloop := FALSE;
      priority := bptr^.priolev;
      BodyMark;
      IF sy = beginsy THEN PutGetSy;
        WHILE sy <> endblock DO Statement END;
      END;
      (* update space used by procedure on stack *)
      INC(bptr^.varlength,BodyScopes()*oneword);
    END;
  END Block;

  PROCEDURE StartBodyAnalysis;
  BEGIN
    GetSy; nestlevel := 0;
    IF sy = modulesy THEN ModulDeclaration; END;
    PutSy(endblock); (* temporary *)
  END StartBodyAnalysis;

BEGIN (* Pass3 *)
  InitInOut;
  StartBodyAnalysis;
  TermInOut;
END Pass3;


END M2Pass3.