cexpr.p

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

		    { get number of elements }
		valexp := NewExprNode(EXPRVAL);
		SameExprLine(valexp,pexp);
		valexp^.exprVal := addexp;
		valexp^.exprType := cardinalTypeNode;

		elementSize := SizeOf(pexptn^.elementType);
		if (pexptn^.elementType = wordTypeNode) and
		    (elementSize <> WORDSIZE)
		then begin
		    { need to scale size to words }
			{ multiply number of elements times size }
		    mulexp := NewExprNode(EXPRBINOP);
		    SameExprLine(mulexp,pexp);
		    mulexp^.exprBinOp := TKASTERISK;
		    mulexp^.opnd1 := valexp;
		    mulexp^.opnd2 := ConstExprNode(CardinalConst(elementSize));
		    mulexp^.opnd2^.exprType := addressTypeNode;
		    mulexp^.exprType := addressTypeNode;
		    mulexp^.operType := addressTypeNode;
			{ add wordsize - 1 }
		    addexp := NewExprNode(EXPRBINOP);
		    SameExprLine(addexp,pexp);
		    addexp^.exprBinOp := TKPLUS;
		    addexp^.opnd1 := mulexp;
		    addexp^.opnd2 := ConstExprNode(CardinalConst(WORDSIZE-1));
		    addexp^.opnd2^.exprType := addressTypeNode;
		    addexp^.exprType := addressTypeNode;
		    addexp^.operType := addressTypeNode;
			{ divide by wordsize }
		    divexp := NewExprNode(EXPRBINOP);
		    SameExprLine(divexp,pexp);
		    divexp^.exprBinOp := TKDIV;
		    divexp^.opnd1 := valexp;
		    divexp^.opnd2 := ConstExprNode(CardinalConst(WORDSIZE));
		    divexp^.opnd2^.exprType := addressTypeNode;
		    divexp^.exprType := cardinalTypeNode;
		    divexp^.operType := cardinalTypeNode;

		    newpexp := divexp;
		end else if (pexptn^.elementType = byteTypeNode) and
		    (elementSize <> BYTESIZE)
		then begin
		    { need to scale size to bytes }
		    { simpler than words, since always a multiple of bytes }
			{ multiply number of elements times size in bytes }
		    mulexp := NewExprNode(EXPRBINOP);
		    SameExprLine(mulexp,pexp);
		    mulexp^.exprBinOp := TKASTERISK;
		    mulexp^.opnd1 := valexp;
		    mulexp^.opnd2 := ConstExprNode(CardinalConst(
					CardDiv(elementSize,BYTESIZE)));
		    mulexp^.opnd2^.exprType := addressTypeNode;
		    mulexp^.exprType := addressTypeNode;
		    mulexp^.operType := addressTypeNode;

		    newpexp := mulexp;
		end else begin
		    { number of elements is right }
		    newpexp := valexp;
		end;
	    end;
	    RefOpenArray(pexp,pexptn);
	    { put address on list }
	    newParams := AddToExprList(newParams,pexp);
	    { put number of elements on list }
	    newParams := AddToExprList(newParams,newpexp);
	    done := true;
	end;
    end;
    if not done then begin
	{ fixed size variable is being passed }
	if parmtn^.elementType = wordTypeNode then begin
	    { calculate words for array of word }
	    numElements := CardDiv(RoundUp(arraySize,WORDSIZE),WORDSIZE);
	end else if parmtn^.elementType = byteTypeNode then begin
	    { calculate bytes for array of byte }
	    numElements := CardDiv(RoundUp(arraySize,BYTESIZE),BYTESIZE);
	end else if pexptn^.kind = DTARRAY then begin
	    numElements := NumberOf(pexptn^.indexType);
	end else begin
	    numElements := 0;
	    ExprErrorNumber(pexp,'Open array parameter must be an array, parameter #',
				pnum);
	end;
	newpexp := ConstExprNode(CardinalConst(numElements));
	newpexp^.exprType := cardinalTypeNode;
	SameExprLine(newpexp,pexp);
	{ put address on list }
	newParams := AddToExprList(newParams,pexp);
	{ put number of elements on list }
	newParams := AddToExprList(newParams,newpexp);
    end;
end;

function CheckFuncProc{(isFunc : boolean; en, procExpr : ExprNode;
    var params : ExprList; var retType : TypeNode) : boolean};
var
    parm : ParamNode;
    pexp, pexpnext : ExprNode;
    pnum : integer;
    tn : TypeNode;
    checked, error : boolean;
    proc : ProcNode;
    procType, pexptn, parmtn : TypeNode;
    newParams : ExprList;
    errorName : String;
    mode : EvalMode;
begin

    checked := false;
    error := true;
    procType := procExpr^.exprType;
    errorName := nil;
    if procExpr^.kind = EXPRSYM then begin
	errorName := procExpr^.exprSym^.name;
    end else if procExpr^.kind = EXPRCONST then begin
	if procExpr^.exprConst^.kind = DTPROC then begin
	    errorName := procExpr^.exprConst^.procVal^.name;
	end;
    end;
    
    { beware: type names can be used as both types and funcs }
    if procExpr^.kind = EXPRSYM then begin
	if procExpr^.exprSym^.kind = SYMTYPE then begin
	    retType := procExpr^.exprSym^.symType;
	    error := true;
	    if params^.first = nil then begin
		ExprErrorName(procExpr,errorName,
			'Type transfer function requires a parameter');
	    end else if params^.first^.next <> nil then begin
		ExprErrorName(procExpr,errorName,
			'Type transfer function must have only one parameter');
	    end else begin
		pexptn := CheckExpr(params^.first,EVALGET);
		if pexptn = nil then begin
		    { found an error }
		end else if WordSizeOf(pexptn) <> WordSizeOf(retType) then begin
		    ExprErrorName(procExpr,errorName,
			    'Type transfer function cannot change size');
		end else begin
		    error := false;
		end;
	    end;
	    checked := true;
	end;
    end;

    { check for builtin function (must be a constant) }
    if checked then begin
	{ do nothing }
    end else if procExpr^.kind = EXPRCONST then begin
	if procExpr^.exprConst^.kind = DTPROC then begin
	    proc := procExpr^.exprConst^.procVal;
	    if proc^.builtin <> BIPNOTBIP then begin
		{ pass proc constant by var in case CheckBuiltin updates it }
		error := not CheckBuiltin(isFunc,en,
		    procExpr^.exprConst^.procVal,params,retType);
		checked := true;
	    end;
	end;
    end;

    if checked then begin
	 { do nothing }
    end else if procType^.kind <> DTPROC then begin
	ExprErrorName(procExpr,errorName,
		'Non-procedure used as a procedure/function');
    end else begin
	if isFunc and (procType^.funcType = nil) then begin
	    ExprErrorName(procExpr,errorName,'Procedure used as a function');
	end else if not isFunc and (procType^.funcType <> nil) then begin
	    ExprErrorName(procExpr,errorName,'Function used as a procedure');
	end else begin
	    error := false;
	    if (params = nil) or (procType^.paramList = nil) then begin
		{ make sure they match }
		if params <> nil then begin
		    if params^.first <> nil then begin
			ExprErrorName(procExpr,errorName,
			    'Too many parameters on procedure/function');
			error := true;
		    end;
		end;
		if procType^.paramList <> nil then begin
		    if procType^.paramList^.first <> nil then begin
			ExprErrorName(procExpr,errorName,
			    'Not enough parameters on procedure/function');
			error := true;
		    end;
		end;
	    end else begin
		pnum := 0;
		pexp := params^.first;
		parm := procType^.paramList^.first;
		newParams := AddToExprList(nil,nil);
		while (pexp <> nil) and (parm <> nil) do begin
		    pnum := pnum + 1;
		    pexpnext := pexp^.next;
		    parmtn := BaseType(parm^.paramType);
		    { decide how parameter will be evaluated }
		    if parm^.kind in [PARAMVAR,PARAMARRAYVAR] then begin
			mode := EVALPUT;
		    end else if parm^.reference then begin
			mode := EVALPOINT;
		    end else begin
			mode := EVALGET;
		    end;
		    pexptn := CheckExpr(pexp,mode);
		    if IsBadExpr(pexp) then begin
			error := true;
		    end else begin
			if not Passable(parm^.paramType,parm^.kind,pexptn,pexp)
			then begin
			    ExprErrorNameNumber(pexp,errorName,
				    'Wrong type, parameter #',pnum);
			    error := true;
			end else if (parm^.kind in [PARAMVAR,PARAMARRAYVAR])
			    and not IsAddressableExpr(pexp)
			then begin
			    ExprErrorNameNumber(pexp,errorName,
				'VAR parameter not variable, parameter #',pnum);
			    error := true;
			end else if parm^.kind in [PARAMARRAYVALUE,
					PARAMARRAYVAR]
			then begin
			    { change open array parameter into two parameters }
			    ExpandOpenArrayParam(pexp,pexptn,parmtn,newParams,
					pnum);
			end else begin
			    if (parm^.kind = PARAMVALUE) and
				    (parm^.paramType^.kind = DTSUBRANGE)
			    then begin
				InsertCheckExpr(pexp,CHECKRANGE,nil,
				    pexptn,
				    LowerBoundOf(parm^.paramType),
				    UpperBoundOf(parm^.paramType));
			    end;
			    newParams := AddToExprList(newParams,pexp);
			end;
		    end;
		    pexp := pexpnext;
		    parm := parm^.next;
		end;
		params := newParams;
		if parm <> nil then begin
		    ExprErrorName(procExpr,errorName,
			'Not enough parameters on procedure/function');
		    error := true;
		end;
		if pexp <> nil then begin
		    ExprErrorName(procExpr,errorName,
			'Too many parameters on procedure/function');
		    error := true;
		end;
	    end;
	end;
	if not error then begin
	    retType := procType^.funcType;
	end;
    end;
    CheckFuncProc := not error;
end;

function FuncExpr(en : ExprNode; mode : EvalMode) : TypeNode;
var
    exprType, funcType : TypeNode;
    func : ExprNode;
begin
    if TraceNexpr then begin
	writeln(output,'FuncExpr');
    end;

    funcType := CheckExprFunc(en^.func,EVALPOINT);
    func := en^.func;
    if IsBadExpr(func) then begin
	BadExpr(en);
    end else begin
	if not (en^.func^.kind in [EXPRCONST,EXPRSYM]) then begin
	    { Get procedure address from variable }
	    ValueOrAddr(en^.func,funcType,EVALGET);
	end;
	if not CheckFuncProc(true,en,func,en^.params,exprType) then begin
	    BadExpr(en);
	end else begin
	    en^.exprType := ActualType(exprType);
	end;
    end;
    FuncExpr := en^.exprType;
end;

function SetExpr(en : ExprNode; mode : EvalMode) : TypeNode;
var
    csl : ConstSetList;
    tn : TypeNode;
    sym : Symbol;
begin
    if en^.setTypeName = nil then begin
	tn := bitsetTypeNode;
    end else begin
	sym := QualifiedName(en^.setTypeName);
	tn := nil;
	if sym = nil then begin
	    { do nothing }
	end else if en^.setTypeName^.first <> nil then begin
	    { more qualifiers remain }
	    ExprErrorName(en,sym^.name,'Invalid set type on set expression');
	end else if sym^.kind <> SYMTYPE then begin
	    ExprErrorName(en,sym^.name,'Symbol on set constant not a set type');
	end else if sym^.symType^.kind <> DTSET then begin
	    ExprErrorName(en,sym^.name,'Symbol on set constant not a set type');
	end else begin
	    tn := ActualType(sym^.symType);
	end;
    end;
    if tn = nil then begin
	BadExpr(en);
    end else begin
	csl := ExprSetToConstSet(en^.setValue);
	en^.kind := EXPRCONST;
	en^.exprConst := SetConst(csl,tn);
	en^.constType := tn;
	en^.exprType := tn;
    end;
    SetExpr := tn;
end;

function DoCheckExpr(en : ExprNode; mode : EvalMode) : TypeNode;
var
    tn : TypeNode;
begin
    tn := nil;
    if en = nil then begin
	ExprError(en,'CheckExpr: nil expression?');
    end else if en^.exprType <> nil then begin
	    { already checked }
	tn := en^.exprType;
	ExprError(en,'CheckExpr: already checked?');
    end else begin
	currLine := en^.lineNumber;
	currFile := en^.fileName;
	case en^.kind of
	    EXPRBAD :	ExprError(en,'CheckExpr: found EXPRBAD?');
	    EXPRNAME :	tn := NameExpr(en,mode);
	    EXPRSYM :	tn := SymExpr(en,mode);
	    EXPRVAR :	tn := VarExpr(en,mode);
	    EXPRCONST :	tn := ConstExpr(en,mode);
	    EXPRUNOP :	tn := UnOpExpr(en,mode);
	    EXPRBINOP :	tn := BinOpExpr(en,mode);
	    EXPRSUBSCR :tn := SubscriptExpr(en,mode);
	    EXPRDOT :	tn := DotExpr(en,mode);
	    EXPRDEREF :	tn := DerefExpr(en,mode);
	    EXPRFUNC :	tn := FuncExpr(en,mode);
	    EXPRSET :	tn := SetExpr(en,mode);
	end;
    end;
    DoCheckExpr := tn;
end;

function CheckExpr{(en : ExprNode; mode : EvalMode) : TypeNode};
var
    tn : TypeNode;
begin
    tn := DoCheckExpr(en,mode);
    if IsBadExpr(en) then begin
    end else if not (en^.kind in [EXPRVAL, EXPRVAR, EXPRBINOP, EXPRCHECK,
		EXPRUNOP, EXPRCONST, EXPRFUNC])
    then begin
	ExprError(en,'Expression is not a value or variable');
	BadExpr(en);
    end;
    CheckExpr := tn;
end;

function CheckExprFunc{(en : ExprNode; mode : EvalMode) : TypeNode};
var
    tn : TypeNode;
begin
    tn := DoCheckExpr(en,mode);
    if IsBadExpr(en) then begin
    end else if en^.kind <> EXPRSYM then begin
	{ any normal expression that is a procedure value is OK }
	if tn^.kind <> DTPROC then begin
	    ExprError(en,'Procedure/function name is not a procedure, function, or type');
	    BadExpr(en);
	end;
    end else if en^.exprSym^.kind <> SYMTYPE then begin
	ExprError(en,'Procedure/function name is not a procedure, function, or type');
	BadExpr(en);

    end;
    CheckExprFunc := tn;
end;

function CheckExprType{(en : ExprNode; mode : EvalMode) : TypeNode};
var
    tn : TypeNode;
begin
    tn := DoCheckExpr(en,mode);
    if IsBadExpr(en) then begin
    end else if en^.kind <> EXPRSYM then begin
	ExprError(en,'Expression found where type name expected');
	BadExpr(en);
    end else if en^.exprSym^.kind <> SYMTYPE then begin
	ExprError(en,'Type not found where type name expected');
	BadExpr(en);
    end;
    CheckExprType := tn;
end;

function Eval{(en : ExprNode) : ConstNode};
var
    cn : ConstNode;
begin
    if en = nil then begin
	ExprError(en,'Eval: nil expression?');
    end else if en^.kind in [EXPRUNOP,EXPRBINOP,EXPRCONST] then begin
	case en^.kind of
	    EXPRCONST :	cn := en^.exprConst;
	    EXPRUNOP :	cn := UnOpConst(en^.exprUnOp,Eval(en^.opnd));
	    EXPRBINOP :	cn := BinOpConst(en^.exprBinOp,Eval(en^.opnd1),
						Eval(en^.opnd2),true);
	end;
    end else begin
	ExprError(en,'Invalid constant expression');
	new(cn);
	cn^.kind := DTCARDINAL;
	cn^.cardVal := 1;
    end;
    Eval := cn;
end;

function ExprSetToConstSet{(esl : ExprSetList) : ConstSetList};
var
    esn : ExprSetNode;
    csl : ConstSetList;
    csn : ConstSetNode;
    tn : TypeNode;
begin
    if esl = nil then begin
	csl := nil;
    end else begin
	csl := nil;
	esn := esl^.first;
	while esn <> nil do begin
	    new(csn);
	    tn := CheckExpr(esn^.lower,EVALGET);
	    if IsBadExpr(esn^.lower) then begin
		csn^.lower := CardinalConst(0);
	    end else begin
		csn^.lower := Eval(esn^.lower);
	    end;
	    if esn^.lower = esn^.upper then begin
		csn^.upper := csn^.lower;
	    end else begin
		tn := CheckExpr(esn^.upper,EVALGET);
		if IsBadExpr(esn^.upper) then begin
		    csn^.upper := CardinalConst(0);
		end else begin
		    csn^.upper := Eval(esn^.upper);
		end;
	    end;
	    csl := AddToConstSetList(csl,csn);
	    esn := esn^.next;
	end;
    end;
    ExprSetToConstSet := csl;
end;