home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 254a.lha / PCQ / Source / Stanprocs.p < prev    next >
Encoding:
Text File  |  1989-05-10  |  10.2 KB  |  431 lines
  1. external;
  2.  
  3. {
  4.     Stanprocs.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     This routine implements the various standard procedures,
  8. hence the name.
  9. }
  10.  
  11. const
  12. {$I "pasconst.i"}
  13.  
  14. type
  15. {$I "pastype.i"}
  16.  
  17. var
  18. {$I "pasvar.i"}
  19.  
  20.     procedure nextsymbol;
  21.         forward;
  22.     function match(s : integer): boolean;
  23.         forward;
  24.     procedure error(s : string);
  25.         forward;
  26.     function expression(): integer;
  27.         forward;
  28.     function conexpr(var t : integer): integer;
  29.         forward;
  30.     function typecmp(t1, t2 : integer): boolean;
  31.         forward;
  32.     function typecheck(t1, t2 : integer): boolean;
  33.         forward;
  34.     function loadaddress() : integer;
  35.         forward;
  36.     procedure mismatch;
  37.         forward;
  38.     procedure needleftparent;
  39.         forward;
  40.     procedure needrightparent;
  41.         forward;
  42.     function findid(s : string) : integer;
  43.         forward;
  44.     procedure savestack(t : integer);
  45.         forward;
  46.     procedure saveval(v : integer);
  47.         forward;
  48.     procedure ns;
  49.         forward;
  50.     function loadvar(v : integer) : integer;
  51.         forward;
  52.     procedure promotetype(var f : integer; o, r : integer);
  53.         forward;
  54.     function numbertype(t : integer): boolean;
  55.         forward;
  56.  
  57. procedure callwrite(vartype : integer);
  58.  
  59. {
  60.     This routine calls the appropriate library routine to write
  61. vartype to a text file.
  62. }
  63.  
  64. var
  65.     elementtype    : integer;
  66. begin
  67.     if numbertype(vartype) then begin
  68.     promotetype(vartype, inttype, 0);
  69.     writeln(output, "\tjsr\t_p%writeint");
  70.     end else if typecmp(vartype, chartype) then
  71.     writeln(output, "\tjsr\t_p%writechar")
  72.     else if typecmp(vartype, booltype) then
  73.     writeln(output, "\tjsr\t_p%writebool")
  74.     else if idents[vartype].offset = varray then begin
  75.     elementtype := idents[vartype].vtype;
  76.     if typecmp(elementtype, chartype) then begin
  77.         writeln(output, "\tmove.l\t#",
  78.         idents[vartype].upper - idents[vartype].lower + 1, ',d3');
  79.         writeln(output, "\tjsr\t_p%writecharray");
  80.     end else
  81.         error("can only write arrays of char");
  82.     end else if typecmp(vartype, stringtype) then
  83.     writeln(output, "\tjsr\t_p%writestring")
  84.     else
  85.     error("can't write that type to text file");
  86. end;
  87.  
  88. procedure filewrite(vartype : integer);
  89.  
  90. {
  91.     This routine writes a variable to a 'file of that
  92. variable'.
  93. }
  94.  
  95. begin
  96.     writeln(output, "\tmove.l\t#", idents[vartype].size, ',d3');
  97.     writeln(output, "\tjsr\t_p%writearb");
  98. end;
  99.  
  100. procedure dowrite(varindex : integer);
  101.  
  102. {
  103.     This routine handles all aspects of the write and writeln
  104. statements.
  105. }
  106.  
  107. var
  108.     filetype    : integer; { file type if there is one }
  109.     exprtype    : integer; { current element type }
  110.     pushed    : boolean; { have pushed the file handle on stack }
  111.     width    : integer; { constant field width }
  112.     widtype     : integer; { type of the above }
  113. begin
  114.     if match(leftparent1) then begin
  115.     filetype := expression();
  116.     pushed := true;
  117.     if idents[filetype].offset = vfile then begin
  118.         writeln(output, "\tmove.l\td0,a0");
  119.         writeln(output, "\tmove.l\t(a0),d0");
  120.         writeln(output, "\tmove.l\td0,-(sp)");
  121.     end else begin
  122.         writeln(output, "\tmove.l\t_stdout,-(sp)");
  123.         if match(colon1) then begin
  124.         width := conexpr(widtype);
  125.         if not typecheck(inttype, widtype) then
  126.             error("Expecting integer value.");
  127.         writeln(output, "\tmove.w\t#", width, ',-(sp)');
  128.         end else
  129.         writeln(output, "\tmove.w\t#1,-(sp)");
  130.         callwrite(filetype);
  131.         writeln(output, "\taddq.l\t#2,sp");
  132.         filetype := texttype;
  133.     end;
  134.     while not match(rightparent1) do begin
  135.         if not match(comma1) then
  136.         error("expecting , or )");
  137.         exprtype := expression();
  138.         if typecmp(filetype, texttype) then begin
  139.         if match(colon1) then begin
  140.             width := conexpr(widtype);
  141.             if not typecheck(inttype, widtype) then
  142.             error("Expecting integer value.");
  143.             writeln(output, "\tmove.w\t#", width, ',-(sp)');
  144.         end else
  145.             writeln(output, "\tmove.w\t#1,-(sp)");
  146.         callwrite(exprtype);
  147.         writeln(output, "\taddq.l\t#2,sp");
  148.         end else begin
  149.         if typecmp(idents[filetype].vtype, exprtype) then
  150.             filewrite(exprtype)
  151.         else
  152.             mismatch;
  153.         end;
  154.     end;
  155.     end else begin
  156.     filetype := texttype;
  157.     pushed := false;
  158.     if idents[varindex].offset = 1 then
  159.         error("'write' requires arguments.");
  160.     end;
  161.     if idents[varindex].offset = 2 then begin
  162.     if filetype = texttype then begin
  163.         if pushed then
  164.         writeln(output, "\tjsr\t_p%writeln")
  165.         else begin
  166.         writeln(output, "\tmove.l\t_stdout,-(sp)");
  167.         writeln(output, "\tjsr\t_p%writeln");
  168.         writeln(output, "\taddq.l\t#4,sp");
  169.         end;
  170.     end else
  171.        error("No ...ln for non-text files");
  172.     end;
  173.     if pushed then
  174.     writeln(output, "\taddq.l\t#4,sp");
  175. end;
  176.  
  177. procedure callread(vartype : integer);
  178.  
  179. {
  180.     This routine calls the appropriate library routines to read
  181. the vartype from a text file.
  182. }
  183.  
  184. begin
  185.     if typecmp(vartype, chartype) then
  186.     writeln(output, "\tjsr\t_p%readchar")
  187.     else if typecmp(vartype, inttype) then begin
  188.     writeln(output, "\tjsr\t_p%readint");
  189.     writeln(output, "\tmove.l\td0,(a0)");
  190.     end else if typecmp(vartype, shorttype) then begin
  191.     writeln(output, "\tjsr\t_p%readint");
  192.     writeln(output, "\tmove.w\td0,(a0)");
  193.     end else if idents[vartype].offset = varray then begin
  194.     if typecmp(idents[vartype].vtype, chartype) then begin
  195.         writeln(output, "\tmove.l\t#",
  196.         idents[vartype].upper - idents[vartype].lower + 1, ',d3');
  197.         writeln(output, "\tjsr\t_p%readcharray");
  198.     end else
  199.         error("can only read character arrays");
  200.     end else if typecmp(vartype, stringtype) then
  201.     writeln(output, "\tjsr\t_p%readstring");
  202.     else
  203.     error("cannot read that type from a text file");
  204. end;
  205.  
  206. procedure doread(varindex : integer);
  207.  
  208. {
  209.     This handles the read statement.  Note that read(f, var) from a
  210. non-text file really does end up being var := f^; get(f).  Same
  211. goes for text files, but it's all handled within the library.
  212.     Note the difference between this and dowrite(),
  213. specifically the use of expression() up there and loadaddress()
  214. here.
  215. }
  216.  
  217. var
  218.     filetype    : integer;
  219.     vartype    : integer;
  220.     pushed    : boolean;
  221. begin
  222.     if match(leftparent1) then begin
  223.     filetype := loadaddress();
  224.     pushed := true;
  225.     if idents[filetype].offset = vfile then
  226.         writeln(output, "\tmove.l\ta0,-(sp)");
  227.     else begin
  228.         writeln(output, "\tmove.l\t#0,-(sp)");
  229.         callread(filetype);
  230.         filetype := texttype;
  231.     end;
  232.     while not match(rightparent1) do begin
  233.         if not match(comma1) then
  234.         error("expecting , or )");
  235.         vartype := loadaddress();
  236.         if typecmp(filetype, texttype) then
  237.         callread(vartype)
  238.         else begin
  239.         if typecmp(idents[filetype].vtype, vartype) then
  240.             writeln(output, "\tjsr\t_p%readarb")
  241.         else
  242.             mismatch;
  243.         end;
  244.     end;
  245.     end else begin
  246.     filetype := texttype;
  247.     pushed := false;
  248.     if idents[varindex].offset = 3 then
  249.         error("'read' requires arguments.");
  250.     end;
  251.     if idents[varindex].offset = 4 then begin
  252.     if typecmp(filetype, texttype) then begin
  253.         if pushed then
  254.         writeln(output, "\tjsr\t_p%readln")
  255.         else begin
  256.         writeln(output, "\tmove.l\t#0,-(sp)");
  257.         writeln(output, "\tjsr\t_p%readln");
  258.         writeln(output, "\taddq.l\t#4,sp");
  259.         end;
  260.     end else
  261.        error("No ...ln for non-text files");
  262.     end;
  263.     if pushed then
  264.     writeln(output, "\taddq.l\t#4,sp");
  265. end;
  266.  
  267. procedure donew;
  268.  
  269. {
  270.     This just handles allocation of memory.
  271. }
  272.  
  273. var
  274.     varindex    : integer;
  275.     vartype    : integer;
  276.     varsize    : integer;
  277.     stackvar    : integer;
  278. begin
  279.     needleftparent;
  280.     varindex := findid(symtext);
  281.     if varindex <> 0 then begin
  282.     stackvar := loadvar(varindex);
  283.     if stackvar <> 0 then begin
  284.         writeln(output, "\tmove.l\td0,-(sp)");
  285.         vartype := stackvar;
  286.     end else
  287.         vartype := idents[varindex].vtype;
  288.     if idents[vartype].offset <> vpointer then
  289.         error("expecting a pointer type");
  290.     varsize := idents[vartype].vtype;
  291.     varsize := idents[varsize].size;
  292.     writeln(output, "\tmove.l\t#", varsize, ',d0');
  293.     writeln(output, "\tjsr\t_p%new");
  294.     if stackvar <> 0 then
  295.         savestack(vartype)
  296.     else
  297.         saveval(varindex);
  298.     end else
  299.     error("Unknown identifier");
  300.     needrightparent;
  301. end;
  302.  
  303. procedure dodispose;
  304.  
  305. {
  306.     This routine calls the library routine that disposes of
  307. memory.
  308. }
  309.  
  310. var
  311.     exprtype    : integer;
  312. begin
  313.     needleftparent;
  314.     exprtype := expression();
  315.     if idents[exprtype].offset <> vpointer then
  316.     error("Expecting a pointer type")
  317.     else
  318.     writeln(output, "\tjsr\t_p%dispose");
  319.     needrightparent;
  320. end;
  321.  
  322. procedure doclose;
  323.  
  324. {
  325.     Closes a file.  The difference between this and a normal
  326. DOS close is that this routine must un-link the file from the
  327. program's open file list.
  328. }
  329.  
  330. var
  331.     exprtype    : integer;
  332. begin
  333.     needleftparent;
  334.     exprtype := expression();
  335.     if idents[exprtype].offset <> vfile then
  336.     error("Expecting a file type")
  337.     else
  338.     writeln(output, "\tjsr\t_p%close");
  339.     needrightparent;
  340. end;
  341.  
  342. procedure doget;
  343.  
  344. {
  345.     This implements get.  There is no analogous put(), since
  346. the write statements never needed it.
  347. }
  348.  
  349. var
  350.     exprtype    : integer;
  351. begin
  352.     needleftparent;
  353.     exprtype := expression();
  354.     if idents[exprtype].offset <> vfile then
  355.     error("Expecting a file type")
  356.     else begin
  357.     writeln(output, "\tmove.l\td0,a0");
  358.     writeln(output, "\tjsr\t_p%readarbbuf");
  359.     end;
  360.     needrightparent;
  361. end;
  362.  
  363. procedure doexit;
  364.  
  365. {
  366.     Just calls the routine that allows the graceful shut-down
  367. of the program.
  368. }
  369.  
  370. var
  371.     exprtype : integer;
  372. begin
  373.     needleftparent;
  374.     exprtype := expression();
  375.     if not typecheck(exprtype, inttype) then
  376.     error("Expecting an integer argument.");
  377.     writeln(output, "\tjsr\t_p%exit");
  378.     needrightparent;
  379. end;
  380.  
  381. procedure dotrap;
  382.  
  383. {
  384.     This is just for debugging a program.  Use some trap, and
  385. your debugger will stop at that statement.
  386. }
  387.  
  388. var
  389.     exprtype,
  390.     trapnum   : integer;
  391. begin
  392.     needleftparent;
  393.     trapnum := conexpr(exprtype);
  394.     writeln(output, "\ttrap\t#", trapnum);
  395.     needrightparent;
  396. end;
  397.  
  398. procedure stdproc(varindex : integer);
  399.  
  400. {
  401.     This routine sifts out the proper routine to call.
  402. }
  403.  
  404. var
  405.     exprtype    : integer;
  406.     pushed    : boolean;
  407. begin
  408.     nextsymbol;
  409.     pushed := false;
  410.     if (idents[varindex].offset = 1) or
  411.         (idents[varindex].offset = 2) then
  412.     dowrite(varindex)
  413.     else if (idents[varindex].offset = 3) or
  414.         (idents[varindex].offset = 4) then
  415.     doread(varindex)
  416.     else if idents[varindex].offset = 5 then
  417.     donew
  418.     else if idents[varindex].offset = 6 then
  419.     dodispose
  420.     else if idents[varindex].offset = 7 then
  421.     doclose
  422.     else if idents[varindex].offset = 8 then
  423.     doget
  424.     else if idents[varindex].offset = 9 then
  425.     doexit
  426.     else if idents[varindex].offset = 10 then
  427.     dotrap;
  428.     ns;
  429. end;
  430.  
  431.