builtin.p

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

		end;
	    end else begin
		while currChar in ['0'..'9'] do begin
		    Advance;
		end;
	    end;
	    if lasttime and (currChar = '.') then begin
		Advance;
		lasttime := false;
	    end else begin
		lasttime := true;
	    end;
	until lasttime;
    end;
begin
    ok := true;
    pen := pl;
    currPos := 0;
    formatSize := format^.length;
    while ok and (currPos < formatSize) do begin
	Advance;
	if currChar <> FMTCHAR then begin
	    { do nothing }
	end else begin
	    Advance;
	    if currChar = FMTCHAR then begin
		{ do nothing }
	    end else begin
		CheckWidth;
		if not ok then begin
		    { do nothing }
		end else if pen = nil then begin
		    FmtErr(en,'No parameter for format');
		end else begin
		    long := false;
		    if currChar = 'l' then begin
			Advance;
			long := true;
		    end;
		    if currChar in ['d','o','x','u'] then begin
			{ need an integer or cardinal }
			pentn := CheckExpr(pen,EVALGET);
			if IsBadExpr(pen) then begin
			    ok := false;
			end else if not Passable(integerTypeNode,PARAMVALUE,pentn,pen)
			then begin
			    FmtErr(en,'Format requires integer or cardinal');
			end;
			pen := pen^.next;
		    end else if (not long) and (currChar in ['f','e','g'])
		    then begin
			{ need a real }
			pentn := CheckExpr(pen,EVALGET);
			if IsBadExpr(pen) then begin
			    ok := false;
			end else if not Passable(realTypeNode,PARAMVALUE,pentn,pen)
			then begin
			    FmtErr(en,'Format requires real');
			end;
			pen := pen^.next;
		    end else if (currChar in ['F','E','G']) or
				(long and (currChar in ['f','e','g']))
		    then begin
			if currChar in ['F','E','G'] then begin
			    currCharacter := ord(currChar)-ord('A')+ord('a');
			end;
			{ need a real }
			pentn := CheckExpr(pen,EVALGET);
			if IsBadExpr(pen) then begin
			    ok := false;
			end else if not Passable(longrealTypeNode,PARAMVALUE,pentn,pen)
			then begin
			    FmtErr(en,'Format requires longreal');
			end;
			pen := pen^.next;
		    end else if currChar = 'c' then begin
			{ need a char }
			pentn := CheckExpr(pen,EVALGET);
			if IsBadExpr(pen) then begin
			    ok := false;
			end else if not Passable(charTypeNode,PARAMVALUE,pentn,pen)
			then begin
			    FmtErr(en,'Format requires char');
			end;
			pen := pen^.next;
		    end else if currChar = 's' then begin
			{ need a string }
			pentn := CheckExpr(pen,EVALPOINT);
			if IsBadExpr(pen) then begin
			    ok := false;
			end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVALUE,pentn,pen)
			then begin
			    FmtErr(en,'Format requires string');
			end else begin
			    RefOpenArray(pen,pentn);
			end;
			pen := pen^.next;
		    end else begin
			FmtErr(en,'Invalid format character');
		    end;
		end;
	    end;
	end;
    end;
    if ok and (pen <> nil) then begin
	ok := false;
	ExprError(en,'Too many parameters for format string');
    end;
    AddChar(currChar);
    newFormat := NewString;
    CheckWritef := ok;
end;

function CheckReadf(en : ExprNode; format : String; pl : ExprNode) : boolean;
const
    FMTCHAR = '%';
    SUPPRESSCHAR = '*';
    LBRACK = '[';
    RBRACK = ']';
var
    ok, suppress, long : boolean;
    pen : ExprNode;
    pentn : TypeNode;
    currPos, formatSize : integer;
    currChar : char;
    currCharacter : character;

    procedure FmtErr(en : ExprNode; msg : ErrorString);
    var
	i, j : integer;
	tmp : ErrorString;
    begin
	tmp := ', character #'; { 13 chars, see below }
	i := ERRORSTRINGSIZE;
	while (i > 1) and (msg[i] = ' ') do begin
	    i := i - 1;
	end;
	for j := 1 to 13 do begin
	    msg[i+j] := tmp[j];
	end;
	ExprErrorNumber(en,msg,currPos);
	ok := false;
    end;

    procedure Advance;
    begin
	if currPos >= formatSize then begin
	    if currChar <> chr(0) then begin
		FmtErr(en,'Premature end of format');
	    end;
	    currChar := chr(0);
	end else begin
	    currCharacter := GetCharX(format,currPos);
	    if currCharacter in [MINCHAR..MAXCHAR] then begin
		currChar := chr(currCharacter);
	    end else begin
		currChar := '?';
	    end;
	    currPos := currPos + 1;
	end;
    end;


    procedure CheckWidth;
    begin
	while currChar in ['0'..'9'] do begin
	    Advance;
	end;
    end;

    procedure CheckVarParam(en : ExprNode);
    begin
	if not IsAddressableExpr(en) then begin
	    FmtErr(en,'Format requires var parameter');
	end;
    end;
begin
    ok := true;
    pen := pl;
    formatSize := format^.length;
    currPos := 0;
    while ok and (currPos < formatSize) do begin
	Advance;
	if currChar <> FMTCHAR then begin
	    { do nothing }
	end else begin
	    Advance;
	    if currChar = FMTCHAR then begin
		{ do nothing }
	    end else begin
		if currChar = SUPPRESSCHAR then begin
		    suppress := true;
		    Advance;
		end else begin
		    suppress := false;
		end;
		CheckWidth;
		if not ok then begin
		    { do nothing }
		end else if not suppress and (pen = nil) then begin
		    FmtErr(en,'No parameter for format');
		end else begin
		    long := false;
		    if currChar = 'l' then begin
			Advance;
			long := true;
		    end;
		    if currChar in ['d','o','x','u'] then begin
			if not suppress then begin
			    { need an integer or cardinal }
			    pentn := CheckExpr(pen,EVALPUT);
			    if IsBadExpr(pen) then begin
				ok := false;
			    end else if Assignable(integerTypeNode,pentn,pen) = nil
			    then begin
				FmtErr(en,'Format requires integer or cardinal');
			    end;
			    CheckVarParam(pen);
			    pen := pen^.next;
			end;
		    end else if (not long) and (currChar in ['f','e'])
		    then begin
			if not suppress then begin
			    { need a real }
			    pentn := CheckExpr(pen,EVALPUT);
			    if IsBadExpr(pen) then begin
				ok := false;
			    end else if not Passable(realTypeNode,PARAMVAR,pentn,pen)
			    then begin
				FmtErr(en,'Format requires real');
			    end;
			    CheckVarParam(pen);
			    pen := pen^.next;
			end;
		    end else if (currChar in ['F','E']) or
				(long and (currChar in ['f','e']))
		    then begin
			if not suppress then begin
			    { need a longreal }
			    pentn := CheckExpr(pen,EVALPUT);
			    if IsBadExpr(pen) then begin
				ok := false;
			    end else if not Passable(longrealTypeNode,PARAMVAR,pentn,pen)
			    then begin
				FmtErr(en,'Format requires longreal');
			    end;
			    CheckVarParam(pen);
			    pen := pen^.next;
			end;
		    end else if currChar = 'c' then begin
			if not suppress then begin
			    { need a char }
			    pentn := CheckExpr(pen,EVALPUT);
			    if IsBadExpr(pen) then begin
				ok := false;
			    end else if not Passable(charTypeNode,PARAMVAR,pentn,pen)
			    then begin
				FmtErr(en,'Format requires char');
			    end;
			    CheckVarParam(pen);
			    pen := pen^.next;
			end;
		    end else if currChar = 's' then begin
			if not suppress then begin
			    { need a string }
			    pentn := CheckExpr(pen,EVALPUT);
			    if IsBadExpr(pen) then begin
				ok := false;
			    end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVAR,pentn,pen)
			    then begin
				FmtErr(en,'Format requires string');
			    end else begin
				RefOpenArray(pen,pentn);
				CheckVarParam(pen);
			    end;
			    pen := pen^.next;
			end;
		    end else if currChar = LBRACK then begin
			while (currChar <> chr(0)) and (currChar <> RBRACK) do begin
			    Advance;
			end;
			if currChar <> RBRACK then begin
			    FmtErr(en,'Missing ]');
			end;
			if not suppress then begin
			    { need a string }
			    pentn := CheckExpr(pen,EVALPUT);
			    if IsBadExpr(pen) then begin
				ok := false;
			    end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVAR,pentn,pen)
			    then begin
				FmtErr(en,'Format requires string');
			    end else begin
				RefOpenArray(pen,pentn);
				CheckVarParam(pen);
			    end;
			    pen := pen^.next;
			end;
		    end else begin
			FmtErr(en,'Invalid format character');
		    end;
		end;
	    end;
	end;
    end;
    if ok and (pen <> nil) then begin
	ok := false;
	ExprError(en,'Too many parameters for format string');
    end;
    CheckReadf := ok;
end;

procedure PointerOrAddress(en : ExprNode; tn : TypeNode);
begin
    if tn^.kind = DTPOINTER then begin
	ValueOrAddr(en,addressTypeNode,EVALGET);
    end else begin
	RefOpenArray(en,tn);
    end;
end;

function CheckBuiltin{(isFunc : boolean; procExpr : ExprNode;
	var proc : ProcNode; params : ExprList; var retType : TypeNode)
	: boolean};
type
    ErrorKind = (ERRNONE, ERROTHER, ERRPROC, ERRFUNC, ERRNUMP, ERRTYPE1,
	ERRTYPE2, ERRTYPE3, ERRTYPE4, ERRMETHOD1, ERRMETHOD2, ERRMETHOD4);
var
    p, p1, p2, p3, p4, nen : ExprNode;
    ptn, pt1, pt2, pt3, pt4, pt1b : TypeNode;
    nump : integer;
    error : ErrorKind;
    value, lowerBound : cardinal;
    sym : Symbol;
    newProc : ProcNode;
    pn1, pn2 : ParamNode;
    cn : ConstNode;
begin
    error := ERRNONE;
    nump := 0;
    p1 := nil;
    p2 := nil;
    pt1 := nil;
    pt2 := 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
	BIPABS : 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 [DTINTEGER, DTREAL, DTLONGREAL]) then begin
		    error := ERRTYPE1;
		end else begin
		    retType := pt1;
		end;
	    end;
	end;
	BIPMIN, BIPMAX : 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 pt1^.kind <> pt2^.kind then begin
		    ErrorName(proc^.name,'Both parameters must be same type');
		    error := ERROTHER;
		end else if not (pt1^.kind in [DTCARDINAL, DTINTEGER, DTREAL, DTLONGREAL]) then begin
		    error := ERRTYPE1;
		end else begin
		    retType := pt1;
		end;
	    end;
	end;
	BIPASSERT : begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump in [1,2] then begin
		pt1 := BaseType(CheckExpr(p1,EVALGET));
		if IsBadExpr(p1) then begin
		    error := ERROTHER;
		end else if pt1^.kind <> DTBOOLEAN then begin
		    error := ERRTYPE1;
		end else if nump = 1 then begin
		    new(cn);
		    cn^.kind := DTSTRING;
		    cn^.strVal := NewString;
		    p2 := ConstExprNode(cn);
		    p2^.exprType := ConstType(cn);
		    params := AddToExprList(params,p2);
		end else begin
		    pt2 := CheckExpr(p2,EVALPOINT);
		    if IsBadExpr(p2) then begin
			error := ERROTHER;
		    end else if not Passable(arrayOfCharTypeNode,PARAMARRAYVALUE,pt2,p2)
		    then begin
			error := ERRTYPE2;
		    end else begin
			RefOpenArray(p2,pt2);
		    end;
		end;
	    end else begin
		error := ERRNUMP;
	    end;
	    retType := nil;
	end;
	BIPCAP : 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 pt1^.kind <> DTCHAR then begin
		    error := ERRTYPE1;
		end else begin
		    retType := charTypeNode;
		end;
	    end;
	end;
	BIPCHR : 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,DTWORD,DTBYTE]) then begin
		    error := ERRTYPE1;
		end else begin
		    retType := charTypeNode;
		end;
	    end;
	end;
	BIPDEC, BIPINC : begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump in [1,2] then begin