builtin.p

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

		pt1 := BaseType(CheckExpr(p1,EVALPOINT));
		if IsBadExpr(p1) then begin
		    error := ERROTHER;
		end else if not (pt1^.kind in indexableTypes) then begin
		    error := ERRTYPE1;
		end else if not IsAddressableExpr(p1) then begin
		    error := ERRMETHOD1;
		end else if nump = 1 then begin
		    p2 := ConstExprNode(CardinalConst(1));
		    p2^.exprType := cardIntTypeNode;
		    params := AddToExprList(params,p2);
		end else begin
		    pt2 := BaseType(CheckExpr(p2,EVALGET));
		    if IsBadExpr(p2) then begin
			error := ERROTHER;
		    end else if not (pt2^.kind in [DTCARDINAL, DTINTEGER]) then begin
			error := ERRTYPE2;
		    end;
		end;
	    end else begin
		error := ERRNUMP;
	    end;
	    if error = ERRNONE then begin
		p3 := ConstExprNode(CardinalConst(SizeOf(pt1)));
		p3^.exprType := cardIntTypeNode;
		params := AddToExprList(params,p3);
		retType := pt1;
	    end;
	end;
	BIPDISPOSE, BIPNEW : begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump < 1 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := BaseType(CheckExpr(p1,EVALPOINT));
		if IsBadExpr(p1) then begin
		    error := ERROTHER;
		end else if pt1^.kind <> DTPOINTER then begin
		    error := ERRTYPE1;
		end else if not IsAddressableExpr(p1) then begin
		    error := ERRMETHOD1;
		end else begin
		    value := WordSizeOf(pt1^.toType);
		    if pt1^.ptrCheck = CHECKPTRMODULA then begin
			{ extra word needed for modula pointer check }
			value := value + WORDSIZE;
		    end else if pt1^.ptrCheck in [CHECKPTRPASCAL,CHECKPTRC]
		    then begin
			{ Pascal allocator works in bytes }
			value := CardDiv(value,BYTESIZE);
		    end;
		    { ignore any parameters after the first }
		    p1^.next := nil;
		    params^.last := p1;
		    { add length as second parameter }
		    p2 := ConstExprNode(CardinalConst(value));
		    p2^.exprType := cardIntTypeNode;
		    params := AddToExprList(params,p2);
		    p3 := ConstExprNode(CardinalConst(ord(pt1^.ptrCheck)));
		    p3^.exprType := cardIntTypeNode;
		    params := AddToExprList(params,p3);
		    retType := nil;
		    if proc^.builtin = BIPNEW then begin
			sym := LookUpSymbol(allocateString,nil,ANYCASE);
		    end else begin
			sym := LookUpSymbol(deallocateString,nil,ANYCASE);
		    end;
		    if sym = nil then begin
			{ just use the default }
		    end else if sym^.kind <> SYMPROC then begin
			error := ERROTHER;
		    end else if sym^.symProc^.builtin = BIPALLOCATE then begin
			{ just use the default }
		    end else if sym^.symProc^.builtin = BIPDEALLOCATE then begin
			{ just use the default }
		    end else begin
			newProc := sym^.symProc;
			if newProc^.procType^.paramList = nil then begin
			    error := ERROTHER;
			end else begin
			    pn1 := newProc^.procType^.paramList^.first;
			    if pn1 = nil then begin
				error := ERROTHER;
			    end else begin
				pn2 := pn1^.next;
				if pn2 = nil then begin
				    error := ERROTHER;
				end else begin
				    if (pn1^.paramType <> addressTypeNode) or
					not (pn2^.paramType^.kind in
						    [DTCARDINAL,DTINTEGER]) or
					(pn2^.next <> nil)
				    then begin
					error := ERROTHER;
				    end else begin
					{ use local allocate/deallocate }
					{ instead of new/dispose }
					new(cn);
					cn^.kind := DTPROC;
					cn^.procVal := sym^.symProc;
					p4 := ConstExprNode(cn);
					pt4 := CheckExpr(p4,EVALPOINT);
					params := AddToExprList(params,p4);
				    end;
				end;
			    end;
			end;
		    end;
		    if error = ERROTHER then begin
			ExprErrorName(p1,sym^.name,
			    'wrong procedure type for new/dispose substitution');
		    end;
		end;
	    end;
	end;
	BIPALLOCATE, BIPDEALLOCATE: begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump <> 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := BaseType(CheckExpr(p1,EVALPUT));
		pt2 := BaseType(CheckExpr(p2,EVALGET));
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if pt1^.kind <> DTPOINTER then begin
		    error := ERRTYPE1;
		end else if not IsAddressableExpr(p1) then begin
		    error := ERRMETHOD1;
		end else if not Passable(cardinalTypeNode,PARAMVALUE,pt2,p2)
		then begin
		    error := ERRTYPE2;
		end else begin
		    retType := nil;
		end;
	    end;
	end;
	BIPEXCL, BIPINCL : begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump <> 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExpr(p1,EVALPOINT);
		pt1b := BaseType(pt1);
		pt2 := BaseType(CheckExpr(p2,EVALGET));
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if pt1b^.kind <> DTSET then begin
		    error := ERRTYPE1;
		end else if not IsAddressableExpr(p1) then begin
		    error := ERRMETHOD1;
		end else if not Passable(pt1b^.setRange,PARAMVALUE,pt2,p2)
		then begin
		    error := ERRTYPE2;
		end else begin
		    lowerBound := LowerBoundOf(pt1b^.setRange);
		    if lowerBound <> 0 then begin
			{ replace p2 with (p2 - lowerBound) }
			nen := NewExprNode(p2^.kind);
			nen^ := p2^;
			p2^.kind := EXPRBINOP;
			p2^.exprBinOp := TKMINUS;
			p2^.opnd1 := nen;
			p2^.opnd2 := ConstExprNode(CardinalConst(lowerBound));
			p2^.opnd2^.exprType := nen^.exprType;
			p2^.opnd2^.operType := nen^.exprType;
		    end;
		    p3 := ConstExprNode(CardinalConst(SizeOf(pt1)));
		    p3^.exprType := cardIntTypeNode;
		    params := AddToExprList(params,p3);
		    retType := nil;
		end;
	    end;
	end;
	BIPFLOAT, BIPLONGFLOAT : 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, DTCARDINAL, DTREAL,
			DTLONGREAL])
		then begin
		    error := ERRTYPE1;
		end else if proc^.builtin = BIPFLOAT then begin
		    retType := realTypeNode;
		end else begin
		    retType := longrealTypeNode;
		end;
	    end;
	end;
	BIPHALT : begin
	    if isFunc then begin
		error := ERRFUNC;
	    end else if nump <> 0 then begin
		error := ERRNUMP;
	    end else begin
		retType := nil;
	    end;
	end;
	BIPHIGH, BIPNUMBER : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 1 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := BaseType(CheckExpr(p1,EVALPOINT));
		if IsBadExpr(p1) then begin
		    error := ERROTHER;
		end else if pt1^.kind <> DTARRAY then begin
		    error := ERRTYPE1;
		end else if pt1^.indexType <> nil then begin
		    { constant: evaluate now }
		    if proc^.builtin = BIPHIGH then begin
			value := UpperBoundOf(pt1^.indexType);
		    end else begin
			value := NumberOf(pt1^.indexType);
		    end;
		    procExpr^.kind := EXPRCONST;
		    procExpr^.exprConst := CardinalConst(value);
		    if value >= 0 then begin
			procExpr^.exprType := cardIntTypeNode;
		    end else begin
			procExpr^.exprType := integerTypeNode;
		    end;
		    retType := procExpr^.exprType;	
		end else if pt1^.nocount then begin
		    ExprError(procExpr,'Cannot take high of NOCOUNT array');
		    error := ERROTHER;
		end else begin
		    retType := cardIntTypeNode;	
		end;
	    end;
	end;
	BIPODD : 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 := booleanTypeNode;
		end;
	    end;
	end;
	BIPORD : 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 indexableTypes) then begin
		    error := ERRTYPE1;
		end else begin
		    retType := cardIntTypeNode;
		end;
	    end;
	end;
	BIPTRUNC : 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 [DTREAL,DTLONGREAL]) then begin
		    error := ERRTYPE1;
		end else begin
		    retType := integerTypeNode;
		end;
	    end;
	end;
	BIPVAL : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 2 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := BaseType(CheckExprType(p1,EVALGET));
		pt2 := BaseType(CheckExpr(p2,EVALGET));
		if IsBadExpr(p1) or IsBadExpr(p2) then begin
		    error := ERROTHER;
		end else if p1^.kind <> EXPRSYM then begin
		    error := ERRTYPE1;
		end else if p1^.exprSym^.kind <> SYMTYPE then begin
		    error := ERRTYPE1;
		end else if not (pt1^.kind in indexableTypes) then begin
		    error := ERRTYPE1;
		end else if not (pt2^.kind in [DTCARDINAL,DTINTEGER]) then begin
		    error := ERRTYPE2;
		end else begin
		    retType := pt1;
		end;
	    end;
	end;
	BIPADR : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 1 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := BaseType(CheckExpr(p1,EVALPOINT));
		if IsBadExpr(p1) then begin
		    error := ERROTHER;
		end else if not IsAddressableExpr(p1) then begin
		    error := ERRMETHOD1;
		end else begin
		    RefOpenArray(p1,pt1);
		    retType := addressTypeNode;
		end;
	    end;
	end;
	BIPSIZE, BIPBYTESIZE : begin
	    if not isFunc then begin
		error := ERRPROC;
	    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 begin
		    { constant: evaluate now }
		    value := SizeOf(pt1);
		    if proc^.builtin = BIPBYTESIZE then begin
			value := CardDiv(value+BYTESIZE-1,BYTESIZE);
		    end;
		    procExpr^.kind := EXPRCONST;
		    procExpr^.exprConst := CardinalConst(value);
		    procExpr^.exprType := cardIntTypeNode;
		    retType := cardIntTypeNode;
		end;
	    end;
	end;
	BIPFIRST, BIPLAST : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 1 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExprType(p1,EVALGET);
		if IsBadExpr(p1) then begin
		    error := ERROTHER;
		end else if p1^.kind <> EXPRSYM then begin
		    error := ERRTYPE1;
		end else if p1^.exprSym^.kind <> SYMTYPE then begin
		    error := ERRTYPE1;
		end else begin
		    { constant: evaluate now }
		    if proc^.builtin = BIPFIRST then begin
			value := LowerBoundOf(p1^.exprSym^.symType);
		    end else begin
			value := UpperBoundOf(p1^.exprSym^.symType);
		    end;
		    retType := p1^.exprSym^.symType;
		    new(cn);
		    if retType^.kind = DTCHAR then begin
			cn^.kind := DTCHAR;
			cn^.charVal := trunc(value);
		    end else if retType^.kind = DTBOOLEAN then begin
			cn^.kind := DTBOOLEAN;
			cn^.boolVal := value = 1.0;
		    end else begin
			{ enumerations and integers }
			cn^.kind := DTINTEGER;
			cn^.cardVal := trunc(value);
		    end;
		    procExpr^.kind := EXPRCONST;
		    procExpr^.exprConst := cn;
		    procExpr^.exprType := retType;
		end;
	    end;
	end;
	BIPTSIZE, BIPTBYTESIZE : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 1 then begin
		error := ERRNUMP;
	    end else begin
		pt1 := CheckExprType(p1,EVALGET);
		if IsBadExpr(p1) then begin
		    error := ERROTHER;
		end else if p1^.kind <> EXPRSYM then begin
		    error := ERRTYPE1;
		end else if p1^.exprSym^.kind <> SYMTYPE then begin
		    error := ERRTYPE1;
		end else begin
		    { constant: evaluate now }
		    value := SizeOf(p1^.exprSym^.symType);
		    if proc^.builtin = BIPTBYTESIZE then begin
			value := CardDiv(value+BYTESIZE-1,BYTESIZE);
		    end;
		    procExpr^.kind := EXPRCONST;
		    procExpr^.exprConst := CardinalConst(value);
		    procExpr^.exprType := cardIntTypeNode;
		    retType := cardIntTypeNode;
		end;
	    end;
	end;
	BIPUNIXCALL : 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 p1^.kind <> EXPRCONST then begin
		    error := ERRTYPE1;
		end else if not (pt1^.kind in [DTINTEGER, DTCARDINAL])
		then begin
		    error := ERRTYPE1;
		end else begin
		    if p2 <> nil then begin
			p := p2;
			while p <> nil do begin
			    ptn := CheckExpr(p,EVALGET);
			    if IsBadExpr(p1) then begin
				error := ERROTHER;
			    end;
			    p := p^.next;
			end;
		    end;
		    retType := integerTypeNode;
		end;
	    end;
	end;
	BIPCPUTIME : begin
	    if not isFunc then begin
		error := ERRPROC;
	    end else if nump <> 0 then begin
		error := ERRNUMP;
	    end else begin
		retType := cardIntTypeNode;
	    end;
	end;
	BIPWRITEF : begin
	    if isFunc then begin
		error := ERRFUNC;
	    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 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 }