home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d1xx / d183 / pcq.lha / PCQ / Source / Statements.p < prev    next >
Text File  |  1989-02-26  |  12KB  |  530 lines
  1. external;
  2.  
  3. {
  4.     Statements.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     This module handles normal statements, including the
  8. standard statements like if, while, case, etc.
  9. }
  10.  
  11. const
  12. {$I "pasconst.i"}
  13.  
  14. type
  15. {$I "pastype.i"}
  16.  
  17. var
  18. {$I "pasvar.i"}
  19.  
  20.     function loadvar(v : integer) : integer;
  21.         forward;
  22.     function match(s : integer) : boolean;
  23.         forward;
  24.     function expression() : integer;
  25.         forward;
  26.     procedure error(s : string);
  27.         forward;
  28.     function typecheck(t1, t2 : integer): boolean;
  29.         forward;
  30.     procedure savestack(t : integer);
  31.         forward;
  32.     procedure saveval(v : integer);
  33.         forward;
  34.     procedure ns;
  35.         forward;
  36.     procedure nextsymbol;
  37.         forward;
  38.     function getlabel(): integer;
  39.         forward;
  40.     procedure printlabel(l : integer);
  41.         forward;
  42.     function suffix(s : integer) : char;
  43.         forward;
  44.     procedure mismatch;
  45.         forward;
  46.     function loadaddress() : integer;
  47.         forward;
  48.     procedure callproc(v : integer);
  49.         forward;
  50.     procedure stdproc(v : integer);
  51.         forward;
  52.     function endoffile() : boolean;
  53.         forward;
  54.     procedure readchar;
  55.         forward;
  56.     function findid(s : string): integer;
  57.         forward;
  58.     function isvariable(i : integer) : boolean;
  59.         forward;
  60.     function conexpr(var t : integer) : integer;
  61.         forward;
  62.     function basetype(t : integer) : integer;
  63.         forward;
  64.     procedure promotetype(var f : integer; o, r : integer);
  65.         forward;
  66.     function numbertype(t : integer): boolean;
  67.         forward;
  68.  
  69. procedure statement;
  70.     forward;
  71.  
  72. procedure assignment(varindex : integer);
  73.  
  74. {
  75.     Not surprisingly, this routine handles assignments.
  76. }
  77.  
  78. var
  79.     vartype    : integer;
  80.     exprtype    : integer;
  81.     stackvar    : integer;
  82. begin
  83.     stackvar := loadvar(varindex);
  84.     if stackvar <> 0 then begin
  85.     writeln(output, "\tmove.l\td0,-(sp)");
  86.     vartype := stackvar;
  87.     end else
  88.     vartype := idents[varindex].vtype;
  89.     if not match(becomes1) then
  90.     error("expecting :=");
  91.     exprtype := expression();
  92.     if typecheck(vartype, exprtype) then begin
  93.     promotetype(exprtype, vartype, 0);
  94.     if stackvar <> 0 then
  95.         savestack(vartype)
  96.     else
  97.         saveval(varindex);
  98.     end else
  99.     mismatch;
  100.     ns;
  101. end;
  102.  
  103. procedure returnval;
  104.  
  105. {
  106.     This is similar to the above, but the value is left in d0.
  107. }
  108.  
  109. var
  110.     exprtype    : integer;
  111. begin
  112.     nextsymbol;
  113.     if not match(becomes1) then
  114.     error("expecting :=");
  115.     exprtype := expression();
  116.     if not typecheck(idents[currfn].vtype, exprtype) then
  117.     mismatch;
  118.     if numbertype(exprtype) then
  119.     promotetype(exprtype, idents[currfn].vtype, 0);
  120.     writeln(output, "\tunlk\ta5");
  121.     writeln(output, "\trts");
  122.     ns;
  123. end;
  124.  
  125. procedure dowhile;
  126.  
  127. {
  128.     Handles the while statement.
  129. }
  130.  
  131. var
  132.     looplabel,
  133.     exitlabel    : integer;
  134. begin
  135.     looplabel := getlabel();
  136.     exitlabel := getlabel();
  137.     printlabel(looplabel);
  138.     writeln(output);
  139.     if not typecheck(expression(), booltype) then
  140.     error("Expecting boolean expression");
  141.     writeln(output, "\ttst.b\td0");
  142.     write(output, "\tbeq\t");
  143.     printlabel(exitlabel);
  144.     writeln(output);
  145.     if not match(do1) then
  146.     error("Missing DO");
  147.     statement;
  148.     write(output, "\tbra\t");
  149.     printlabel(looplabel);
  150.     writeln(output);
  151.     printlabel(exitlabel);
  152.     writeln(output);
  153. end;
  154.  
  155. procedure dorepeat;
  156.  
  157. {
  158.     Handles the repeat statement.
  159. }
  160.  
  161. var
  162.     replabel    : integer;
  163. begin
  164.     replabel := getlabel();
  165.     printlabel(replabel);
  166.     writeln(output);
  167.     while not match(until1) do
  168.     statement;
  169.     if not typecheck(expression(), booltype) then
  170.     error("Expecting a Boolean expression.");
  171.     writeln(output, "\ttst.b\td0");
  172.     write(output, "\tbeq\t");
  173.     printlabel(replabel);
  174.     writeln(output);
  175. end;
  176.  
  177. procedure savefor(vartype, varindex, off : integer);
  178.  
  179. {
  180.     This routine saves the new value of the index variable for
  181. for statements.
  182. }
  183.  
  184. begin
  185.     write(output, "\tmove.l\t");
  186.     if off <> 0 then
  187.     write(output, off);
  188.     writeln(output, '(sp),a0');
  189.     writeln(output, "\tmove.", suffix(idents[vartype].size), "\td0,(a0)");
  190. end;
  191.  
  192. procedure incfor(vartype, value : integer);
  193.  
  194. {
  195.     This routine adjusts the index for increments of 1 or -1.
  196. }
  197.  
  198. begin
  199.     writeln(output, "\tmove.l\t4(sp),a0");
  200.     writeln(output, "\tadd.", suffix(idents[vartype].size), "\t#",
  201.             value,',(a0)');
  202.     writeln(output, "\tmove.", suffix(idents[vartype].size), "\t(a0),d0");
  203. end;
  204.  
  205. procedure stackinc(vartype : integer);
  206.  
  207. {
  208.     This handles non-standard increments.
  209. }
  210.  
  211. begin
  212.     writeln(output, "\tmove.l\t8(sp),a0");
  213.     writeln(output, "\tmove.l\t(sp),d0");
  214.     writeln(output, "\tadd.", suffix(idents[vartype].size), "\td0,(a0)");
  215.     writeln(output, "\tmove.", suffix(idents[vartype].size), "\t(a0),d0");
  216. end;
  217.  
  218. procedure dofor;
  219.  
  220. {
  221.     handles the for statement.
  222. }
  223.  
  224. var
  225.     looplabel    : integer;
  226.     varindex    : integer;
  227.     vartype    : integer;
  228.     boundtype    : integer;
  229.     increment    : integer;
  230.     bytype    : integer;
  231.     default    : boolean;
  232. begin
  233.     vartype := loadaddress();
  234.     if idents[vartype].offset <> vordinal then
  235.     error("expecting an ordinal type");
  236.     writeln(output, "\tmove.l\ta0,-(sp)");
  237.     if not match(becomes1) then
  238.     error("missing :=");
  239.     boundtype := expression();
  240.     if not typecheck(vartype, boundtype) then
  241.     mismatch;
  242.     savefor(vartype, varindex, 0);
  243.     if match(to1) then
  244.     increment := 1
  245.     else if match(downto1) then
  246.     increment := -1
  247.     else
  248.     error("Expecting TO or DOWNTO");
  249.     boundtype := expression();
  250.     if not typecheck(boundtype, vartype) then
  251.     mismatch;
  252.     writeln(output, "\tmove.l\td0,-(sp)");
  253.  
  254.     if match(by1) then begin
  255.     default := false;
  256.     bytype := expression();
  257.     if not typecheck(bytype, vartype) then
  258.         mismatch;
  259.     writeln(output, "\tmove.l\td0,-(sp)");
  260.     end else
  261.     default := true;
  262.  
  263.     if not match(do1) then
  264.     error("missing DO");
  265.     looplabel := getlabel();
  266.     printlabel(looplabel);
  267.     writeln(output);
  268.     statement;
  269.     if default then begin
  270.     incfor(vartype, increment);
  271.     writeln(output, "\tmove.l\t(sp),d1");
  272.     end else begin
  273.     stackinc(vartype);
  274.     writeln(output, "\tmove.l\t4(sp),d1");
  275.     end;
  276.     writeln(output, "\tcmp.", suffix(idents[vartype].size), "\td1,d0");
  277.     if increment > 0 then
  278.     write(output, "\tble\t")
  279.     else
  280.     write(output, "\tbge\t");
  281.     printlabel(looplabel);
  282.     writeln(output);
  283.     if default then
  284.     writeln(output, "\tadd.l\t#8,sp")
  285.     else
  286.     writeln(output, "\tadd.l\t#12,sp");
  287. end;
  288.  
  289. procedure doreturn;
  290.  
  291. {
  292.     This just takes care of return.
  293. }
  294.  
  295. begin
  296.     if currfn <> 0 then begin
  297.     if idents[currfn].object = proc then begin
  298.         writeln(output, "\tunlk\ta5");
  299.         writeln(output, "\trts");
  300.     end else
  301.         error("return only allowed in procedures.");
  302.     end else
  303.     error("No return from the main procedure");
  304. end;
  305.  
  306. procedure compound;
  307.  
  308. {
  309.     This takes care of the begin...end syntax.
  310. }
  311.  
  312. begin
  313.     while not match(end1) do
  314.     statement;
  315. end;
  316.  
  317. procedure doif;
  318.  
  319. {
  320.     This handles the if statement.  Eventually it should handle
  321. elsif.
  322. }
  323.  
  324. var
  325.     flab1, flab2    : integer;
  326. begin
  327.     flab1 := getlabel();
  328.     if not typecheck(expression(), booltype) then
  329.     error("Expecting a Boolean type");
  330.     writeln(output, "\ttst.b\td0");
  331.     write(output, "\tbeq\t");
  332.     printlabel(flab1);
  333.     writeln(output);
  334.     if not match(then1) then
  335.     error("Missing THEN");
  336.     statement;
  337.     if match(else1) then begin
  338.     flab2 := getlabel();
  339.     write(output, "\tbra\t");
  340.     printlabel(flab2);
  341.     writeln(output);
  342.     printlabel(flab1);
  343.     writeln(output);
  344.     statement;
  345.     printlabel(flab2);
  346.     writeln(output);
  347.     end else begin
  348.     printlabel(flab1);
  349.     writeln(output);
  350.     end;
  351. end;
  352.  
  353. procedure docase;
  354.  
  355. {
  356.     This block handles the case statement.  At the moment, it
  357. only allows single constant cases.  That will change soon.
  358. }
  359.  
  360. type
  361.     caserecord = record
  362.     value : integer;
  363.     lab : integer;
  364.     end;
  365.  
  366. { Gasp! An arbitrary number of cases? }
  367.  
  368.     casetabletype = array [1..40] of caserecord;
  369.  
  370. var
  371.     endtable   : integer;
  372.     tablelabel : integer;
  373.     cases      : integer;
  374.     casetype   : integer;
  375.     casetable  : casetabletype;
  376.     index      : integer;
  377.  
  378.     procedure readcases(var cases : integer;
  379.             var ct : casetabletype; ctype : integer);
  380.     {
  381.     This routine should at least read series of cases,
  382.     separated by commas.  It would be nice if it would read
  383.     ranges as well.
  384.     }
  385.  
  386.     var
  387.     eltype : integer;
  388.     begin
  389.     if cases < 40 then begin
  390.         cases := cases + 1;
  391.         ct[cases].value := conexpr(eltype);
  392.         if not typecheck(ctype, eltype) then
  393.         mismatch;
  394.         ct[cases].lab := getlabel();
  395.     end else begin
  396.         error("Too many cases");
  397.         eltype := conexpr(eltype);
  398.     end;
  399.     end;
  400.  
  401. begin
  402.     tablelabel := getlabel();
  403.     endtable   := getlabel();
  404.     cases := 0;
  405.     casetype := expression();
  406.     if idents[basetype(casetype)].offset <> vordinal then
  407.     error("Expecting an ordinal type");
  408.     write(output, "\tlea\t");
  409.     printlabel(tablelabel);
  410.     writeln(output, ',a0');
  411.     writeln(output, "\tjmp\t_p%case");
  412.     if not match(of1) then
  413.     error("expecting OF");
  414.     while (currsym <> end1) and (currsym <> else1) do begin
  415.     readcases(cases, casetable, casetype);
  416.     if not match(colon1) then
  417.         error("Expecting :");
  418.     printlabel(casetable[cases].lab);
  419.     writeln(output);
  420.     statement;
  421.     write(output, "\tjmp\t");
  422.     printlabel(endtable);
  423.     writeln(output);
  424.     end;
  425.     if match(else1) then begin
  426.     cases := cases + 1;
  427.     casetable[cases].lab := 0;
  428.     casetable[cases].value := getlabel();
  429.     printlabel(casetable[cases].value);
  430.     writeln(output);
  431.     statement;
  432.     write(output, "\tbra\t");
  433.     printlabel(endtable);
  434.     writeln(output);
  435.     end else begin
  436.     cases := cases + 1;
  437.     casetable[cases].lab := 0;
  438.     casetable[cases].value := endtable;
  439.     end;
  440.     if not match(end1) then
  441.     error("Missing END");
  442.     printlabel(tablelabel);
  443.     if cases = 0 then begin
  444.     write(output, "\tdc.l\t0,");
  445.     printlabel(endtable);
  446.     writeln(output);
  447.     end else begin
  448.     for index := 1 to cases do begin
  449.         if casetable[index].lab <> 0 then begin
  450.         write(output, "\tdc.l\t");
  451.         printlabel(casetable[index].lab);
  452.         writeln(output, ',', casetable[index].value);
  453.         end else begin
  454.         write(output, "\tdc.l\t0,");
  455.         printlabel(casetable[index].value);
  456.         writeln(output);
  457.         end;
  458.     end;
  459.     end;
  460.     printlabel(endtable);
  461.     writeln(output);
  462. end;
  463.  
  464. procedure statement;
  465.  
  466. {
  467.     This is the main routine for handling statements of all
  468. sorts.  It distributes the work as necessary.
  469. }
  470.  
  471. var
  472.     varindex    : integer;
  473. begin
  474.     if endoffile() then
  475.     return
  476.     else if currsym = ident1 then begin
  477.     varindex := findid(symtext);
  478.     if varindex = 0 then begin
  479.         error("unknown ID");
  480.         while (currsym <> semicolon1) and
  481.           (currsym <> end1) and
  482.           (currentchar <> chr(10)) do
  483.         nextsymbol;
  484.         if currsym = semicolon1 then
  485.         nextsymbol;
  486.     end else if (varindex = currfn) and (idents[currfn].object = func) then
  487.         returnval
  488.     else if isvariable(varindex) then
  489.         assignment(varindex)
  490.     else if idents[varindex].object = proc then
  491.         callproc(varindex)
  492.     else if idents[varindex].object = stanproc then
  493.         stdproc(varindex)
  494.     else begin
  495.         error("expecting a variable or procedure.");
  496.         while (currsym <> semicolon1) and
  497.           (currsym <> end1) and
  498.           (currentchar <> chr(10)) do
  499.         nextsymbol;
  500.         if currsym = semicolon1 then
  501.         nextsymbol;
  502.     end;
  503.     end else if match(begin1) then begin
  504.     compound;
  505.     ns;
  506.     end else if match(if1) then begin
  507.     doif;
  508.     end else if match(while1) then begin
  509.     dowhile;
  510.     end else if match(repeat1) then begin
  511.     dorepeat;
  512.     end else if match(for1) then begin
  513.     dofor;
  514.     end else if match(case1) then begin
  515.     docase;
  516.     end else if match(semicolon1) then;
  517.     else if match(return1) then begin
  518.     doreturn;
  519.     ns;
  520.     end else begin
  521.     error("expecting a statement");
  522.     while (currsym <> semicolon1) and
  523.           (currsym <> end1) and
  524.           (currentchar <> chr(10)) do
  525.         nextsymbol;
  526.     if currsym = semicolon1 then
  527.         nextsymbol;
  528.     end;
  529. end;
  530.