cexpr.p

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

    con : ConstNode;
    lowerBound : cardinal;
begin
    if TraceNexpr then begin
	writeln(output,'BinExprNode(',oper:0,',',mode:0,')');
    end;
    oper := en^.exprBinOp;;
    resultType := nil;
    opnd1tn := CheckExpr(en^.opnd1,EVALGET);
    opnd1 := en^.opnd1;
    opnd2tn := CheckExpr(en^.opnd2,EVALGET);
    opnd2 := en^.opnd2;
    if mode <> EVALGET then begin
	ExprErrorName(en,stringToken[en^.exprBinOp],
		'Expression must be used as a value');
    end else if IsBadExpr(opnd1) or IsBadExpr(opnd2) then begin
	{ do nothing }
    end else if oper = TKIN then begin
{ IN }
	setType := BaseType(opnd2tn);
	if setType^.kind <> DTSET then begin
	    ExprError(en,'Right operand of IN is not a set');
	end else begin
	    opndType := Compatible(opnd1tn,opnd1,setType^.setRange,nil);
	    if opndType = nil then begin
		ExprError(en,'Left operand of IN does not match type of set');
	    end else begin
		opndType := BaseType(opndType);
		en^.operType := opndType;
		lowerBound := LowerBoundOf(setType^.setRange);
		if lowerBound <> 0 then begin
		    { replace opnd1 with (opnd1 - lowerBound) }
		    nen := NewExprNode(opnd1^.kind);
		    nen^ := opnd1^;
		    opnd1^.kind := EXPRBINOP;
		    opnd1^.exprBinOp := TKMINUS;
		    opnd1^.opnd1 := nen;
		    opnd1^.opnd2 := ConstExprNode(CardinalConst(lowerBound));
		    opnd1^.opnd2^.exprType := nen^.exprType;
		    opnd1^.operType := nen^.exprType;
		end;
		resultType := booleanTypeNode;
	    end;
	end;
    end else begin
	opndType := Compatible(opnd1tn,opnd1,opnd2tn,opnd2);
	if opndType = nil then begin
	    ExprErrorName(en,stringToken[oper],
		    'Incompatible operands on binary operator');
	end else begin
	    opndType := BaseType(opndType);
	    en^.operType := opndType;
	    if oper in [TKEQUALS, TKNOTEQUAL, TKSHARP, TKLESS, TKGREATER,
		    TKLSEQUAL, TKGREQUAL]
	    then begin
{ RELATIONAL }
		if (opndType^.kind in [DTINTEGER, DTBOOLEAN, DTCHAR, DTSTRING,
			DTREAL, DTLONGREAL, DTCARDINAL, DTENUMERATION]) or
			(opndType = addressTypeNode)
		then begin
		    resultType := booleanTypeNode;
		end else if (opndType^.kind = DTSET) and
			not (oper in [TKLESS, TKGREATER])
		then begin
		    if oper = TKGREQUAL then begin
			{ change >= to <= with switched operands }
			en^.opnd1 := opnd2;
			en^.opnd2 := opnd1;
			en^.exprBinOp := TKLSEQUAL;
		    end;
		    resultType := booleanTypeNode;
		end else if (opndType^.kind = DTPOINTER)
			and (oper in [TKEQUALS, TKNOTEQUAL, TKSHARP])
		then begin
		    resultType := booleanTypeNode;
		end else if (opndType^.kind = DTARRAY)
			and (oper in [TKEQUALS, TKNOTEQUAL, TKSHARP])
		then begin
		    if ActualType(opndType^.elementType) = charTypeNode
		    then begin
			resultType := booleanTypeNode;
		    end;
		end;
		if resultType = nil then begin
		    ExprErrorName(en,stringToken[oper],
			    'Operand types invalid for operator');
		end;
	    end else if oper in [TKPLUS, TKMINUS, TKASTERISK, TKSLASH, TKDIV,
		    TKMOD]
	    then begin
{ ARITHMETIC }
		if ((opndType^.kind in [DTINTEGER, DTCARDINAL])
			    or (opndType = addressTypeNode))
		and
			(oper <> TKSLASH)
		then begin
		    resultType := opndType;
		end else if (opndType^.kind in [DTREAL,DTLONGREAL]) and
			not (oper in [TKDIV,TKMOD])
		then begin
		    resultType := opndType;
		end else if (opndType^.kind = DTSET) and
			not (oper in [TKDIV,TKMOD])
		then begin
		    resultType := opndType;
		end;
	    end else if oper in [TKAND, TKOR, TKAMPERSAND] then begin
		if opndType^.kind = DTBOOLEAN then begin
		    resultType := booleanTypeNode;
		end;
	    end;
	    if resultType = nil then begin
		ExprErrorName(en,stringToken[oper],
			'Operand types invalid for operator');
	    end;
	end;
    end;
    if resultType = nil then begin
	BadExpr(en);
    end else begin
	en^.exprType := ActualType(resultType);
	EvalConstBinOpExpr(en);
    end;
    BinOpExpr := en^.exprType;
end;

procedure FactorInConstants(var en : ExprNode; var total, multiple : cardinal;
	multiply : boolean);
var
    tmpen, olden : ExprNode;
begin
    olden := en;
    { en will be multiplied by multiple and added to total }
    { update en, total, and multiple to try to improve things }
    if en^.kind = EXPRBINOP then begin
	if en^.exprBinOp = TKPLUS then begin
	    if en^.opnd1^.kind = EXPRCONST then begin
		total := total + OrdOf(en^.opnd1^.exprConst) * multiple;
		en := en^.opnd2;
	    end else if en^.opnd2^.kind = EXPRCONST then begin
		total := total + OrdOf(en^.opnd2^.exprConst) * multiple;
		en := en^.opnd1;
	    end;
	end else if en^.exprBinOp = TKMINUS then begin
	    if en^.opnd2^.kind = EXPRCONST then begin
		total := total - OrdOf(en^.opnd2^.exprConst) * multiple;
		en := en^.opnd1;
	    end;
	end else if multiply and (en^.exprBinOp = TKASTERISK) then begin
	    if en^.opnd1^.kind = EXPRCONST then begin
		multiple := multiple * OrdOf(en^.opnd1^.exprConst);
		en := en^.opnd2;
	    end else if en^.opnd2^.kind = EXPRCONST then begin
		multiple := multiple * OrdOf(en^.opnd2^.exprConst);
		en := en^.opnd1;
	    end;
	end;
    end;
    if en <> olden then begin
	FactorInConstants(en,total,multiple,multiply);
    end;
end;

function SubscriptExpr(en : ExprNode; mode : EvalMode) : TypeNode;
var
    sen, sennext, multen, adden, newadden, aen : ExprNode;
    rowtn, sentn : TypeNode;
    subnum : integer;
    error : boolean;
    subOffset, subMultiple, rowsize, lowerBound, upperBound, baseOffset
	    : cardinal;
begin
    if TraceNexpr then begin
	writeln(output,'SubscriptExpr');
    end;
    error := false;
    aen := en^.arr;
    if mode = EVALPUT then begin
	rowtn := BaseType(CheckExpr(aen,EVALPUT));
    end else begin
	rowtn := BaseType(CheckExpr(aen,EVALPOINT));
    end;
    if IsBadExpr(aen) then begin
	{ do nothing }
	error := true;
    end else if rowtn^.kind <> DTARRAY then begin
	ExprError(en,'Subscripted expression not an array');
	error := true;
    end else begin
	RefOpenArray(aen,rowtn);
	subnum := 1;
	adden := aen;
	sen := en^.subscripts^.first;
	baseOffset := 0;
	while not error and (sen <> nil) and (rowtn <> nil) do begin
	    sennext := sen^.next;
	    sentn := CheckExpr(sen,EVALGET);
	    rowtn := BaseType(rowtn);
	    if rowtn^.kind <> DTARRAY then begin
		ExprErrorNumber(en,'Too many subscripts, subscript #',subnum);
		error := true;
	    end else if rowtn^.indexType = nil then begin
		{ open array, must be cardinal subscript }
		if Assignable(cardinalTypeNode,sentn,sen) = nil then begin
		    ExprErrorNumber(en,'Incompatible type, subscript #',subnum);
		    error := true;
		end;
	    end else begin
		if Assignable(rowtn^.indexType,sentn,sen) = nil then begin
		    ExprErrorNumber(en,'Incompatible type, subscript #',subnum);
		    error := true;
		end;
	    end;
	    if not error then begin
		{ lower bound of index }
		lowerBound := LowerBoundOf(rowtn^.indexType);
		upperBound := UpperBoundOf(rowtn^.indexType);
		subOffset := 0;
		subMultiple := 1;
		{ do not factor out constants on checked open array }
		if not genCheckFlag or (rowtn^.indexType <> nil) then begin
		    FactorInConstants(sen,subOffset,subMultiple,true);
		end;
		if genCheckFlag then begin
		    if rowtn^.indexType <> nil then begin
			{ ceiling on div of lower bound, floor on upper bound }
			InsertCheckExpr(sen,CHECKSUBSCR,nil,sentn,
			    CardDiv(lowerBound-subOffset+(subMultiple-1),
				    subMultiple),
			    CardDiv(upperBound-subOffset,subMultiple));
		    end else if rowtn^.nocount then begin
			{ no check }
		    end else begin
			{ for open array, always 0..count-1 }
			InsertCheckExpr(sen,CHECKSUBSCROPEN,aen^.baseVar,
				cardinalTypeNode,0,0);
		    end;
		end;
		rowtn := rowtn^.elementType;
		{ size of row }
		rowsize := SizeOf(rowtn);
		{ accumulate offset of base of the array }
		baseOffset := baseOffset + subOffset * rowsize
				- lowerBound * subMultiple * rowsize;
		rowsize := rowsize * subMultiple;
		{ multiply subscript by rowsize }
		multen := NewExprNode(EXPRBINOP);
		SameExprLine(multen,sen);
		multen^.exprBinOp := TKASTERISK;
		multen^.opnd1 := sen;
		multen^.opnd2 := ConstExprNode(CardinalConst(rowsize));
		multen^.opnd2^.exprType := addressTypeNode;
		EvalConstBinOpExpr(multen);
		multen^.exprType := addressTypeNode;
		multen^.operType := addressTypeNode;
		{ add to other subscripts }
		if adden = nil then begin
		    adden := multen;
		end else begin
		    newadden := NewExprNode(EXPRBINOP);
		    SameExprLine(newadden,sen);
		    newadden^.exprBinOp := TKPLUS;
		    newadden^.opnd1 := adden;
		    newadden^.opnd2 := multen;
		    adden := newadden;
		    EvalConstBinOpExpr(adden);
		    adden^.exprType := addressTypeNode;
		    adden^.operType := addressTypeNode;
		end;
	    end;
	    sen := sennext;
	end;
    end;
    if error then begin
	BadExpr(en);
	rowtn := nil;
    end else begin
	sennext := en^.next;
	en^ := adden^;
	en^.next := sennext;
	en^.baseVar := aen^.baseVar;
	en^.basePtrType := aen^.basePtrType;
	if baseOffset <> 0 then begin
	    { add in constant offset }
	    newadden := NewExprNode(EXPRBINOP);
	    newadden^ := en^;
	    en^.exprBinOp := TKPLUS;
	    en^.opnd1 := newadden;
	    en^.opnd2 := ConstExprNode(CardinalConst(baseOffset));
	    en^.opnd2^.exprType := addressTypeNode;
	    en^.baseVar := aen^.baseVar;
	    en^.basePtrType := aen^.basePtrType;
	    EvalConstBinOpExpr(en);
	    en^.exprType := addressTypeNode;
	    en^.operType := addressTypeNode;
	end;
	ValueOrAddr(en,rowtn,mode);
    end;
    SubscriptExpr := rowtn;
end;

function DotExpr{(en : ExprNode) : TypeNode};
var
    rectn, fieldtn : TypeNode;
    sym : Symbol;
    rec, saveNext : ExprNode;
    field : FieldNode;
    offset, multiple : MemoryOffset;
begin
    if TraceNexpr then begin
	writeln(output,'DotExpr');
    end;
    if mode = EVALPUT then begin
	rectn := BaseType(CheckExpr(en^.rec,EVALPUT));
    end else begin
	rectn := BaseType(CheckExpr(en^.rec,EVALPOINT));
    end;
    rec := en^.rec;
    field := nil;
    if IsBadExpr(rec) then begin
	{ do nothing }
    end else if rectn^.kind <> DTRECORD then begin
	ExprError(en,'Dot follows non-record expression');
    end else if en^.field <> nil then begin
	field := en^.field;
    end else begin
	sym := LookUpSymbol(en^.fieldName,rectn^.recScope,ONECASE);
	if sym = nil then begin
	    ExprErrorName(en,en^.fieldName,'Not a field of this record');
	end else begin
	    field := sym^.symField;
	end;
    end;
    if field = nil then begin
	BadExpr(en);
	fieldtn := nil;
    end else begin
	fieldtn := ActualType(field^.fieldType);
	{ combine field offset with any other constants }
	offset := field^.offset;
	multiple := 1;
	FactorInConstants(rec,offset,multiple,false);
	if genCheckFlag and (field^.containingVariant <> nil) then begin
	    if field^.containingVariant^.tagField <> nil then begin
		InsertCheckExpr(rec,CHECKVARIANT,nil,nil,0,0);
		rec^.checkField := field;
	    end;
	end;
	if offset = 0 then begin
	    { no need to do add }
	    saveNext := en^.next;
	    en^ := rec^;
	    en^.next := saveNext;
	end else begin
	    { add in offset }
	    en^.kind := EXPRBINOP;
	    en^.exprBinOp := TKPLUS;
	    en^.opnd1 := rec;
	    en^.opnd2 := ConstExprNode(CardinalConst(offset));
	    en^.opnd2^.exprType := addressTypeNode;
	    en^.baseVar := rec^.baseVar;
	    en^.basePtrType := rec^.basePtrType;
	    en^.exprType := addressTypeNode;
	    en^.operType := addressTypeNode;
	end;
	ValueOrAddr(en,fieldtn,mode);
    end;
    DotExpr := fieldtn;
end;

function DerefExpr{(en : ExprNode) : TypeNode};
var
    tn, ptrtn : TypeNode;
    ptr, saveNext : ExprNode;
begin
    if TraceNexpr then begin
	writeln(output,'DerefExpr');
    end;
    tn := BaseType(CheckExpr(en^.ptr,EVALGET));
    ptr := en^.ptr;
    ptrtn := nil;
    if tn = nil then begin
	{ do nothing }
    end else if tn^.kind = DTPOINTER then begin
	ptrtn := ActualType(tn^.toType);
	if ptrtn = nil then begin
	    ExprError(en,'Dereference of pointer to unknown type');
	end;
    end else begin
	ExprError(en,'Dereference of a non-pointer');
    end;
    if ptrtn = nil then begin
	BadExpr(en);
    end else begin
	{ convert deref expr into check of appropriate kind }
	en^.kind := EXPRCHECK;
	en^.exprCheck := tn^.ptrCheck;
	en^.checkExpr := ptr;
	en^.exprType := ptr^.exprType;
	en^.checkVar := nil;
	en^.checkType := nil;
	en^.checkField := nil;
	en^.checkLower := 0;
	en^.checkUpper := 0;
	ValueOrAddr(en,ptrtn,mode);
	en^.basePtrType := ptrtn;
    end;
    DerefExpr := ptrtn;
end;

procedure ExpandOpenArrayParam(pexp : ExprNode; pexptn, parmtn : TypeNode;
	    var newParams : ExprList; pnum : integer);
var
    numElements, elementSize, arraySize : cardinal;
    newpexp, varexp, valexp, mulexp, addexp, divexp : ExprNode;
    done : boolean;
begin
    done := false;
    arraySize := SizeOf(pexptn);
    pexptn := BaseType(pexptn);
    if parmtn^.nocount then begin
	{ just put address on list }
	RefOpenArray(pexp,pexptn);
	newParams := AddToExprList(newParams,pexp);
	done := true;
    end else if pexptn^.kind = DTSTRING then begin
	if parmtn^.elementType = wordTypeNode then begin
	     { calculate words for array of word }
	     numElements := CardDiv(RoundUp(pexptn^.stringLength*CHARSIZE,
						WORDSIZE),WORDSIZE);
	end else if parmtn^.elementType = byteTypeNode then begin
	     { number of bytes = number of chars }
	     numElements := pexptn^.stringLength;
	end else begin
	     numElements := pexptn^.stringLength;
	end;
	newpexp := ConstExprNode(CardinalConst(numElements));
	newpexp^.exprType := cardIntTypeNode;
	SameExprLine(newpexp,pexp);
	{ put address on list }
	newParams := AddToExprList(newParams,pexp);
	{ put number of elements on list }
	newParams := AddToExprList(newParams,newpexp);
	done := true;
    end else if pexptn^.kind = DTARRAY then begin
	if pexptn^.nocount then begin
	    ExprErrorNumber(pexp,'Cannot pass NOCOUNT array as an open array parameter #',pnum);
	    done := true;
	end else if pexptn^.arrayKind = ARRAYOPEN then begin
	    { it better be a variable }
	    if pexp^.kind <> EXPRVAR then begin
		ExprErrorNumber(pexp,'Open array actual parameter must be variable, parameter #',
				pnum);
	    end else begin
		{ open array parameter, need to get run-time size }
		{ get number of elements in open array }
		    { address of open array descriptor }
		varexp := NewExprNode(EXPRVAR);
		SameExprLine(varexp,pexp);
		varexp^.exprVar := pexp^.exprVar;
		varexp^.exprType := addressTypeNode;
		    { add wordsize to get address of number of elements }
		addexp := NewExprNode(EXPRBINOP);
		SameExprLine(addexp,pexp);
		addexp^.exprBinOp := TKPLUS;
		addexp^.opnd1 := varexp;
		addexp^.opnd2 := ConstExprNode(CardinalConst(WORDSIZE));
		addexp^.opnd2^.exprType := addressTypeNode;
		addexp^.exprType := addressTypeNode;
		addexp^.operType := addressTypeNode;