builtin.p

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

    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPREADC;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('OPEN');
    name := NewString;
    exports := AddToIdentList(exports,MakeIdent(name));
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPOPENF;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('CLOSE');
    name := NewString;
    exports := AddToIdentList(exports,MakeIdent(name));
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPCLOSEF;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('EOF');
    name := NewString;
    exports := AddToIdentList(exports,MakeIdent(name));
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPEOFF;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('INPUT');
    name := NewString;
    exports := AddToIdentList(exports,MakeIdent(name));
    vn := DefineVar(name,fileTypeNode,MEMNORMAL,false);

    AddText('OUTPUT');
    name := NewString;
    exports := AddToIdentList(exports,MakeIdent(name));
    vn := DefineVar(name,fileTypeNode,MEMNORMAL,false);

    AddText('TERMINAL');
    name := NewString;
    exports := AddToIdentList(exports,MakeIdent(name));
    vn := DefineVar(name,fileTypeNode,MEMNORMAL,false);

    Export(exports,TKQUALIFIED);

    EndModule(mn,nil,nil);

    saveScope := currScope;
    currScope := builtinScope;

    AddText('ABS');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPABS;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('ASSERT');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPASSERT;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('CAP');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPCAP;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('CHR');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPCHR;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('DEC');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPDEC;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('DISPOSE');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPDISPOSE;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('EXCL');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPEXCL;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('FLOAT');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPFLOAT;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('LONGFLOAT');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPLONGFLOAT;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('HALT');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPHALT;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('HIGH');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPHIGH;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('NUMBER');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPNUMBER;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('INC');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPINC;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('INCL');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPINCL;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('NEW');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPNEW;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('MAX');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPMAX;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('MIN');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPMIN;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('ODD');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPODD;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('ORD');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPORD;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('TRUNC');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPTRUNC;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('VAL');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPVAL;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('FIRST');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPFIRST;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    AddText('LAST');
    name := NewString;
    pn := DefineProc(name,TKPROCEDURE);
    pn^.builtin := BIPLAST;
    pn^.procType := builtinProcTypeNode;
    EndProc(pn,nil,nil);

    currScope := saveScope;

    if generateBlockNumber > MAXBUILTINSCOPES then begin
	Error('Compiler error: too many builtin scopes');
	exit(99);
    end;
    generateBlockNumber := MAXBUILTINSCOPES+1;

    InitUnixProcNames;

end;

procedure InitStandardTypes;
var
    sym : Symbol;
    cn : ConstNode;
    error : boolean;
begin
    error := false;
    integerTypeNode := NewTypeNode(DTINTEGER);
    integerTypeNode^.size := WORDSIZE;
    AddText('INTEGER');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMTYPE;
    sym^.symType := integerTypeNode;

    cardinalTypeNode := NewTypeNode(DTCARDINAL);
    cardinalTypeNode^.size := WORDSIZE;

    cardIntTypeNode := NewTypeNode(DTINTEGER);
    cardIntTypeNode^.size := WORDSIZE;

    AddText('CARDINAL');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMTYPE;
    if standardCardinalFlag then begin
	sym^.symType := cardinalTypeNode;
    end else begin
	sym^.symType := cardIntTypeNode;
    end;

    AddText('UNSIGNED');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMTYPE;
    sym^.symType := cardinalTypeNode;

    charTypeNode := NewTypeNode(DTCHAR);
    case target of
	TARGETVAX : begin
	    charTypeNode^.size := CHARSIZE;
	end;
	TARGETTITAN : begin
	    charTypeNode^.size := WORDSIZE;
	end;
    end;
    AddText('CHAR');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMTYPE;
    sym^.symType := charTypeNode;

    charConstTypeNode := NewTypeNode(DTCHAR);
    case target of
	TARGETVAX : begin
	    charConstTypeNode^.size := CHARSIZE;
	end;
	TARGETTITAN : begin
	    charConstTypeNode^.size := WORDSIZE;
	end;
    end;

    realTypeNode := NewTypeNode(DTREAL);
    realTypeNode^.size := WORDSIZE;
    AddText('REAL');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMTYPE;
    sym^.symType := realTypeNode;

    longrealTypeNode := NewTypeNode(DTLONGREAL);
    longrealTypeNode^.size := 2*WORDSIZE;
    AddText('LONGREAL');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMTYPE;
    sym^.symType := longrealTypeNode;

    realConstTypeNode := NewTypeNode(DTLONGREAL);
    realConstTypeNode^.size := 2*WORDSIZE;

    stringTypeNode := NewTypeNode(DTSTRING);
    stringTypeNode^.stringLength := 0;
    stringTypeNode^.size := 0;

    bitsetTypeNode := NewTypeNode(DTSET);
    bitsetTypeNode^.size := WORDSIZE;
    bitsetTypeNode^.setRange := MakeSubrange(0,WORDSIZE-1,cardIntTypeNode);
    AddText('BITSET');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMTYPE;
    sym^.symType := bitsetTypeNode;

    booleanTypeNode := NewTypeNode(DTBOOLEAN);
    case target of
	TARGETVAX : begin
	    booleanTypeNode^.size := BOOLEANSIZE;
	end;
	TARGETTITAN : begin
	    booleanTypeNode^.size := WORDSIZE;
	end;
    end;
    AddText('BOOLEAN');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMTYPE;
    sym^.symType := booleanTypeNode;

    new(cn);
    cn^.kind := DTBOOLEAN;
    cn^.boolVal := true;
    AddText('TRUE');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMCONST;
    sym^.symConst := cn;

    new(cn);
    cn^.kind := DTBOOLEAN;
    cn^.boolVal := false;
    AddText('FALSE');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMCONST;
    sym^.symConst := cn;

    procTypeNode := NewTypeNode(DTPROC);
    procTypeNode^.size := WORDSIZE;
    procTypeNode^.paramList := nil;
    procTypeNode^.funcType := nil;
    AddText('PROC');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMTYPE;
    sym^.symType := procTypeNode;

    builtinProcTypeNode := NewTypeNode(DTPROC);
    builtinProcTypeNode^.size := WORDSIZE;
    builtinProcTypeNode^.paramList := nil;
    builtinProcTypeNode^.funcType := nil;

    new(cn);
    cn^.kind := DTPOINTER;
    AddText('NIL');
    error := error or not DefineSymbol(sym,NewString,builtinScope,ANYCASE);
    sym^.kind := SYMCONST;
    sym^.symConst := cn;

    opaqueTypeNode := NewTypeNode(DTOPAQUE);
    AddText('_opaque_');
    opaqueTypeNode^.opaqueName := NewString;
    opaqueTypeNode^.size := WORDSIZE;

    wordTypeNode := NewTypeNode(DTWORD);
    wordTypeNode^.size := WORDSIZE;

    byteTypeNode := NewTypeNode(DTBYTE);
    byteTypeNode^.size := BYTESIZE;

    addressTypeNode := PointerType(wordTypeNode,TKATNONE);

    anyTypeNode := NewTypeNode(DTANY);
    anyTypeNode^.size := WORDSIZE;

    nullTypeNode := NewTypeNode(DTNULL);
    nullTypeNode^.size := 0;

    fileTypeNode := PointerType(opaqueTypeNode,TKATNONE);

    processTypeNode := NewTypeNode(DTOPAQUE);
    processTypeNode^.size := WORDSIZE;
    AddText('SYSTEM_PROCESS');
    processTypeNode^.opaqueName := NewString;

    arrayOfCharTypeNode := ArrayType(nil, charTypeNode, TKARRAY, TKNULL);

    indexableTypes := [DTINTEGER, DTCARDINAL, DTCHAR, DTBOOLEAN, DTENUMERATION,
				DTSUBRANGE];
    if error then begin
	Error('Compiler error:  Cannot initialize builtin types');
	exit(99);
    end;
end;

function CheckWritef(en : ExprNode; format : String; pl : ExprNode;
	    var newFormat : String) : boolean;
const
    FMTCHAR = '%';
var
    ok, lasttime, 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
	    if currPos > 0 then begin
		AddCharX(currCharacter);
	    end;
	    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;
    var
	tn : TypeNode;
    begin
	if currChar = '-' then begin
	    Advance;
	end;
	lasttime := true;
	repeat
	    if currChar = '*' then begin
		Advance;
		if pen = nil then begin
		    ok := false;
		    FmtErr(en,'No parameter for field width');
		end else begin
		    tn := BaseType(CheckExpr(pen,EVALGET));
		    if IsBadExpr(pen) then begin
			ok := false;	{ error already printed }
		    end else if not (tn^.kind in [DTCARDINAL,DTINTEGER])
		    then begin
			FmtErr(en, 'Field width not integer or cardinal');
		    end;
		    pen := pen^.next;