cexpr.p

<B>Digital的Unix操作系统VAX 4.2源码</B>

(*#@(#)cexpr.p	4.1	Ultrix	7/17/90 *)
(****************************************************************************
 *									    *
 *  Copyright (c) 1984 by						    *
 *  DIGITAL EQUIPMENT CORPORATION, Maynard, Massachusetts.		    *
 *  All rights reserved.						    *
 * 									    *
 *  This software is furnished under a license and may be used and copied   *
 *  only in  accordance with  the  terms  of  such  license  and with the   *
 *  inclusion of the above copyright notice. This software or  any  other   *
 *  copies thereof may not be provided or otherwise made available to any   *
 *  other person.  No title to and ownership of  the  software is  hereby   *
 *  transferred.							    *
 * 									    *
 *  The information in this software is  subject to change without notice   *
 *  and  should  not  be  construed as  a commitment by DIGITAL EQUIPMENT   *
 *  CORPORATION.							    *
 * 									    *
 *  DIGITAL assumes no responsibility for the use  or  reliability of its   *
 *  software on equipment which is not supplied by DIGITAL.		    *
 * 									    *
$Header: cexpr.p,v 1.6 84/06/06 12:52:19 powell Exp $
 ****************************************************************************)
#include "globals.h"
#include "bexpr.h"
#include "cexpr.h"
#include "const.h"
#include "decls.h"
#include "builtin.h"
#include "alloc.h"

{
    Resolve, type-check and reconstruct expressions:

	Resolution is through the procedures NameExpr, SymExpr, RecordExpr,
	and ImplQualExpr.  These routines figure out what a name list means
	and call the regular type-checking routines.  They do no checking
	on their own.

	The regular type-checking routines take an ExprNode parameter and a
	mode indicating how the expression is used (principally, whether the
	value or address is of interest).  For address expressions, they are
	free to reconstruct the expression tree in terms of explicit address
	calculations.  For value expressions, they must insert a value node.
	Since the original expression nodes may be lost, having been converted
	to an address expression, these routines return a type which represents
	the logical type of the expression.  In reconstructing the expression
	tree, the argument ExprNode must remain the root of the expression,
	since there are pointers to it.

	After this pass, there should be no SUBSCRIPT, DOT, or DEREF nodes.
	NAME and SET nodes should also be gone.  SYM nodes may still exist for
	type names.  VAR nodes subsequently mean the address of the variable.

}
procedure BadExpr(en : ExprNode);
begin
    en^.kind := EXPRBAD;
    en^.exprType := anyTypeNode;
end;

function IsBadExpr{(en : ExprNode) : boolean};
begin
    if en = nil then begin
	IsBadExpr := true;
    end else begin
	IsBadExpr := en^.kind = EXPRBAD;
    end;
end;

function IsAddressableExpr{(en : ExprNode) : boolean};
var
    result : boolean;
begin
    result := false;
    if en = nil then begin
	{ do nothing }
    end else if (en^.kind in [EXPRVAL, EXPRVAR, EXPRBINOP, EXPRCHECK]) and
	(en^.exprType = addressTypeNode)
    then begin
	result := true;
    end;
    IsAddressableExpr := result;
end;

function ConstType{(cn : ConstNode) : TypeNode};
var
    tn : TypeNode;
begin
    if TraceNexpr then begin
	write(output,'ConstType(',cn^.kind:1,')=');
	WriteConstant(output,cn);
	writeln(output);
    end;
    case cn^.kind of
	DTINTEGER : tn := integerTypeNode;
	DTCARDINAL : begin
	    if cn^.cardVal > MAXINT then begin
		tn := cardinalTypeNode;
	    end else begin
		tn := cardIntTypeNode;
	    end;
	end;
	DTREAL : tn := realConstTypeNode;
	DTCHAR : tn := charConstTypeNode;
	DTBOOLEAN : tn := booleanTypeNode;
	DTSTRING : begin
	    tn := NewTypeNode(DTSTRING);
	    tn^.stringLength := cn^.strVal^.length;
	    tn^.size := tn^.stringLength * CHARSIZE;
	end;
	DTENUMERATION : tn := cn^.enumVal^.enumType;
	DTPOINTER : tn := addressTypeNode;
	DTPROC : tn := cn^.procVal^.procType;
	DTSET : tn := cn^.setVal^.setType;
    end;
    ConstType := tn;
end;

procedure InsertCheckExpr{(en : ExprNode; check : CheckKind; vn : VarNode;
	    tn : TypeNode; lowerBound, upperBound : cardinal)};
var
    oen : ExprNode;
begin
    oen := NewExprNode(en^.kind);
    oen^ := en^;
    en^.kind := EXPRCHECK;
    en^.exprCheck := check;
    en^.checkExpr := oen;
    en^.checkVar := vn;
    en^.checkType := tn;
    en^.checkField := nil;
    en^.checkLower := lowerBound;
    en^.checkUpper := upperBound;
end;

function ImplQualExpr(en : ExprNode; sym : Symbol; mode : EvalMode) : TypeNode;
var
    qen, aen : ExprNode;
    wqn : WithQualNode;
    fn : FieldNode;
    found : boolean;
    tn : TypeNode;
begin
    found := false;
    fn := sym^.symField;
    wqn := withQualList;
    while not found and (wqn <> nil) do begin
	if fn^.recType = wqn^.recType then begin
	    found := true;
	end else begin
	    wqn := wqn^.next;
	end;
    end;
    tn := nil;
    if not found then begin
	ExprErrorName(en,sym^.name,'Field used without qualification');
	BadExpr(en);
    end else begin
	{ found field in a with statemtent: generate implQual^.field }
	qen := NewExprNode(EXPRVAR);		{ node for implQual }
	SameExprLine(qen,en);
	qen^.exprVar := wqn^.implQual;
	aen := NewExprNode(EXPRDEREF);		{ node for implQual^ }
	SameExprLine(aen,en);
	aen^.ptr := qen;
	aen^.realPtr := false;
	en^.kind := EXPRDOT;			{ node for implQual^.field }
	en^.rec := aen;
	en^.field := fn;
	en^.fieldName := nil;
	tn := DotExpr(en,mode);
	{ this expression depends on the var in the with expression }
	en^.baseVar := wqn^.baseVar;
	en^.basePtrType := wqn^.basePtrType;
    end;
    ImplQualExpr := tn;
end;

function RecordExpr(en : ExprNode; sym : Symbol; names : IdentList;
	mode : EvalMode) : TypeNode;
var
    error : boolean;
    id, idnext : IdentNode;
    vt, rentn : TypeNode;
    ren, fen : ExprNode;
begin
    { get expression for record symbol }
    ren := NewExprNode(EXPRSYM);
    SameExprLine(ren,en);
    ren^.exprSym := sym;
    { add field qualifications to record }
    id := names^.first;
    while id <> nil do begin
	idnext := id^.next;
	if idnext = nil then begin
	    fen := en;	{ use original en for final field }
	    fen^.kind := EXPRDOT;
	end else begin
	    fen := NewExprNode(EXPRDOT);    { otherwise, get new one}
	    SameExprLine(fen,ren);
	end;
	fen^.rec := ren;
	fen^.fieldName := id^.name;
	ren := fen;
	dispose(id);
	id := idnext;
    end;
    dispose(names);
    assert (en = ren);
    en := ren;
    RecordExpr := DotExpr(en,mode);
end;

function SymExpr(en : ExprNode; mode : EvalMode) : TypeNode;
var
    sym : Symbol;
    cn : ConstNode;
    tn : TypeNode;
begin
    if TraceNexpr then begin
	writeln(output,'SymExpr');
    end;
    sym := en^.exprSym;
    tn := nil;
    if sym = nil then begin
	BadExpr(en);
    end else if sym^.kind = SYMCONST then begin
	en^.kind := EXPRCONST;
	en^.exprConst := sym^.symConst;
	tn := ConstExpr(en,mode);
    end else if sym^.kind = SYMVAR then begin
	en^.kind := EXPRVAR;
	en^.exprVar := sym^.symVar;
	tn := VarExpr(en,mode);
    end else if sym^.kind = SYMFIELD then begin
	tn := ImplQualExpr(en,sym,mode);
    end else if sym^.kind = SYMPROC then begin
	new(cn);
	cn^.kind := DTPROC;
	cn^.procVal := sym^.symProc;
	en^.kind := EXPRCONST;
	en^.exprConst := cn;
	tn := ConstExpr(en,mode);
	if mode = EVALGET then begin
	    sym^.symProc^.internalProc := false;
	end;
    end else if sym^.kind = SYMENUM then begin
	new(cn);
	cn^.kind := DTENUMERATION;
	cn^.enumVal := sym^.symEnum;
	en^.kind := EXPRCONST;
	en^.exprConst := cn;
	tn := ConstExpr(en,mode);
    end else if sym^.kind = SYMTYPE then begin
	en^.kind := EXPRSYM;
	en^.exprSym := sym;
	en^.exprType := ActualType(sym^.symType);
	tn := en^.exprType;
    end else begin
	ExprErrorName(en,sym^.name,'Symbol not valid in expression');
	BadExpr(en);
    end;
    SymExpr := tn;
end;

function NameExpr(en : ExprNode; mode : EvalMode) : TypeNode;
var
    sym : Symbol;
    cn : ConstNode;
    tn : TypeNode;
begin
    if TraceNexpr then begin
	writeln(output,'NameExpr');
    end;
    tn := nil;
    sym := QualifiedName(en^.exprName);
    if sym = nil then begin
	BadExpr(en);
    end else if en^.exprName^.first <> nil then begin
	{ more qualifiers, must be a record }
	tn := RecordExpr(en,sym,en^.exprName,mode);
    end else begin
	en^.kind := EXPRSYM;
	en^.exprSym := sym;
	tn := SymExpr(en,mode);
    end;
    NameExpr := tn;
end;

{ Insert a value node if necessary (mode = EVALGET). }
{  Change expression type to address.  }
procedure ValueOrAddr{(en : ExprNode; tn : TypeNode; mode : EvalMode)};
var
    nen : ExprNode;
begin
    if TraceNexpr then begin
	write(output,'ValueOrAddr ');
	WriteExpr(output,en);
	writeln(output);
    end;
    if mode = EVALGET then begin
	nen := NewExprNode(en^.kind);
	nen^ := en^;
	nen^.exprType := addressTypeNode;
	en^.kind := EXPRVAL;
	en^.exprVal := nen;
	en^.dependVar := nen^.baseVar;
	en^.dependPtrType := nen^.basePtrType;
	en^.exprType := tn;
    end else begin
	en^.exprType := addressTypeNode;
    end;
end;


{  Add a dereference if the expression is an open array }
procedure RefOpenArray{(en : ExprNode; tn : TypeNode)};
begin
    if tn^.kind = DTARRAY then begin
	if tn^.arrayKind = ARRAYOPEN then begin
	    ValueOrAddr(en,addressTypeNode,EVALGET);
	end;
    end;
end;

{ The following are the real expression manipulating routines. }
{   The above name-resolving routines "always" call them. }
{   ( exceptions are errors, type names, procedure names, etc.) }

function ConstExpr{(en : ExprNode; mode : EvalMode) : TypeNode};
begin
    if TraceNexpr then begin
	write(output,'ConstExpr(',en^.exprConst^.kind:1,')=');
	WriteConstant(output,en^.exprConst);
	writeln(output);
    end;
    if mode = EVALPUT then begin
	ExprErrorName(en,stringDataType[en^.exprConst^.kind],
		'Constant must not be changed');
	BadExpr(en);
    end else begin
	en^.exprType := ConstType(en^.exprConst);
	en^.constType := en^.exprType;
    end;
    ConstExpr := en^.exprType;
end;

function VarExpr{(en : ExprNode; mode : EvalMode) : TypeNode};
var
    tn : TypeNode;
    vn : VarNode;
begin
    vn := en^.exprVar;
    tn := ActualType(vn^.varType);
    if vn^.indirect then begin
	{ insert value node to get address of variable }
	en^.baseVar := vn;
	ValueOrAddr(en,addressTypeNode,EVALGET);
	{ indirection is not real value }
	en^.dependVar := nil;
	en^.dependPtrType := nil;
    end;
    if mode = EVALPUT then begin
	vn^.changed := true;
    end;
    en^.baseVar := vn;
    ValueOrAddr(en,tn,mode);
    VarExpr := tn;
end;

function UnOpExpr{(en : ExprNode; mode : EvalMode) : TypeNode};
var
    opndtn, et : TypeNode;
    opnd : ExprNode;
    con : ConstNode;
begin
    if TraceNexpr then begin
	writeln(output,'UnOpExpr(',en^.exprUnOp:0,',',mode:0,')');
    end;
    opndtn := BaseType(CheckExpr(en^.opnd,EVALGET));
    en^.unOperType := opndtn;
    opnd := en^.opnd;
    et := nil;
    if mode <> EVALGET then begin
	ExprErrorName(en,stringToken[en^.exprUnOp],
		'Expression must be used as a value');
    end else if opndtn = nil then begin
	{ do nothing }
    end else if en^.exprUnOp in [TKPLUS,TKMINUS] then begin
	if opndtn^.kind in [DTINTEGER, DTCARDINAL, DTREAL, DTLONGREAL]
	then begin
	    et := opndtn;
	end;
    end else if en^.exprUnOp = TKNOT then begin
	if opndtn^.kind = DTBOOLEAN then begin
	    et := opndtn;
	end;
    end else begin
	ExprErrorName(en,stringToken[en^.exprUnOp],'Unexpected unary operator');
    end;
    if et = nil then begin
	ExprErrorName(en,stringDataType[opnd^.exprType^.kind],
		'Invalid operand type for unary operator');
	BadExpr(en);
    end else begin
	en^.exprType := ActualType(et);
	if en^.opnd^.kind = EXPRCONST then begin
	    con := UnOpConst(en^.exprUnOp,en^.opnd^.exprConst);
	    en^.kind := EXPRCONST;
	    en^.exprConst := con;
	    en^.constType := en^.exprType;
	end;
    end;
    UnOpExpr := en^.exprType;
end;

procedure EvalConstBinOpExpr{(en : ExprNode)};
var
    con : ConstNode;
begin
    if (en^.opnd1^.kind = EXPRCONST) and (en^.opnd2^.kind = EXPRCONST)
    then begin
	con := BinOpConst(en^.exprBinOp,en^.opnd1^.exprConst,
		en^.opnd2^.exprConst,true);
	en^.kind := EXPRCONST;
	en^.exprConst := con;
	en^.constType := en^.exprType;
    end;
end;

{

    The following are legal binary operations.  In all cases except IN,
	operands must be compatible.
    
    e in s: result boolean
	e must be compatible with range of set s

    relations: result boolean
	    I  C  R  S  B  St Ch E  P  A  R
	=   +  +  +  +  +  +  +  +  +  +  +
	#   +  +  +  +  +  +  +  +  +  +  +
	/=  +  +  +  +  +  +  +  +  +  +  +
	>=  +  +  +  +  +  +  +  +
	>   +  +  +     +  +  +  +
	<=  +  +  +  +  +  +  +  +
	<   +  +  +     +  +  +  +

    arithmetic and set operations: result operand type
	    I  C  R  S
	+   +  +  +  +
	-   +  +  +  +
	*   +  +  +  +
	/         +  +
	div +  +
	mod +  +
    
    boolean operations: result boolean
	    B
	and +
	&   +
	or  +
}
function BinOpExpr(en : ExprNode; mode : EvalMode) : TypeNode;
var
    opndType, resultType, setType : TypeNode;
    opnd1, opnd2, nen : ExprNode;
    opnd1tn, opnd2tn : TypeNode;
    oper : Token;