home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_disks / 300-399 / ff339.lzh / PCQ / Source.lzh / Source / Calls.p next >
Text File  |  1989-11-26  |  16KB  |  627 lines
  1. External;
  2.  
  3. {
  4.     Calls.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     Calls.p is the first attempt to organize the various
  8. addressing and code generating routines in one section.  If you
  9. read the other sections you'll find that not much effort went into
  10. this project.  Nonetheless, a couple of common addressing things
  11. can be found here.
  12.     If the compiler were designed so that all the addressing
  13. things were here, it would be much easier to port to a different
  14. processor.
  15. }
  16.  
  17. {$O-}
  18. {$I "Pascal.i"}
  19.  
  20.     Function Match(s : Symbols) : Boolean;
  21.         external;
  22.     Procedure Error(s : string);
  23.         external;
  24.     Function FindField(s : string; TP : TypePtr): IDPtr;
  25.         external;
  26.     Function FindWithField(S : String) : IDPtr;
  27.         External;
  28.     Procedure NextSymbol;
  29.         external;
  30.     Function Expression() : TypePtr;
  31.         external;
  32.     Function TypeCheck(t1, t2 : TypePtr): Boolean;
  33.         external;
  34.     Function TypeCmp(t1, t2 : TypePtr) : Boolean;
  35.         external;
  36.     Function FindID(s : string) : IDPtr;
  37.         external;
  38.     Function IsVariable(i : IDPtr) : Boolean;
  39.         external;
  40.     Function GetLabel() : Integer;
  41.         external;
  42.     Procedure PrintLabel(l : Integer);
  43.         external;
  44.     Procedure ns;
  45.         external;
  46.     Function Suffix(s : Integer): Char;
  47.         external;
  48.     Procedure Mismatch;
  49.         external;
  50.     Function SimpleType(t : TypePtr): Boolean;
  51.         external;
  52.     Function NumberType(t : TypePtr): Boolean;
  53.         external;
  54.     Procedure PromoteType(var f : TypePtr; o : TypePtr; r : Short);
  55.         external;
  56.  
  57. Procedure PushLongD0;
  58. begin
  59.     writeln(OutFile, "\tmove.l\td0,-(sp)");
  60.     StackLoad := StackLoad + 4;
  61. end;
  62.  
  63. Procedure PopLongD0;
  64. begin
  65.     Writeln(OutFile, '\tmove.l\t(sp)+,d0');
  66.     StackLoad := StackLoad - 4;
  67. end;
  68.  
  69. Procedure PopStackSpace(amount : Integer);
  70. begin
  71.     Writeln(OutFile, '\tadd.l\t#', amount, ',sp');
  72.     StackLoad := StackLoad - amount;
  73. end;
  74.  
  75. Procedure PushWordD0;
  76. begin
  77.     writeln(OutFile, "\tmove.w\td0,-(sp)");
  78.     StackLoad := StackLoad + 2;
  79. end;
  80.  
  81. Procedure PushLongD1;
  82. begin
  83.     Writeln(OutFile, '\tmove.l\td1,-(sp)');
  84.     StackLoad := StackLoad + 4;
  85. end;
  86.  
  87. Procedure PopLongD1;
  88. begin
  89.     writeln(OutFile, "\tmove.l\t(sp)+,d1");
  90.     StackLoad := StackLoad - 4;
  91. end;
  92.  
  93. Procedure PushLongA0;
  94. begin
  95.     writeln(OutFile, '\tmove.l\ta0,-(sp)');
  96.     StackLoad := StackLoad + 4;
  97. end;
  98.  
  99. Procedure PopLongA0;
  100. begin
  101.     writeln(OutFile, '\tmove.l\t(sp)+,a0');
  102.     StackLoad := StackLoad - 4;
  103. end;
  104.  
  105. Procedure PopLongA1;
  106. begin
  107.     writeln(OutFile, '\tmove.l\t(sp)+,a1');
  108.     StackSpace := StackSpace - 4;
  109. end;
  110.  
  111. Procedure DoRangeCheck(VarType : TypePtr);
  112.  
  113. {
  114.     This routine is called from selector() when range checking
  115. is turned on.  Notice that the code is now in a library, rather
  116. than inline as it was in 1.0.  Also note that the library code fixes
  117. the stack after the call.
  118. }
  119.  
  120. begin
  121.     Writeln(OutFile, '\tpea\t', VarType^.Lower);
  122.     Writeln(OutFile, '\tpea\t', VarType^.Upper);
  123.     Writeln(OutFile, '\tjsr\t_p%CheckRange');
  124. end;
  125.  
  126. Function GetFramePointer(Reference : Integer) : Short;
  127. var
  128.     Current : Integer;
  129. begin
  130.     Current := CurrentBlock^.Level;
  131.     if Current = Reference then
  132.     GetFramePointer := 5
  133.     else begin
  134.     writeln(OutFile, "\tmove.l\t8(a5),a4");
  135.     Current := Pred(Current);
  136.     while Current > Reference do begin
  137.         Writeln(OutFile, "\tmove.l\t8(a4),a4");
  138.         Current := Pred(Current);
  139.     end;
  140.     GetFramePointer := 4;
  141.     end;
  142. end;
  143.  
  144. Procedure GetPointerVal(ID : IDPtr);
  145.  
  146. {
  147.     This routine puts the value of a pointer variable (or a
  148. reference parameter) into a0.
  149. }
  150. var
  151.     Reg : Short;
  152. begin
  153.     case ID^.Object of
  154.     global : writeln(OutFile, "\tmove.l\t_", ID^.Name, ',a0');
  155.     typed_const :
  156.          if ID^.Level <= 1 then
  157.              writeln(OutFile, '\tmove.l\t_', ID^.Name, ',a0')
  158.          else
  159.              writeln(OutFile, '\tmove.l\t_',ID^.Name,'%',ID^.Unique);
  160.     refarg : begin
  161.             Reg := GetFramePointer(ID^.Level);
  162.             writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),a0');
  163.             writeln(OutFile, "\tmove.l\t(a0),a0");
  164.          end;
  165.     else begin
  166.         Reg := GetFramePointer(ID^.Level);
  167.         writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),a0');
  168.      end;
  169.     end;
  170. end;
  171.  
  172. Procedure SimpleAddress(ID : IDPtr);
  173.  
  174. {
  175.     simpleaddress() is passed a idrecord of some sort of
  176. variable, and just loads its address into a0.
  177. }
  178. var
  179.     Reg : Short;
  180. begin
  181.     case ID^.Object of
  182.     global : writeln(OutFile, "\tlea\t_", ID^.Name, ',a0');
  183.     typed_const :
  184.          if ID^.Level <= 1 then
  185.              writeln(OutFile, '\tlea\t_', ID^.Name, ',a0')
  186.          else
  187.              writeln(OutFile, '\tlea\t_', ID^.Name, '%',
  188.                 ID^.Unique, ',a0');
  189.     refarg : begin
  190.             Reg := GetFramePointer(ID^.Level);
  191.             writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),a0');
  192.          end;
  193.     else begin
  194.          Reg := GetFramePointer(ID^.Level);
  195.          writeln(OutFile, "\tlea\t", ID^.Offset, '(a', Reg, '),a0');
  196.      end;
  197.     end;
  198. end;
  199.  
  200. Procedure DoMultiply(size : Integer);
  201.  
  202.     Procedure ShiftLeft(num : Short);
  203.     begin
  204.     Writeln(OutFile, "\tlsl.l\t#", num, ',d0');
  205.     end;
  206.  
  207. begin
  208.     case size of
  209.     1  : ;
  210.     2  : ShiftLeft(1);
  211.     4  : ShiftLeft(2);
  212.     8  : ShiftLeft(3);
  213.     16 : ShiftLeft(4);
  214.     32 : ShiftLeft(5);
  215.     64 : ShiftLeft(6);
  216.     128: ShiftLeft(7);
  217.     256: ShiftLeft(8);
  218.     else
  219.     writeln(OutFile, "\tmuls\t#", size, ',d0');
  220.     end;
  221. end;
  222.  
  223. Function Selector(ID : IDPtr) : TypePtr;
  224.  
  225. {
  226.     This is an overlarge function that handles all the
  227. selectors- in other words ^, ., and [].  It can handle a series of
  228. them, of course.  selector() returns Nil if no selection was
  229. required, and the type if there was some selection.
  230. }
  231.  
  232. var
  233.     VarType    : TypePtr;
  234.     FieldID    : IDPtr;
  235.     IndexType    : TypePtr;
  236.     Stacked    : Boolean;
  237.     Leave    : Boolean;
  238.     bufsize,
  239.     WithOffset    : Integer;
  240.     Substitute    : TypePtr;
  241. begin
  242.     if ID^.Object = field then begin
  243.     WithOffset := StackLoad - LastWith^.Offset;
  244.     if WithOffset = 0 then
  245.         Writeln(OutFile, '\tmove.l\t(sp),a0')
  246.     else
  247.         Writeln(OutFile, '\tmove.l\t', WithOffset, '(sp),a0');
  248.     if ID^.Offset <> 0 then
  249.         Writeln(OutFile, '\tadda.l\t#', ID^.Offset, ',a0');
  250.     Stacked := True;
  251.     end else
  252.     Stacked := False;
  253.     VarType := ID^.VType;
  254.     while (CurrSym = period1) or (CurrSym = leftbrack1) or
  255.       (CurrSym = carat1) do begin
  256.     if (not Stacked) and (VarType^.Object <> ob_pointer) then begin
  257.         SimpleAddress(ID);
  258.         Stacked := True;
  259.     end;
  260.     if Match(Period1) then begin
  261.         if VarType^.Object <> ob_record then
  262.         error("not a record type");
  263.         FieldID := FindField(symtext, VarType);
  264.         if FieldID = Nil then
  265.         Error("unknown field")
  266.         else if FieldID^.Offset <> 0 then
  267.         writeln(OutFile, "\tadda.l\t#", FieldID^.Offset, ',a0');
  268.         NextSymbol;
  269.         VarType := FieldID^.VType;
  270.     end else if Match(Carat1) then begin
  271.         if VarType^.Object = ob_file then begin
  272.         BufSize := VarType^.SubType^.Size;
  273.         writeln(OutFile, '\tjsr\t_p%FilePtr');
  274.         if IOCheck then
  275.             Writeln(OutFile, '\tjsr\t_p%CheckIO');
  276.         VarType := VarType^.SubType;
  277.         end else if VarType^.Object = ob_pointer then begin
  278.         if not Stacked then begin
  279.             GetPointerVal(ID);
  280.             Stacked := True;
  281.         end else
  282.             writeln(OutFile, "\tmove.l\t(a0),a0");
  283.         VarType := VarType^.SubType;
  284.         end else
  285.         error("Need a file or pointer for ^");
  286.     end else if Match(LeftBrack1) then begin
  287.         if VarType^.Object = ob_array then begin
  288.         Leave := False;
  289.         repeat
  290.             PushLongA0;
  291.             IndexType := Expression();
  292.             Substitute := Indextype;
  293.             PromoteType(Substitute, Inttype, 0);
  294.             if RangeCheck then
  295.             DoRangeCheck(VarType);
  296.             if not TypeCheck(IndexType, VarType^.Ref) then
  297.             Mismatch;
  298.             if VarType^.Lower <> 0 then
  299.             writeln(OutFile, "\tsub.l\t#", VarType^.Lower, ',d0');
  300.             VarType := VarType^.SubType;
  301.             DoMultiply(VarType^.Size);
  302.             PopLongA0;
  303.             writeln(OutFile, "\tadd.l\td0,a0");
  304.             if Match(Comma1) then begin
  305.             if VarType^.Object <> ob_array then begin
  306.                 Error("Not a multidimensional array");
  307.                 Leave := True;
  308.             end;
  309.             end else
  310.             Leave := True;
  311.         until Leave;
  312.         if not Match(RightBrack1) then
  313.             Error("Expecting ]");
  314.         end else if TypeCheck(Vartype, StringType) then begin
  315.         if not Stacked then begin
  316.             GetPointerVal(ID);
  317.             Stacked := True;
  318.         end else
  319.             writeln(OutFile, "\tmove.l\t(a0),a0");
  320.         PushLongA0;
  321.         IndexType := Expression();
  322.         if not TypeCheck(IndexType, IntType) then
  323.             Mismatch
  324.         else
  325.             PromoteType(IndexType, IntType, 0);
  326.         if not Match(RightBrack1) then
  327.             error("expecting ]");
  328.         PopLongA0;
  329.         writeln(OutFile, "\tadd.l\td0,a0");
  330.         VarType := CharType;
  331.         end else
  332.         error("Expecting an Array or String");
  333.     end;
  334.     end;
  335.     if Stacked then
  336.     Selector := VarType
  337.     else
  338.     Selector := Nil;
  339. end;
  340.  
  341. Function LoadAddress() : TypePtr;
  342.  
  343. {
  344.     This is the routine used wherever I need the address of a
  345. variable, for example reference parameters or the adr() function.
  346. The address is loaded into a0.
  347. }
  348.  
  349. var
  350.     ArgIndex    : IDPtr;
  351.     ArgType    : TypePtr;
  352. begin
  353.     if CurrSym = Ident1 then begin
  354.     ArgIndex := FindWithField(SymText);
  355.     if ArgIndex = Nil then
  356.         ArgIndex := FindID(SymText);
  357.     NextSymbol;
  358.     if ArgIndex = Nil then begin
  359.         error("Unknown ID");
  360.         LoadAddress := BadType;
  361.     end else begin
  362.         if IsVariable(ArgIndex) then begin
  363.         ArgType := Selector(ArgIndex);
  364.         if ArgType = Nil then begin
  365.             SimpleAddress(ArgIndex);
  366.             LoadAddress := ArgIndex^.VType
  367.         end else
  368.             LoadAddress := ArgType;
  369.         end else if (ArgIndex^.Object = proc) or
  370.             (ArgIndex^.Object = func) then begin
  371.         with ArgIndex^ do begin
  372.             if Level <= 1 then
  373.             Writeln(OutFile, "\tlea\t_", Name, ',a0')
  374.             else
  375.             Writeln(OutFile, "\tlea\t_", Name, '%', Unique, ',a0');
  376.         end;
  377.         LoadAddress := AddressType;
  378.         end else
  379.         error("Expecting a variable (reference parameter)");
  380.     end
  381.     end else
  382.     error("Expecting a variable identifier");
  383.     LoadAddress := BadType;
  384. end;
  385.  
  386. Procedure PushArgs(ProcID : IDPtr);
  387.  
  388. {
  389.     This routine handles the parameters of a call (not the
  390. declaration, which is handled in doblock()).  It sorts out the
  391. various reference and value parameters and gets the stack properly
  392. set up.
  393. }
  394.  
  395. var
  396.     CurrentParam    : IDPtr;
  397.     stay        : Boolean;
  398.     argtype        : TypePtr;
  399.     argindex        : integer;
  400.     totalsize        : integer;
  401.     lab            : integer;
  402. begin
  403.     Stay := True;
  404.     if Match(LeftParent1) then begin
  405.     CurrentParam := ProcID^.Param;
  406.     while (not Match(RightParent1)) and Stay do begin
  407.         if CurrentParam = Nil then begin
  408.         error("argument not expected");
  409.         nextsymbol;
  410.         Stay := False;
  411.         end else begin
  412.         if CurrentParam^.Object = valarg then begin
  413.             ArgType := Expression();
  414.             if not TypeCheck(ArgType, CurrentParam^.VType) then begin
  415.             Mismatch;
  416.             ArgType := BadType;
  417.             end else begin
  418.             if NumberType(ArgType) then
  419.                 PromoteType(ArgType, CurrentParam^.VType, 0);
  420.             ArgType := CurrentParam^.VType;
  421.             if SimpleType(ArgType) then begin
  422.                 if ArgType^.Size <= 2 then
  423.                 PushWordD0
  424.                 else if ArgType^.Size = 4 then
  425.                 PushLongD0;
  426.             end else begin
  427.                 writeln(OutFile, "\tmove.l\td0,a0");
  428.                 writeln(OutFile, "\tmove.l\tsp,a1");
  429.                 writeln(OutFile, "\tsub.l\t#",
  430.                 ArgType^.Size, ',a1');
  431.                 writeln(OutFile, "\tmove.l\t#",
  432.                 ArgType^.Size - 1, ',d1');
  433.  
  434.                 lab := GetLabel();
  435.                 PrintLabel(lab);
  436.                 writeln(OutFile, "\tmove.b\t(a0)+,d0");
  437.                 writeln(OutFile, "\tmove.b\td0,(a1)+");
  438.                 write(OutFile, "\tdbra\td1,");
  439.                 PrintLabel(lab);
  440.                 writeln(OutFile);
  441.                 write(OutFile, "\tsub.l\t#");
  442.                 if odd(ArgType^.Size) then begin
  443.                 write(OutFile, ArgType^.Size + 1);
  444.                 StackLoad := StackLoad + ArgType^.Size + 1;
  445.                 end else begin
  446.                 write(OutFile, ArgType^.Size);
  447.                 StackLoad := StackLoad + ArgType^.Size;
  448.                 end;
  449.                 writeln(OutFile, ',sp');
  450.             end;
  451.             end;
  452.         end else if CurrentParam^.Object = refarg then begin
  453.             if CurrSym = ident1 then begin
  454.             ArgType := LoadAddress();
  455.             PushLongA0;
  456.             if not TypeCmp(ArgType, CurrentParam^.VType) then
  457.                 Mismatch;
  458.             end else
  459.             error("Expecting a variable name (reference param)");
  460.         end;
  461.         CurrentParam := CurrentParam^.Next;
  462.         if CurrentParam <> Nil then
  463.             if not Match(Comma1) then
  464.             error("Expected ,");
  465.         end;
  466.     end;
  467.     if CurrentParam <> Nil then
  468.         error("more parameters needed");
  469.     end else begin
  470.     if ProcID^.Param <> Nil then
  471.         error("Expecting some parameters");
  472.     end
  473. end;
  474.  
  475. Procedure PushFrame(Callee : Integer);
  476. var
  477.     Caller : Integer;
  478. begin
  479.     if Callee <= 1 then { global-level routines, which include externs }
  480.     return
  481.     else begin
  482.     Caller := CurrentBlock^.Level - 1;
  483.     if Callee = Caller + 1 then { calling child procedure }
  484.         writeln(OutFile, "\tmove.l\ta5,-(sp)")
  485.     else if Callee = Caller then { same level }
  486.         writeln(OutFile, "\tmove.l\t8(a5),-(sp)")
  487.     else begin
  488.         writeln(OutFile, "\tmove.l\t8(a5),a4");
  489.         Caller := Pred(Caller);
  490.         while Caller > Callee do begin
  491.         writeln(OutFile, "\tmove.l\t8(a4),a4");
  492.         Caller := Pred(Caller);
  493.         end;
  494.         writeln(OutFile, "\tmove.l\t8(a4),-(sp)");
  495.     end;
  496.     StackLoad := StackLoad + 4;
  497.     end;
  498. end;
  499.  
  500. Procedure CallFunc(FuncID : IDPtr);
  501.  
  502. {
  503.     This calls a function.  It's mostly the same as callproc,
  504. but it's called from deep within expression() rather than
  505. statement().  This will also have to push a back pointer.
  506. }
  507. var
  508.     ArgSize : Integer;
  509.     BaseOffset : Integer;
  510. begin
  511.     PushArgs(FuncID);
  512.     PushFrame(FuncID^.Level);
  513.     if FuncID^.Level <= 1 then
  514.     writeln(OutFile, "\tjsr\t_", FuncID^.Name)
  515.     else
  516.     Writeln(OutFile, "\tjsr\t_", FuncID^.Name, '%', FuncID^.Unique);
  517.     if FuncID^.Param <> Nil then begin
  518.     if FuncID^.Param^.Object = refarg then
  519.         ArgSize := FuncID^.Param^.Offset - 4
  520.     else
  521.         ArgSize := FuncID^.Param^.Offset - 8 +
  522.             FuncID^.Param^.VType^.Size;
  523.     end else begin
  524.     if FuncID^.Level <= 1 then
  525.         ArgSize := 0
  526.     else
  527.         ArgSize := 4;
  528.     end;
  529.     if ArgSize <> 0 then begin
  530.     if odd(ArgSize) then
  531.         ArgSize := Succ(ArgSize);
  532.     PopStackSpace(ArgSize);
  533.     end;
  534. end;
  535.  
  536. Procedure CallProc(ProcID : IDPtr);
  537.  
  538. var
  539.     ArgSize : Integer;
  540. begin
  541.     NextSymbol;
  542.     CallFunc(ProcID);
  543. end;
  544.  
  545. Procedure SaveThrougha0(TotalSize : Integer);
  546.  
  547. {
  548.     This saves a complex data object pointed to by d0 to the
  549. memory at a0.
  550. }
  551.  
  552. var
  553.     lab        : integer;
  554. begin
  555.     writeln(OutFile, "\tmove.l\td0,a1");
  556.     writeln(OutFile, "\tmove.l\t#", TotalSize - 1, ',d1');
  557.     lab := GetLabel();
  558.     PrintLabel(lab);
  559.     writeln(OutFile, "\tmove.b\t(a1)+,d0");
  560.     writeln(OutFile, "\tmove.b\td0,(a0)+");
  561.     write(OutFile, "\tdbra\td1,");
  562.     PrintLabel(lab);
  563.     writeln(OutFile);
  564. end;
  565.  
  566. Procedure SaveStack(TP : TypePtr);
  567.  
  568. {
  569.     This saves a variable into the memory pointed to by the
  570. longword on the top of the stack.  Odd as it may sound, this occurs
  571. fairly often.
  572. }
  573.  
  574. begin
  575.     PopLongA0;
  576.     if SimpleType(TP) then
  577.     writeln(OutFile, "\tmove.", suffix(TP^.Size), "\td0,(a0)")
  578.     else
  579.     SaveThrougha0(TP^.Size);
  580. end;
  581.  
  582. Procedure SaveVal(ID : IDPtr);
  583.  
  584. {
  585.     This saves whatever's in d0 into the variable pointed to by
  586. ID.
  587. }
  588.  
  589. var
  590.     TotalSize    : Integer;
  591.     Reg : Short;
  592. begin
  593.     TotalSize := ID^.VType^.Size;
  594.     if (ID^.Object = global) or (ID^.Object = typed_const) then begin
  595.     if SimpleType(ID^.VType) then begin
  596.         if ID^.Level > 1 then { only for typed_const, of course }
  597.         writeln(OutFile, '\tmove.', Suffix(TotalSize), '\td0,_',
  598.                 ID^.Name, '%', ID^.Unique)
  599.         else
  600.         writeln(OutFile, "\tmove.", Suffix(TotalSize),
  601.                 "\td0,_", ID^.Name)
  602.     end else begin
  603.         if ID^.Level > 1 then { only for typed_const, of course }
  604.         writeln(OutFile, '\tlea\t_',ID^.Name,'%',ID^.Unique,',a0')
  605.         else
  606.         writeln(OutFile, "\tlea\t_", ID^.Name, ',a0');
  607.         SaveThrougha0(TotalSize);
  608.     end;
  609.     end else if (ID^.Object = local) or (ID^.Object = valarg) then begin
  610.     Reg := GetFramePointer(ID^.Level);
  611.     if SimpleType(ID^.VType) then
  612.         writeln(OutFile, "\tmove.", Suffix(TotalSize), "\td0,",
  613.             ID^.Offset, '(a', Reg, ')')
  614.     else begin
  615.         writeln(OutFile, "\tlea\t", ID^.Offset, '(a', Reg, '),a0');
  616.         savethrougha0(totalsize);
  617.     end;
  618.     end else begin
  619.     Reg := GetFramePointer(ID^.Level);
  620.     writeln(OutFile, "\tmove.l\t", ID^.Offset, '(a', Reg, '),a0');
  621.     if SimpleType(ID^.VType) then
  622.         writeln(OutFile, "\tmove.", Suffix(TotalSize), "\td0,(a0)")
  623.     else
  624.         SaveThrougha0(TotalSize);
  625.     end;
  626. end;
  627.