builtin.p

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

		end else if p2^.exprConst^.kind <> DTSTRING then begin
		    error := ERRTYPE2;
		end else begin
		    { need to update format string }
		    new(cn);
		    cn^.kind := DTSTRING;
		    if not CheckWritef(p2,p2^.exprConst^.strVal,p2^.next,
						cn^.strVal)
		    then begin
			error := ERROTHER;
		    end else begin
			p2^.exprConst := cn;
		    end;
		end;
	    end;
	    retType := nil;
	end;
	BIPREADF : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump < 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := BaseType(CheckExpr(p1,EVALGET));
		pt2 := CheckExpr(p2,EVALPOINT);
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if pt1 <> fileTypeNode then begin
		    error := ERRTYPE1;
		end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVALUE,pt2,p2)
		then begin
		    error := ERRTYPE2;
		end else if p2^.kind <> EXPRCONST then begin
		    error := ERRTYPE2;
		end else if p2^.exprConst^.kind = DTCHAR then begin
		    { one character string is OK }
		end else if p2^.exprConst^.kind <> DTSTRING then begin
		    error := ERRTYPE2;
		end else if p2^.kind <> EXPRCONST then begin
		    error := ERRTYPE2;
		end else begin
		    if not CheckReadf(p2,p2^.exprConst^.strVal,p2^.next)
		    then begin
			error := ERROTHER;
		    end;
		    retType := integerTypeNode;
		end;
	    end;
	end;
	BIPWRITES : begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump < 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALPUT);
		pt2 := CheckExpr(p2,EVALPOINT);
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVAR,pt1,p1)
		then begin
		    error := ERRTYPE1;
		end else if p2^.kind <> EXPRCONST then begin
		    error := ERRTYPE2;
		end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVALUE,pt2,p2)
		then begin
		    error := ERRTYPE2;
		end else if p2^.exprConst^.kind = DTCHAR then begin
		    { one character string is OK }
		end else if p2^.exprConst^.kind <> DTSTRING then begin
		    error := ERRTYPE2;
		end else begin
		    RefOpenArray(p1,pt1);
		    { need to update format string }
		    new(cn);
		    cn^.kind := DTSTRING;
		    if not CheckWritef(p2,p2^.exprConst^.strVal,p2^.next,
						cn^.strVal)
		    then begin
			error := ERROTHER;
		    end else begin
			p2^.exprConst := cn;
		    end;
		end;
	    end;
	    retType := nil;
	end;
	BIPREADS : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump < 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALPOINT);
		pt2 := CheckExpr(p2,EVALPOINT);
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVALUE,pt1,p1)
		then begin
		    error := ERRTYPE1;
		end else if p2^.kind <> EXPRCONST then begin
		    error := ERRTYPE2;
		end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVALUE,pt2,p2)
		then begin
		    error := ERRTYPE2;
		end else if p2^.exprConst^.kind = DTCHAR then begin
		    { one character string is OK }
		end else if p2^.exprConst^.kind <> DTSTRING then begin
		    error := ERRTYPE2;
		end else begin
		    RefOpenArray(p1,pt1);
		    if not CheckReadf(p2,p2^.exprConst^.strVal,p2^.next)
		    then begin
			error := ERROTHER;
		    end;
		    retType := integerTypeNode;
		end;
	    end;
	end;
	BIPWRITEC : begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump <> 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALGET);
		pt2 := BaseType(CheckExpr(p2,EVALGET));
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if pt1 <> fileTypeNode then begin
		    error := ERRTYPE1;
		end else if pt2^.kind <> DTCHAR then begin
		    error := ERRTYPE2;
		end else begin
		    retType := nil;
		end;
	    end;
	end;
	BIPREADC : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALGET);
		pt2 := BaseType(CheckExpr(p2,EVALPUT));
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if pt1 <> fileTypeNode then begin
		    error := ERRTYPE1;
		end else if pt2^.kind <> DTCHAR then begin
		    error := ERRTYPE2;
		end else if not IsAddressableExpr(p2) then begin
		    error := ERRMETHOD2;
		end else begin
		    retType := integerTypeNode;
		end;
	    end;
	end;
	BIPWRITEB : begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump <> 3 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALGET);
		pt2 := BaseType(CheckExpr(p2,EVALPOINT));
		p3 := p2^.next;
		pt3 := BaseType(CheckExpr(p3,EVALGET));
		if IsBadExpr(p1) or IsBadExpr(p2) or IsBadExpr(p3) then begin
		    error := ERROTHER;
		end else if pt1 <> fileTypeNode then begin
		    error := ERRTYPE1;
		end else if not (pt3^.kind in [DTINTEGER,DTCARDINAL]) then begin
		    error := ERRTYPE3;
		end else begin
		    PointerOrAddress(p2,pt2);
		    retType := nil;
		end;
	    end;
	end;
	BIPREADB : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 3 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALGET);
		pt2 := BaseType(CheckExpr(p2,EVALPUT));
		p3 := p2^.next;
		pt3 := BaseType(CheckExpr(p3,EVALGET));
		if IsBadExpr(p1) or IsBadExpr(p2) or IsBadExpr(p3) then begin
		    error := ERROTHER;
		end else if pt1 <> fileTypeNode then begin
		    error := ERRTYPE1;
		end else if not (pt3^.kind in [DTINTEGER,DTCARDINAL]) then begin
		    error := ERRTYPE3;
		end else begin
		    PointerOrAddress(p2,pt2);
		    retType := integerTypeNode;
		end;
	    end;
	end;
	BIPOPENF : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALPOINT);
		pt2 := CheckExpr(p2,EVALPOINT);
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVALUE,pt1,p1)
		then begin
		    error := ERRTYPE1;
		end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVALUE,pt2,p2)
		then begin
		    error := ERRTYPE2;
		end else begin
		    RefOpenArray(p1,pt1);
		    RefOpenArray(p2,pt2);
		end;
		retType := fileTypeNode;
	    end;
	end;
	BIPCLOSEF : begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump <> 1 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALGET);
		if IsBadExpr(p1) then begin
		    error := ERROTHER;
		end else if not Passable(fileTypeNode,PARAMVALUE,pt1,p1)
		then begin
		    error := ERRTYPE1;
		end;
	    end;
	    retType := nil;
	end;
	BIPNEWPROCESS: begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump <> 4 then begin
		error := ERRNUMP;
	    end else begin
		p3 := p2^.next;
		p4 := p3^.next;
		pt1 := BaseType(CheckExpr(p1,EVALGET));
		pt2 := BaseType(CheckExpr(p2,EVALGET));
		pt3 := BaseType(CheckExpr(p3,EVALGET));
		pt4 := CheckExpr(p4,EVALPUT);
		if IsBadExpr(p1) or IsBadExpr(p2) or IsBadExpr(p3) or
			IsBadExpr(p4)
		then begin
		    error := ERROTHER;
		end else if pt1^.kind <> DTPROC then begin
		    error := ERRTYPE1;
		end else if not Passable(addressTypeNode,PARAMVALUE,pt2,p2)
		then begin
		    error := ERRTYPE2;
		end else if not Passable(cardinalTypeNode,PARAMVALUE,pt3,p3)
		then begin
		    error := ERRTYPE3;
		end else if not Passable(processTypeNode,PARAMVAR,pt4,p4)
		then begin
		    error := ERRTYPE4;
		end else if not IsAddressableExpr(p4) then begin
		    error := ERRMETHOD4;
		end else begin
		    retType := processTypeNode;
		end;
	    end;
	end;
	BIPTRANSFER: begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump <> 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALPUT);
		pt2 := CheckExpr(p2,EVALPUT);
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if not Passable(processTypeNode,PARAMVAR,pt1,p1)
		then begin
		    error := ERRTYPE1;
		end else if not Passable(processTypeNode,PARAMVAR,pt2,p2)
		then begin
		    error := ERRTYPE2;
		end else if not IsAddressableExpr(p1) then begin
		    error := ERRMETHOD1;
		end else if not IsAddressableExpr(p2) then begin
		    error := ERRMETHOD2;
		end else begin
		    retType := nil;
		end;
	    end;
	end;
	BIPBITAND, BIPBITOR, BIPBITXOR, BIPBITSHIFTLEFT,
	BIPBITSHIFTRIGHT : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := BaseType(CheckExpr(p1,EVALGET));
		pt2 := BaseType(CheckExpr(p2,EVALGET));
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if not (pt1^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE1;
		end else if not (pt2^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE2;
		end else begin
		    retType := cardIntTypeNode;
		end;
	    end;
	end;
	BIPBITNOT : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 1 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := BaseType(CheckExpr(p1,EVALGET));
		if IsBadExpr(p1) then begin
		    error := ERROTHER;
		end else if not (pt1^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE1;
		end else begin
		    retType := cardIntTypeNode;
		end;
	    end;
	end;
	BIPBITEXTRACT : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 3 then begin
		error := ERRNUMP;
	    end else begin
		p3 := p2^.next;
		pt1 := BaseType(CheckExpr(p1,EVALGET));
		pt2 := BaseType(CheckExpr(p2,EVALGET));
		pt3 := BaseType(CheckExpr(p3,EVALGET));
		if IsBadExpr(p1) or IsBadExpr(p2) or IsBadExpr(p3) then begin
		    error := ERROTHER;
		end else if not (pt1^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE1;
		end else if not (pt2^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE2;
		end else if not (pt3^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE3;
		end else begin
		    retType := cardIntTypeNode;
		end;
	    end;
	end;
	BIPBITINSERT : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 4 then begin
		error := ERRNUMP;
	    end else begin
		p3 := p2^.next;
		p4 := p3^.next;
		pt1 := BaseType(CheckExpr(p1,EVALGET));
		pt2 := BaseType(CheckExpr(p2,EVALGET));
		pt3 := BaseType(CheckExpr(p3,EVALGET));
		pt4 := BaseType(CheckExpr(p4,EVALGET));
		if IsBadExpr(p1) or IsBadExpr(p2) or IsBadExpr(p3)
			or IsBadExpr(p4)
		then begin
		    error := ERROTHER;
		end else if not (pt1^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE1;
		end else if not (pt2^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE2;
		end else if not (pt3^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE3;
		end else if not (pt4^.kind in [DTCARDINAL, DTINTEGER]) then begin
		    error := ERRTYPE4;
		end else begin
		    retType := cardIntTypeNode;
		end;
	    end;
	end;
    end;
    case error of
	ERRNONE : ;
	ERROTHER : ;
	ERRPROC : ErrorName(proc^.name,'Function used as a procedure');
	ERRFUNC : ErrorName(proc^.name,'Procedure used as a function');
	ERRNUMP : ErrorName(proc^.name,'Incorrect number of parameters');
	ERRTYPE1 : ErrorName(proc^.name,'Wrong type for parameter #1');
	ERRTYPE2 : ErrorName(proc^.name,'Wrong type for parameter #2');
	ERRTYPE3 : ErrorName(proc^.name,'Wrong type for parameter #3');
	ERRTYPE4 : ErrorName(proc^.name,'Wrong type for parameter #4');
	ERRMETHOD1 : ErrorName(proc^.name,
		    'Variable required for VAR parameter #1');
	ERRMETHOD2 : ErrorName(proc^.name,
		    'Variable required for VAR parameter #2');
	ERRMETHOD4 : ErrorName(proc^.name,
		    'Variable required for VAR parameter #4');
    end;
    CheckBuiltin := error = ERRNONE;
end;


function OptBuiltin{(procExpr : ExprNode; proc : ProcNode; params : ExprList):OptTime};
var
    p, p1, p2, p3, p4 : ExprNode;
    nump : integer;
    time, timep : OptTime;

    procedure OptRestOfParams(mode : EvalMode);
    var
	p : ExprNode;
    begin
	if p2 <> nil then begin
	    p := p2^.next;
	    while p <> nil do begin
		timep := OptExpr(p,procExpr,mode);
		time := Latest(time,timep);
		if mode = EVALPUT then begin
		    MarkOptExpr(p);
		end;
		p := p^.next;
	    end;
	end;
    end;

begin
    nump := 0;
    p1 := nil;
    p2 := nil;
    if params = nil then begin
	{ do nothing }
    end else if params^.first = nil then begin
	{ do nothing }
    end else begin
	p1 := params^.first;
	if p1^.next = nil then begin
	    nump := 1;
	end else begin
	    p2 := p1^.next;
	    if p2^.next = nil then begin
		nump := 2;
	    end else begin
		p := params^.first;
		nump := 0;
		while p <> nil do begin
		    nump := nump + 1;
		    p := p^.next;
		end;
	    end;
	end;
    end;
    case proc^.builtin of
	BIPHALT, BIPCPUTIME, BIPSIZE, BIPTSIZE, BIPBYTESIZE, BIPTBYTESIZE,
	BIPFIRST, BIPLAST : begin { either constants or no parameters }
	    time := 0;
	end;
	BIPABS, BIPCAP, BIPCHR, BIPFLOAT, BIPLONGFLOAT, BIPHIGH, BIPNUMBER,
	BIPODD, BIPORD, BIPTRUNC, BIPBITNOT : begin { all one value parameter }
	    time := OptExpr(p1,procExpr,EVALGET);
	end;
	BIPASSERT, BIPMAX, BIPMIN, BIPBITAND, BIPBITOR, BIPBITXOR,
	BIPBITSHIFTLEFT, BIPBITSHIFTRIGHT : begin { all two val