home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / COPASC.ZIP / BLOCKB.MOD < prev    next >
Encoding:
Text File  |  1987-09-07  |  7.8 KB  |  297 lines
  1.  
  2. (*---------------------------------------------------EXPRESSION-----*)
  3.  
  4.       procedure EXPRESSION (* FSYS: SYMSET; var X: ITEM *) ;
  5.       (*
  6.      Note: dynamic variables for Y have been used due to the
  7.            constraints imposed upon local variables in recursion.
  8.       *)
  9.  
  10.       type ITEMptr = ^ITEM;   (* static > dynamic : SCHOENING *)
  11.       var Y  : ITEMptr;
  12.       OP : SYMBOL;
  13.  
  14.     procedure SIMPLEEXPRESSION( FSYS : SYMSET; var X : ITEM );
  15.     var Y  : ITEMptr;
  16.         OP : SYMBOL;
  17.  
  18.       procedure TERM( FSYS : SYMSET; var X : ITEM );
  19.       var Y     : ITEMptr;
  20.           OP : SYMBOL;
  21.           TS : TYPSET;
  22.  
  23.         procedure FACTOR( FSYS : SYMSET; var X : ITEM );
  24.         var I, F : INTEGER;
  25.  
  26.           procedure STANDFCT( N : INTEGER );
  27.           var TS: TYPSET;
  28.           begin (*STANDARD FUNCTION NO. N*)
  29.         if SY = LPARENT then INSYMBOL else ERROR(9);
  30.         if ( N < 17 ) OR ( N=19 ) then begin
  31.           EXPRESSION( FSYS+[RPARENT], X );
  32.           case N of
  33.  
  34. { ABS, SQR }    0,2: begin
  35.                TS := [INTS,REALS];
  36.                TAB[I].TYP := X.TYP;
  37.                if X.TYP = REALS then N := N+1
  38.              end;
  39.  
  40. { ODD, CHR    } 4,5: TS := [INTS];
  41.  
  42. { ORD          } 6  : TS := [INTS,BOOLS,CHARS];
  43.  
  44. { SUCC,     PRED } 7,8: begin
  45.                TS := [INTS,BOOLS,CHARS];
  46.                TAB[I].TYP := X.TYP
  47.              end;
  48.  
  49. { ROUND,TRUNC } 9,10,11,12,13,14,15,16:
  50. { SIN,COS,... }         begin
  51.                TS := [INTS,REALS];
  52.                if X.TYP = INTS then EMIT1(26,0)
  53.              end;
  54.  
  55. { RANDOM      } 19:  begin
  56.                TS := [INTS];
  57.                TAB[I].TYP := X.TYP;
  58.              end;
  59.           end; (* case *)
  60.           if X.TYP in TS then EMIT1(8,N) else
  61.           if X.TYP <> NOTYP then ERROR(48);
  62.  
  63.         end else begin (* N in [17,18] *)
  64. { EOF, EOLN   }      if SY <> IDENT then ERROR(2) else
  65.           if ID <> 'INPUT     ' then ERROR(0) else INSYMBOL;
  66.           EMIT1(8,N);
  67.         end;
  68.         X.TYP := TAB[I].TYP;
  69.         if SY = RPARENT then INSYMBOL else ERROR(4)
  70.           end; (* STANDFCT *)
  71.  
  72.         begin (* FACTOR *)
  73.           X.TYP := NOTYP;
  74.           X.REF := 0;
  75.           TEST(FACBEGSYS, FSYS, 58);
  76.           while SY in FACBEGSYS do begin
  77. {   ID     }    if SY = IDENT then begin
  78.           I := LOC(ID);
  79.           INSYMBOL;
  80.           WITH TAB[I] do case OBJ of
  81.  
  82.           KONSTANT: begin
  83.               X.TYP := TYP;
  84.               X.REF := 0;
  85.               if X.TYP = REALS then EMIT1(25,ADR)
  86.                 else EMIT1(24,ADR)
  87.             end;
  88.  
  89.           VARIABLE: begin
  90.               X.TYP := TYP;
  91.               X.REF := REF;
  92.               if SY in [LBRACK,LPARENT,PERIOD] then begin
  93.                 if NORMAL then F := 0 else F := 1;
  94.                   EMIT2(F, LEV, ADR);
  95.                   SELECTOR(FSYS,X);
  96.                   if X.TYP in STANTYPS then EMIT(34)
  97.                 end else begin
  98.                   if X.TYP in STANTYPS then
  99.                 if NORMAL then F := 1 else F := 2
  100.                   else
  101.                 if NORMAL then F := 0 else F := 1;
  102.                   EMIT2(F, LEV, ADR)
  103.                 end;
  104.             end;
  105.  
  106.           TYPE1, PROZEDURE:       ERROR(44);
  107.  
  108.           FUNKTION : begin
  109.                X.TYP := TYP;
  110.                if LEV <> 0 then CALL(FSYS, I) else STANDFCT(ADR);
  111.              end
  112.  
  113.             end (*CASE,WITH*)
  114.           end else
  115.           if SY in [CHARCON,INTCON,REALCON] then begin
  116.              if SY = REALCON then begin
  117.                X.TYP := REALS;
  118.                ENTERREAL(RNUM);
  119.                EMIT1(25, C1)
  120.              end else
  121.              begin
  122.                if SY = CHARCON then X.TYP := CHARS
  123.                        else X.TYP := INTS;
  124.                EMIT1(24, INUM)
  125.              end;
  126.              X.REF := 0; INSYMBOL
  127.            end else
  128. {   (    }       if SY = LPARENT then begin
  129.              INSYMBOL;
  130.              EXPRESSION(FSYS+[RPARENT], X);
  131.              if SY = RPARENT then INSYMBOL else ERROR(4);
  132.            end else
  133. {  NOT    }       if SY = NOTSY then
  134.            begin
  135.              INSYMBOL;
  136.              FACTOR(FSYS,X);
  137.              if X.TYP=BOOLS then EMIT(35) else
  138.                if X.TYP<>NOTYP then ERROR(32)
  139.            end;
  140.           TEST(FSYS, FACBEGSYS, 6)
  141.         end (*while*)
  142.         end; (*FACTOR*)
  143.  
  144.       begin (*TERM*)
  145.         new( Y );
  146.         FACTOR(FSYS+[TIMES,RDIV,IDIV,IMOD,ANDSY], X);
  147.         while SY in [TIMES,RDIV,IDIV,IMOD,ANDSY] do begin
  148.         OP := SY;
  149.         INSYMBOL;
  150.         FACTOR(FSYS+[TIMES,RDIV,IDIV,IMOD,ANDSY], Y^ );
  151. {  *  }        if OP = TIMES then begin
  152.           X.TYP := RESULTTYPE(X.TYP, Y^.TYP);
  153.           case X.TYP of
  154.             NOTYP: ;
  155.             INTS : EMIT(57);
  156.             REALS: EMIT(60);
  157.           end
  158.         end else
  159. {  /  }        if OP = RDIV then begin
  160.           if X.TYP = INTS then begin
  161.             EMIT1(26,1);
  162.             X.TYP := REALS
  163.           end;
  164.           if Y^.TYP = INTS then begin
  165.             EMIT1(26,0);
  166.             Y^.TYP := REALS
  167.           end;
  168.           if (X.TYP=REALS) AND (Y^.TYP=REALS) then EMIT(61)
  169.             else begin
  170.               if (X.TYP<>NOTYP) AND (Y^.TYP<>NOTYP) then ERROR(33);
  171.               X.TYP := NOTYP
  172.             end
  173.         end else
  174. { AND }        if OP = ANDSY then begin
  175.           if (X.TYP=BOOLS) AND (Y^.TYP=BOOLS) then EMIT(56)
  176.             else begin
  177.               if (X.TYP<>NOTYP) AND (Y^.TYP<>NOTYP) then ERROR(32);
  178.               X.TYP := NOTYP
  179.             end
  180.         end else
  181. { DIV,MOD }    begin (*OP in [IDIV,IMOD]*)
  182.           if (X.TYP=INTS) AND (Y^.TYP=INTS) then
  183.             if OP=IDIV then EMIT(58) else EMIT(59)
  184.           else begin
  185.             if (X.TYP<>NOTYP) AND (Y^.TYP<>NOTYP) then ERROR(34);
  186.             X.TYP := NOTYP
  187.           end
  188.         end
  189.           end;
  190.         dispose( Y );
  191.       end (*TERM*) ;
  192.  
  193.     begin (*SIMPLEEXPRESSION*)
  194.       new( Y );
  195. { +, - }  if SY in [PLUS,MINUS] then begin
  196.         OP := SY;
  197.         INSYMBOL;
  198.         TERM(FSYS+[PLUS,MINUS], X);
  199.         if X.TYP > REALS then ERROR(33)
  200.           else if OP = MINUS then EMIT(36)
  201.       end else TERM( FSYS+[ PLUS,MINUS,ORSY ], X );
  202.       while SY in [PLUS,MINUS,ORSY] do begin
  203.         OP := SY;
  204.         INSYMBOL;
  205.         TERM(FSYS+[PLUS,MINUS,ORSY], Y^);
  206. { OR   }    if OP = ORSY then begin
  207.          if (X.TYP=BOOLS) AND (Y^.TYP=BOOLS) then EMIT(51)
  208.            else begin
  209.              if (X.TYP<>NOTYP) AND (Y^.TYP<>NOTYP) then ERROR(32);
  210.              X.TYP := NOTYP
  211.            end
  212.            end else begin
  213.          X.TYP := RESULTTYPE(X.TYP, Y^.TYP);
  214.          case X.TYP of
  215.            NOTYP: ;
  216.            INTS : if OP = PLUS then EMIT(52) else EMIT(53);
  217.            REALS: if OP = PLUS then EMIT(54) else EMIT(55);
  218.          end;
  219.            end;
  220.         end;
  221.       dispose( Y );
  222.     end; (* SIMPLEEXPRESSION *)
  223.  
  224.       begin (*EXPRESSION*)
  225.     new( Y );
  226.     SIMPLEEXPRESSION(FSYS+[EQL,NEQ,LSS,LEQ,GTR,GEQ], X);
  227.     if SY in [EQL,NEQ,LSS,LEQ,GTR,GEQ] then begin
  228.       OP := SY;
  229.       INSYMBOL;
  230.       SIMPLEEXPRESSION(FSYS, Y^ );
  231.       if (X.TYP in [NOTYP,INTS,BOOLS,CHARS]) AND (X.TYP = Y^.TYP) then
  232.         case OP of
  233.           EQL : EMIT(45);
  234.           NEQ : EMIT(46);
  235.           LSS : EMIT(47);
  236.           LEQ : EMIT(48);
  237.           GTR : EMIT(49);
  238.           GEQ : EMIT(50);
  239.         end else begin
  240.           if X.TYP = INTS then begin
  241.         X.TYP := REALS;
  242.         EMIT1(26,1)
  243.           end else if Y^.TYP = INTS then begin
  244.         Y^.TYP := REALS;
  245.         EMIT1(26,0);
  246.           end;
  247.           if (X.TYP=REALS) AND (Y^.TYP=REALS) then case OP of
  248.         EQL : EMIT(39);
  249.         NEQ : EMIT(40);
  250.         LSS : EMIT(41);
  251.         LEQ : EMIT(42);
  252.         GTR : EMIT(43);
  253.         GEQ : EMIT(44);
  254.           end else ERROR(35);
  255.         end;
  256.         X.TYP := BOOLS;
  257.       end;
  258.     dispose( Y );
  259.       end (*EXPRESSION*) ;
  260.  
  261.       procedure ASSIGNMENT(LV,AD: INTEGER);
  262.       var X,Y: ITEM; F: INTEGER;
  263.       (* TAB[I].OBJ in [VARIABLE,PROZEDURE] *)
  264.       begin
  265.     X.TYP := TAB[I].TYP;
  266.     X.REF := TAB[I].REF;
  267.     if TAB[I].NORMAL then F := 0 else F := 1;
  268.     EMIT2(F, LV, AD);
  269.     if SY in [LBRACK,LPARENT,PERIOD] then SELECTOR([BECOMES,EQL]+FSYS, X);
  270.     if SY = BECOMES then INSYMBOL else begin
  271.       ERROR(51);
  272.       if SY = EQL then INSYMBOL
  273.     end;
  274.     EXPRESSION(FSYS, Y);
  275.     if X.TYP = Y.TYP then
  276.       if X.TYP in STANTYPS then EMIT(38) else
  277.       if X.REF <> Y.REF then ERROR(46) else
  278.       if X.TYP = ARRAYS then EMIT1(23, ATAB[X.REF].SIZE)
  279.                 else EMIT1(23, BTAB[X.REF].VSIZE)
  280.     else
  281.     if (X.TYP=REALS) AND (Y.TYP=INTS) then begin
  282.       EMIT1(26,0); EMIT(38)
  283.     end else
  284.       if (X.TYP<>NOTYP) AND (Y.TYP<>NOTYP) then ERROR(46)
  285.       end; { ASSIGNMENT }
  286.  
  287.       procedure COMPOUNDSTMNT;
  288.       begin
  289.     INSYMBOL;
  290.     STATEMENT([SEMICOLON,endSY]+FSYS);
  291.     while SY in [SEMICOLON]+STATBEGSYS do begin
  292.       if SY = SEMICOLON then INSYMBOL else ERROR(14);
  293.       STATEMENT([SEMICOLON,endSY]+FSYS)
  294.     end;
  295.     if SY = EndSy then InSymbol else ERROR(57)
  296.       end; { CompuundStatement }
  297.