home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / COPASC.ZIP / BLOCKC.MOD < prev    next >
Encoding:
Text File  |  1987-09-07  |  8.6 KB  |  327 lines
  1.       procedure IFSTATEMENT;
  2.       var X: ITEM;
  3.       LC1,LC2: integer;
  4.       begin
  5.     INSYMBOL;
  6.     EXPRESSION(FSYS+[thenSY,DOSY], X);
  7.     if NOT (X.TYP in [BOOLS,NOTYP]) then ERROR(17);
  8.     LC1 := LC;
  9.     EMIT(11);  { JMPC }
  10.     if SY = thenSY then INSYMBOL else begin
  11.       ERROR(52);
  12.       if SY = DOSY then INSYMBOL;
  13.     end;
  14.     STATEMENT(FSYS+[elseSY]);
  15.     if SY = elseSY then begin
  16.       INSYMBOL;
  17.       LC2 := LC;
  18.       EMIT(10);
  19.       CODE[LC1].Y := LC;
  20.       STATEMENT(FSYS);
  21.       CODE[LC2].Y := LC;
  22.     end else CODE[LC1].Y := LC;
  23.       end;  { IFSTATEMENT }
  24.  
  25.       procedure CASESTATEMENT;
  26.       var X: ITEM;
  27.       I,J,K,LC1: integer;
  28.       CASETAB: array [1..CSMAX] of record
  29.              VAL,
  30.              LC     : INDEX
  31.            end;
  32.       EXITTAB: array [1..CSMAX] of integer;
  33.  
  34.     procedure CASELABEL;
  35.     var LAB: CONREC; K: integer;
  36.     begin
  37.       CONSTANT(FSYS+[COMMA,COLON], LAB);
  38.       if LAB.TP <> X.TYP then ERROR(47) else
  39.       if I = CSMAX then FATAL(6) else begin
  40.         I := I+1;
  41.         K := 0;
  42.         CASETAB[I].VAL := LAB.I;
  43.         CASETAB[I].LC := LC;
  44.         repeat
  45.           K := K+1
  46.         until CASETAB[K].VAL = LAB.I;
  47.         if K < I then ERROR(1);   (*MULTIPLE DEFINITION*)
  48.       end;
  49.     end; (*CASELABEL*)
  50.  
  51.     procedure ONECASE;
  52.     begin if SY in CONSTBEGSYS then
  53.       begin CASELABEL;
  54.         while SY = COMMA do begin
  55.           INSYMBOL;
  56.           CASELABEL
  57.         end;
  58.         if SY = COLON then INSYMBOL else ERROR(5);
  59.         STATEMENT([SEMICOLON,ENDSY]+FSYS);
  60.         J := J + 1;
  61.         EXITTAB[J] := LC; EMIT(10)
  62.       end
  63.     end (*ONECASE*) ;
  64.  
  65.       begin
  66.     INSYMBOL;
  67.     I := 0;
  68.     J := 0;
  69.     EXPRESSION(FSYS+[OFSY,COMMA,COLON], X);
  70.     if NOT (X.TYP in [INTS,BOOLS,CHARS,NOTYP]) then ERROR(23);
  71.     LC1 := LC; EMIT(12);  (*JMPX*)
  72.     if SY = OFSY then INSYMBOL else ERROR(8);
  73.     ONECASE;
  74.     while SY = SEMICOLON do begin
  75.       INSYMBOL;
  76.       ONECASE
  77.     end;
  78.     CODE[LC1].Y := LC;
  79.     for K := 1 TO I do begin
  80.       EMIT1(13,CASETAB[K].VAL);
  81.       EMIT1(13,CASETAB[K].LC)
  82.     end;
  83.     EMIT1(10,0);
  84.     for K := 1 TO J do CODE[EXITTAB[K]].Y := LC;
  85.     if SY = ENDSY then INSYMBOL else ERROR(57)
  86.       end (*CASESTATEMENT*) ;
  87.  
  88.       procedure repeatSTATEMENT;
  89.       var X: ITEM; LC1: integer;
  90.       begin
  91.     LC1 := LC;
  92.     INSYMBOL; STATEMENT([SEMICOLON,UNTILSY]+FSYS);
  93.     while SY in [SEMICOLON]+STATBEGSYS do begin
  94.       if SY = SEMICOLON then INSYMBOL else ERROR(14);
  95.       STATEMENT([SEMICOLON,UNTILSY]+FSYS)
  96.     end;
  97.     if SY = UNTILSY then begin
  98.       INSYMBOL; EXPRESSION(FSYS, X);
  99.       if NOT (X.TYP in [BOOLS,NOTYP]) then ERROR(17);
  100.       EMIT1(11,LC1)
  101.     end else ERROR(53)
  102.       end (*repeatSTATEMENT*) ;
  103.  
  104.       procedure whileSTATEMENT;
  105.       var X: ITEM; LC1,LC2: integer;
  106.       begin
  107.     INSYMBOL;
  108.     LC1 := LC;
  109.     EXPRESSION(FSYS+[DOSY], X);
  110.     if NOT (X.TYP in [BOOLS,NOTYP]) then ERROR(17);
  111.     LC2 := LC; EMIT(11);
  112.     if SY = DOSY then INSYMBOL else ERROR(54);
  113.     STATEMENT(FSYS);
  114.     EMIT1(10,LC1);
  115.     CODE[LC2].Y := LC
  116.       end; (* WHILESTATEMENT *)
  117.  
  118.       procedure FORSTATEMENT;
  119.       var CVT : TYPES;
  120.       X   : ITEM;
  121.       I,F,LC1,LC2 : integer;
  122.       begin
  123.     INSYMBOL;
  124.     if SY = IDENT then begin
  125.       I := LOC(ID);
  126.       INSYMBOL;
  127.       if I = 0 then CVT := INTS
  128.         else if TAB[I].OBJ = VARIABLE then begin
  129.           CVT := TAB[I].TYP;
  130.           if NOT TAB[I].NORMAL then ERROR(37)
  131.         else EMIT2(0, TAB[I].LEV, TAB[I].ADR);
  132.           if NOT (CVT in [NOTYP,INTS,BOOLS,CHARS]) then ERROR(18)
  133.         end else begin
  134.           ERROR(37);
  135.           CVT := INTS
  136.         end
  137.       end else SKIP([BECOMES,TOSY,DOWNTOSY,DOSY]+FSYS, 2);
  138.       if SY = BECOMES then begin
  139.         INSYMBOL;
  140.         EXPRESSION([TOSY,DOWNTOSY,DOSY]+FSYS, X);
  141.         if X.TYP <> CVT then ERROR(19);
  142.       end else SKIP([TOSY,DOWNTOSY,DOSY]+FSYS, 51);
  143.     F := 14;
  144.     if SY in [TOSY, DOWNTOSY] then begin
  145.       if SY = DOWNTOSY then F := 16;
  146.       INSYMBOL;
  147.       EXPRESSION([DOSY]+FSYS, X);
  148.       if X.TYP <> CVT then ERROR(19)
  149.     end else SKIP([DOSY]+FSYS, 55);
  150.     LC1 := LC; EMIT(F);
  151.     if SY = DOSY then INSYMBOL else ERROR(54);
  152.     LC2 := LC;
  153.     STATEMENT(FSYS);
  154.     EMIT1(F+1,LC2);
  155.     CODE[LC1].Y := LC
  156.       end; (* FORSTATEMENT *)
  157.  
  158.       procedure STANDPROC( N : integer );
  159.       var I,F : integer;
  160.       X,Y : ITEM;
  161.       begin
  162.     case N of
  163.    1,2: begin (* READ *)
  164.       if NOT ifLAG then begin
  165.         ERROR(59);
  166.         IFLAG := TRUE;
  167.       end;
  168.       if SY = LPARENT then begin
  169.         repeat
  170.           INSYMBOL;
  171.           if DFLAG AND ( SY <> IDENT ) then begin
  172.         I := pos( ' ', ID );
  173.         if copy( ID, 1, i-1 ) = copy( DFILE, 11-i, i-1 )
  174.           then INSYMBOL else ERROR(2);
  175.           end;
  176.           if SY <> IDENT then ERROR(2) else begin
  177.         I := LOC(ID);
  178.         INSYMBOL;
  179.         if I <> 0 then if TAB[I].OBJ <> VARIABLE
  180.           then ERROR(37) else begin
  181.             X.TYP := TAB[I].TYP;
  182.             X.REF := TAB[I].REF;
  183.             if TAB[I].NORMAL then F := 0 else F := 1;
  184.             EMIT2(F, TAB[I].LEV, TAB[I].ADR);
  185.             if SY in [LBRACK,LPARENT,PERIOD] then
  186.               SELECTOR(FSYS+[COMMA,RPARENT], X);
  187.             if X.TYP in [INTS,REALS,CHARS,NOTYP] then
  188.               EMIT1(27,ORD(X.TYP)) else ERROR(41)
  189.         end;
  190.           end;
  191.           TEST([COMMA,RPARENT], FSYS, 6);
  192.         until SY <> COMMA;
  193.         if SY = RPARENT then INSYMBOL else ERROR(4)
  194.       end;
  195.       if N = 2 then EMIT(62)
  196.     end;
  197.  
  198.    3,4: begin { WRITE }
  199.       if SY = LPARENT then begin
  200.         repeat
  201.           INSYMBOL;
  202.           if SY = WORD then begin
  203.         EMIT1(24,SLENG);
  204.         EMIT1(28,INUM);
  205.         INSYMBOL;
  206.           end else begin
  207.         EXPRESSION(FSYS+[COMMA,COLON,RPARENT], X);
  208.         if NOT (X.TYP in STANTYPS) then ERROR(41);
  209.         if SY = COLON then begin
  210.           INSYMBOL;
  211.           EXPRESSION(FSYS+[COMMA,COLON,RPARENT], Y);
  212.           if Y.TYP <> INTS then ERROR(43);
  213.           if SY = COLON then begin
  214.             if X.TYP <> REALS then ERROR(42);
  215.             INSYMBOL;
  216.             EXPRESSION(FSYS+[COMMA,RPARENT], Y);
  217.             if Y.TYP <> INTS then ERROR(43);
  218.             EMIT(37)
  219.           end else EMIT1(30, ORD(X.TYP))
  220.         end
  221.         else EMIT1(29, ORD(X.TYP))
  222.           end
  223.         until SY <> COMMA;
  224.         if SY = RPARENT then INSYMBOL else ERROR(4)
  225.       end;
  226.       if N = 4 then EMIT(63)
  227.     end;
  228.     5,6:  { WAIT,SIGNAL }
  229.       if SY <> LPARENT then ERROR(9) else begin
  230.     INSYMBOL;
  231.     if SY<>IDENT then ERROR(0) else begin
  232.       I := LOC(ID);
  233.       INSYMBOL;
  234.       if I <> 0 then if TAB[I].OBJ <> VARIABLE then ERROR(37)
  235.         else begin
  236.           X.TYP:=TAB[I].TYP;
  237.           X.REF:=TAB[I].REF;
  238.           if TAB[I].NORMAL then F:=0 else F:=1;
  239.           EMIT2(F,TAB[I].LEV,TAB[I].ADR);
  240.           if SY in [LBRACK,LPARENT,PERIOD] then SELECTOR(FSYS+[RPARENT],X);
  241.           if X.TYP=INTS then EMIT(N+1) else ERROR(43)
  242.           end
  243.         end;
  244.         if SY=RPARENT then INSYMBOL else ERROR(4)
  245.       end;
  246.     end (* CASE *)
  247.       end; (* STANDPROC *)
  248.  
  249.     begin (*STATEMENT*)
  250.       if SY in STATBEGSYS+[IDENT] then
  251.       case SY of
  252.         IDENT:    begin
  253.             I := LOC(ID);
  254.             INSYMBOL;
  255.             if I <> 0 then case TAB[I].OBJ of
  256.  
  257.               KONSTANT,
  258.               TYPE1       : ERROR(45);
  259.               VARIABLE : ASSIGNMENT(TAB[I].LEV, TAB[I].ADR);
  260.               PROZEDURE: if TAB[I].LEV <> 0 then CALL(FSYS, I)
  261.                        else STANDPROC(TAB[I].ADR);
  262.               FUNKTION : if TAB[I].REF = DISPLAY[LEVEL]
  263.                        then ASSIGNMENT(TAB[I].LEV+1, 0)
  264.                      else ERROR(45);
  265.             end; (* case *)
  266.               end;
  267.  
  268.         BEGINSY  :    if ID = 'COBEGIN   ' then begin
  269.               EMIT(4);
  270.               COMPOUNDSTMNT;
  271.               EMIT(5)
  272.             end else COMPOUNDSTMNT;
  273.  
  274.         IFSY     :       IFSTATEMENT;
  275.         CASESY   :     CASESTATEMENT;
  276.         WHILESY  :    WHILESTATEMENT;
  277.         REPEATSY : REPEATSTATEMENT;
  278.         FORSY    :      FORSTATEMENT;
  279.       end;
  280.     TEST(FSYS, [], 14)
  281.     end (*STATEMENT*) ;
  282.  
  283. begin (*BLOCK*)
  284.   DX := 5;
  285.   PRT := T;
  286.   if LEVEL > LMAX then FATAL(5);
  287.   TEST([LPARENT,COLON,SEMICOLON], FSYS, 14);
  288.   ENTERBLOCK;
  289.   DISPLAY[LEVEL] := B;
  290.   PRB := B;
  291.   TAB[PRT].TYP := NOTYP;
  292.   TAB[PRT].REF := PRB;
  293.   if ( SY = LPARENT ) AND ( LEVEL > 1 ) then PARAMETERLIST;
  294.   BTAB[PRB].LASTPAR := T;
  295.   BTAB[PRB].PSIZE := DX;
  296.   if ISFUN then
  297.     if SY = COLON then begin
  298.       INSYMBOL;      (*FUNCTION TYPE*)
  299.       if SY = IDENT then begin
  300.     X := LOC(ID);
  301.     INSYMBOL;
  302.     if X <> 0 then
  303.       if TAB[X].OBJ <> TYPE1 then ERROR(29) else
  304.         if TAB[X].TYP in STANTYPS then TAB[PRT].TYP := TAB[X].TYP
  305.           else ERROR(15)
  306.       end else SKIP([SEMICOLON]+FSYS, 2)
  307.     end else ERROR(5);
  308.   if SY = SEMICOLON then INSYMBOL else ERROR(14);
  309.   repeat
  310.     if SY = CONSTSY then CONSTDECLARATION;
  311.     if SY =  TYPESY then  TYPEDECLARATION;
  312.     if SY =   VARSY then    VARDECLARTION;
  313.     BTAB[PRB].VSIZE := DX;
  314.     while SY in [PROCSY,FUNCSY] do PROCDECLARATION;
  315.     TEST([BEGINSY], BLOCKBEGSYS+STATBEGSYS, 56)
  316.   until SY in STATBEGSYS;
  317.   TAB[PRT].ADR := LC;
  318.   INSYMBOL;
  319.   STATEMENT([SEMICOLON,ENDSY]+FSYS);
  320.   while SY in [SEMICOLON]+STATBEGSYS do begin
  321.     if SY = SEMICOLON then INSYMBOL else ERROR(14);
  322.     STATEMENT([SEMICOLON,ENDSY]+FSYS)
  323.   end;
  324.   if SY = ENDSY then INSYMBOL else ERROR(57);
  325.   TEST(FSYS+[PERIOD], [], 6)
  326. end; { block }
  327.