Club Amiga de Montreal - CAM/CAM_CD_1.iso/files/364b.lha/PCQ_v1.1/Source/StanProcs.p

Text File | 1990-04-08 | 12.4 KB | 554 lines

External;

{
    Stanprocs.p (of PCQ Pascal)
    Copyright (c) 1989 Patrick Quaid

    This routine implements the various standard procedures,
    hence the name.
}

{$O-}
{$I "Pascal.i"}

    Procedure NextSymbol;
        external;
    Function Match(s : Symbols): Boolean;
        external;
    Procedure Error(s : string);
        external;
    Function Expression(): TypePtr;
        external;
    Function ConExpr(VAR t : TypePtr): Integer;
        external;
    Function TypeCmp(t1, t2 : TypePtr): Boolean;
        external;
    Function TypeCheck(t1, t2 : TypePtr): Boolean;
        external;
    Function LoadAddress() : TypePtr;
        external;
    Procedure Mismatch;
        external;
    Procedure NeedLeftParent;
        external;
    Procedure NeedRightParent;
        external;
    Procedure NeedNumber;
        external;
    Function FindID(s : string) : IDPtr;
        external;
    Function FindWithField(s : String) : IDPtr;
        External;
    Procedure SaveStack(TP : TypePtr);
        external;
    Procedure SaveVal(ID : IDPtr);
        external;
    Procedure ns;
        external;
    Procedure PromoteType(var f : TypePtr; o : TypePtr; r : Short);
        external;
    Function NumberType(t : TypePtr): Boolean;
        external;
    Procedure PushLongD0;
        external;
    Procedure PushWordD0;
        external;
    Procedure PopLongD1;
        external;
    Procedure PopStackSpace(amount : Integer);
        External;
    Procedure PushLongA0;
        External;
    Function Selector(ID : IDPtr) : TypePtr;
        external;
    Function Suffix(size : Integer) : Char;
        External;

Procedure CallWrite(TP : TypePtr);

{
    This routine calls the appropriate library routine to write
vartype to a text file.
}

var
    ElementType    : TypePtr;
begin
    if TypeCmp(TP, RealType) then
    writeln(OutFile, "\tjsr\t_p%WriteReal")
    else if NumberType(TP) then begin
    PromoteType(TP, IntType, 0);
    writeln(OutFile, "\tjsr\t_p%WriteInt");
    end else if TypeCmp(TP, CharType) then
    writeln(OutFile, "\tjsr\t_p%WriteChar")
    else if TypeCmp(TP, BoolType) then
    writeln(OutFile, "\tjsr\t_p%WriteBool")
    else if TP^.Object = ob_array then begin
    ElementType := TP^.SubType;
    if TypeCmp(ElementType, CharType) then begin
        writeln(OutFile, "\tmove.l\t#", TP^.Upper - TP^.Lower + 1, ',d3');
        writeln(OutFile, "\tjsr\t_p%WriteCharray");
    end else
        Error("Write() can only write arrays of char");
    end else if TP = StringType then
    writeln(OutFile, "\tjsr\t_p%WriteString")
    else
    Error("can't write that type to text file");
    if IOCheck then
    Writeln(OutFile, '\tjsr\t_p%CheckIO');
end;

Procedure FileWrite(TP : TypePtr);

{
    This routine writes a variable to a File of TP
}

begin
    writeln(OutFile, "\tmove.l\t#", TP^.Size, ',d3');
    writeln(OutFile, "\tjsr\t_p%WriteArb");
    if IOCheck then
    Writeln(OutFile, '\tjsr\t_p%CheckIO');
end;

Procedure DoWrite(ID : IDPtr);

{
    This routine handles all aspects of the write and writeln
statements.
}

var
    FileType    : TypePtr; { file type if there is one }
    ExprType    : TypePtr; { current element type }
    Pushed    : Boolean; { have pushed the file handle on stack }
    Width    : Integer; { constant field width }
    WidType     : TypePtr; { type of the above }
begin
    if Match(LeftParent1) then begin
    FileType := Expression();
    Pushed := True;
    if FileType^.Object = ob_file then
        PushLongD0
    else begin
        writeln(OutFile, "\tmove.l\t#_Output,-(sp)");
        StackLoad := StackLoad + 4;
        if Match(colon1) then begin
        PushLongD0;
        WidType := Expression();
        if not TypeCheck(IntType, WidType) then
            NeedNumber;
        PopLongD1;
        PushWordD0;
        writeln(OutFile, "\tmove.l\td1,d0");
        end else begin
        writeln(OutFile, "\tmove.w\t#1,-(sp)");
        StackLoad := StackLoad + 2;
        end;
        if TypeCmp(FileType, RealType) then begin
        if Match(colon1) then begin
            PushLongD0;
            WidType := Expression();
            if not TypeCheck(IntType, WidType) then
            NeedNumber;
            PopLongD1;
            PushWordD0;
            writeln(OutFile, "\tmove.l\td1,d0");
        end else begin
            writeln(OutFile, "\tmove.w\t#2,-(sp)");
            StackLoad := StackLoad + 2;
        end;
        end;
        CallWrite(FileType);
        if TypeCmp(FileType, RealType) then
        PopStackSpace(4)
        else
        PopStackSpace(2);
        FileType := TextType;
    end;
    while not Match(RightParent1) do begin
        if not Match(Comma1) then
        Error("expecting , or )");
        ExprType := Expression();
        if FileType = TextType then begin
        if Match(Colon1) then begin
            PushLongD0;
            WidType := Expression();
            if not TypeCheck(IntType, WidType) then
            NeedNumber;
            PopLongD1;
            PushWordD0;
            writeln(OutFile, "\tmove.l\td1,d0");
        end else begin
            writeln(OutFile, "\tmove.w\t#1,-(sp)");
            StackLoad := StackLoad + 2;
        end;
        if TypeCmp(ExprType, RealType) then begin
            if Match(colon1) then begin
            PushLongD0;
            WidType := Expression();
            if not TypeCheck(IntType, WidType) then
                NeedNumber;
            PopLongD1;
            PushWordD0;
            writeln(OutFile, "\tmove.l\td1,d0");
            end else begin
            writeln(OutFile, "\tmove.w\t#2,-(sp)");
            StackLoad := StackLoad + 2;
            end;
        end;
        CallWrite(ExprType);
        if TypeCmp(ExprType, RealType) then
            PopStackSpace(4)
        else
            PopStackSpace(2);
        end else begin
        if TypeCmp(FileType^.SubType, ExprType) then
            FileWrite(ExprType)
        else
            Mismatch;
        end;
    end;
    end else begin
    FileType := TextType;
    Pushed := False;
    if ID^.Offset = 1 then
        error("'write' requires arguments.");
    end;
    if ID^.Offset = 2 then begin
    if FileType = TextType then begin
        if Pushed then
        writeln(OutFile, "\tjsr\t_p%WriteLn")
        else begin
        writeln(OutFile, "\tmove.l\t#_Output,-(sp)");
        writeln(OutFile, "\tjsr\t_p%WriteLn");
        writeln(OutFile, "\taddq.l\t#4,sp");
        end;
        if IOCheck then
        Writeln(OutFile, '\tjsr\t_p%CheckIO');
    end else
       error("Writeln is only for text files");
    end;
    if Pushed then
    PopStackSpace(4);
end;

Procedure CallRead(TP : TypePtr);

{
    This routine calls the appropriate library routines to read
the vartype from a text file.
}

begin
    if TypeCmp(TP, CharType) then
    writeln(OutFile, "\tjsr\t_p%ReadChar")
    else if TypeCmp(TP, IntType) then begin
    writeln(OutFile, "\tjsr\t_p%ReadInt");
    writeln(OutFile, "\tmove.l\td0,(a0)");
    end else if TypeCmp(TP, ShortType) then begin
    writeln(OutFile, "\tjsr\t_p%ReadInt");
    writeln(OutFile, "\tmove.w\td0,(a0)");
    end else if TypeCmp(TP, RealType) then
    writeln(OutFile, "\tjsr\t_p%ReadReal")
    else if TP^.Object = ob_array then begin
    if TypeCmp(TP^.SubType, chartype) then begin
        writeln(OutFile, "\tmove.l\t#", TP^.Upper - TP^.Lower + 1, ',d3');
        writeln(OutFile, "\tjsr\t_p%ReadCharray");
    end else
        Error("can only read character arrays");
    end else if TP = StringType then
    writeln(OutFile, "\tjsr\t_p%ReadString")
    else
    Error("cannot read that type from a text file");
    if IOCheck then
    Writeln(OutFile, '\tjsr\t_p%CheckIO');
end;

Procedure DoRead(ID : IDPtr);

{
    This handles the read statement.  Note that read(f, var) from a
non-text file really does end up being var := f^; get(f).  Same
goes for text files, but it's all handled within the library.
    Note the difference between this and dowrite(),
specifically the use of expression() up there and loadaddress()
here.
}

var
    FileType,
    VarType    : TypePtr;
    Pushed    : Boolean;
begin
    if Match(LeftParent1) then begin
    FileType := LoadAddress();
    Pushed := True;
    if FileType^.Object = ob_file then
        PushLongA0
    else begin
        writeln(OutFile, "\tmove.l\t#_Input,-(sp)");
        StackLoad := StackLoad + 4;
        CallRead(FileType);
        FileType := TextType;
    end;
    while not Match(RightParent1) do begin
        if not Match(Comma1) then
        Error("expecting , or )");
        VarType := LoadAddress();
        if FileType = TextType then
        CallRead(VarType)
        else begin
        if TypeCmp(FileType^.SubType, VarType) then
            writeln(OutFile, "\tjsr\t_p%ReadArb")
        else
            Mismatch;
        if IOCheck then
            Writeln(OutFile, '\tjsr\t_p%CheckIO');
        end;
    end;
    end else begin
    FileType := TextType;
    Pushed := False;
    if ID^.Offset = 3 then
        error("'read' requires arguments.");
    end;
    if ID^.Offset = 4 then begin
    if TypeCmp(FileType, TextType) then begin
        if Pushed then
        writeln(OutFile, "\tjsr\t_p%ReadLn")
        else begin
        writeln(OutFile, "\tmove.l\t#_Input,-(sp)");
        writeln(OutFile, "\tjsr\t_p%ReadLn");
        writeln(OutFile, "\taddq.l\t#4,sp");
        end;
        if IOCheck then
        Writeln(OutFile, '\tjsr\t_p%CheckIO');
    end else
       error("Readln applies only to Text files");
    end;
    if Pushed then
    PopStackSpace(4);
end;

Procedure DoNew;

{
    This just handles allocation of memory.
}

var
    ID        : IDPtr;
    TP        : TypePtr;
    StackVar    : TypePtr;
begin
    NeedLeftParent;
    ID := FindWithField(SymText);
    if ID = Nil then
    ID := FindID(SymText);
    if ID <> Nil then begin
    NextSymbol;
    StackVar := Selector(ID);
    if StackVar = Nil then
        TP := ID^.VType
    else begin
        PushLongA0;
        TP := StackVar;
    end;
    if TP^.Object <> ob_pointer then
        Error("expecting a pointer type");
    writeln(OutFile, "\tmove.l\t#", TP^.SubType^.Size, ',d0');
    writeln(OutFile, "\tjsr\t_p%new");
    if StackVar = Nil then
        SaveVal(ID)
    else
        SaveStack(TP);
    end else
    Error("Unknown identifier");
    NeedRightParent;
end;

Procedure DoDispose;

{
    This routine calls the library routine that frees memory.
}

var
    ExprType    : TypePtr;
begin
    NeedLeftParent;
    ExprType := Expression();
    if ExprType^.Object <> ob_pointer then
    Error("Expecting a pointer type")
    else
    writeln(OutFile, "\tjsr\t_p%dispose");
    NeedRightParent;
end;

Procedure DoClose;

{
    Closes a file.  The difference between this and a normal
DOS close is that this routine must un-link the file from the
program's open file list.
}

var
    ExprType    : TypePtr;
begin
    NeedLeftParent;
    ExprType := LoadAddress();
    if ExprType^.Object <> ob_file then
    Error("Expecting a file type")
    else
    writeln(OutFile, "\tjsr\t_p%Close");
    if IOCheck then
    Writeln(OutFile, '\tjsr\t_p%CheckIO');
    NeedRightParent;
end;

Procedure DoGet;

{
    This implements get.
}

var
    ExprType    : TypePtr;
begin
    NeedLeftParent;
    ExprType := LoadAddress();
    if ExprType^.Object <> ob_file then
    Error("Expecting a file type")
    else
    Writeln(OutFile, '\tjsr\t_p%Get');
    if IOCheck then
    Writeln(OutFile, '\tjsr\t_p%CheckIO');
    NeedRightParent;
end;

Procedure DoPut;

{
    This just implements put.  The real guts of these two
routines is in the runtime library.
}

var
    ExprType    : TypePtr;
begin
    NeedLeftParent;
    ExprType := LoadAddress();
    if ExprType^.Object <> ob_file then
    Error("Expecting a file type")
    else
    Writeln(OutFile, '\tjsr\t_p%Put');
    if IOCheck then
    Writeln(OutFile, '\tjsr\t_p%CheckIO');
    NeedRightParent;
end;

Procedure DoInc;

{
    This takes care of Inc.
}

var
    ExprType    : TypePtr;
begin
    NeedLeftParent;
    ExprType := LoadAddress();
    with ExprType^ do begin
    case Object of
      ob_ordinal : Writeln(OutFile, '\taddq.',Suffix(Size),'\t#1,(a0)');
      ob_pointer : Writeln(OutFile, '\tadd.l\t#', SubType^.Size,',(a0)');
    else
        Error("Expecting an ordinal or pointer type");
    end;
    end;
    NeedRightParent;
end;

Procedure DoDec;

{
    This takes care of Dec.
}

var
    ExprType    : TypePtr;
begin
    NeedLeftParent;
    ExprType := LoadAddress();
    with ExprType^ do begin
    case Object of
      ob_ordinal : Writeln(OutFile, '\tsubq.',Suffix(Size),'\t#1,(a0)');
      ob_pointer : Writeln(OutFile, '\tsub.l\t#', SubType^.Size,',(a0)');
    else
        Error("Expecting an ordinal or pointer type");
    end;
    end;
    NeedRightParent;
end;

Procedure DoExit;

{
    Just calls the routine that allows the graceful shut-down
of the program.
}

var
    ExprType : TypePtr;
begin
    NeedLeftParent;
    ExprType := Expression();
    if not TypeCheck(ExprType, IntType) then
    Error("Expecting an integer argument.");
    writeln(OutFile, "\tjsr\t_p%exit");
    NeedRightParent;
end;

Procedure DoTrap;

{
    This is just for debugging a program.  Use some trap, and
your debugger will stop at that statement.
}

var
    ExprType  : TypePtr;
    TrapNum   : Integer;
begin
    NeedLeftParent;
    TrapNum := ConExpr(ExprType);
    writeln(OutFile, "\ttrap\t#", trapnum);
    NeedRightParent;
end;

Procedure StdProc(ProcID : IDPtr);

{
    This routine sifts out the proper routine to call.
}

begin
    NextSymbol;
    case ProcID^.Offset of
      1,2 : DoWrite(ProcID);
      3,4 : DoRead(ProcID);
      5   : DoNew;
      6   : DoDispose;
      7   : DoClose;
      8   : DoGet;
      9   : DoExit;
      10  : DoTrap;
      11  : DoPut;
      12  : DoInc;
      13  : DoDec;
    end;
end;