decls.p

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

	    ErrorName(fileString,
		    'Cannot find definition module for implementation module');
	    exit(999);
	end;
	if 'i' in debugSet then begin
	    write(output,'GetDefinitionFile ');
	    WriteString(output,mn^.name);
	    write(output,' : ');
	    WriteString(output,currFile);
	    writeln(output);
	end;
    end;
end;

function DefineProc{(name : String; global : Token): ProcNode};
var
    pn : ProcNode;
    sym : Symbol;
begin
    if DefineSymbol(sym,name,nil,SCOPECASE) then begin
	currProc^.containsProcs := true;
	sym^.kind := SYMPROC;
	new(pn);
	pn^.fileName := currFile;
	pn^.lineNumber := currLine;
	pn^.name := name;
	if global = TKEXTERNAL then begin
	    pn^.globalName := name;
	    pn^.extern := true;
	end else begin
	    pn^.globalName := GlobalName(name, currModule, currProc);
	    pn^.extern := false;
	end;
	pn^.procType := nil;
	pn^.builtin := BIPNOTBIP;
	pn^.body := nil;
	pn^.code := AddToCodeList(nil,nil);

	pn^.scope := StartScope(true);
	pn^.block := pn^.scope^.block;
	pn^.mem := InitAllocationNode;
	pn^.displayLevel := currProc^.displayLevel+1;
	pn^.enclosing := currProc;
	pn^.enclosingModule := currModule;
	pn^.containsProcs := false;
	pn^.internalProc := not OptNcall;
	pn^.tailRecursion := false;
	pn^.tempMap := nil;
	pn^.varList := nil;
	currProc := pn;
	sym^.symProc := pn;
    end else begin
	if sym^.kind <> SYMPROC then begin
	    ErrorName(name,'Symbol redefined');
	    pn := nil;
	end else if sym^.symProc^.builtin <> BIPNOTBIP then begin
	    ErrorName(name,'Builtin procedure redefined');
	    pn := nil;
	end else if sym^.symProc^.body <> nil then begin
	    ErrorName(sym^.symProc^.name,'Procedure redefined');
	    pn := nil;
	end else if (sym^.symProc^.name <> sym^.symProc^.globalName)
	    and (global = TKEXTERNAL)
	then begin
	    ErrorName(sym^.symProc^.name,'External must be specified in definition module');
	    pn := nil;
	end else begin
	    pn := sym^.symProc;
	    { put procedure in proper scope nesting }
	    pn^.scope^.enclosing := currScope;
	    currScope := pn^.scope;
	    currProc := pn;
	    pn^.fileName := currFile;
	    pn^.lineNumber := currLine;
	end;
    end;
    DefineProc := pn;
end;

function AddTypeToProc{(proc : ProcNode; procType : TypeNode): ProcNode};
begin
    if proc = nil then begin
	{ do nothing }
    end else if proc^.procType <> nil then begin
	CheckEqualProc(proc,procType);
    end else begin
	proc^.procType := procType;
    end;
    AddTypeToProc := proc;
end;

procedure EndProc{(proc : ProcNode; body : StmtList; name : String)};
var
    code : CodeNode;
    param : ParamNode;
    vn : VarNode;
    atn : TypeNode;
begin
    if proc = nil then begin
	{ do nothing }
    end else begin
	if body <> nil then begin
	    proc^.body := body;
	    currModule^.procs := AddToProcList(currModule^.procs,proc);
	    new(code);
	    code^.kind := CODEPROC;
	    code^.proc := proc;
	    code^.stmts := body;
	    proc^.code := AddToCodeList(proc^.code,code);
	    { allocate variables for parameters }
	    if proc^.procType^.paramList <> nil then begin
		param := proc^.procType^.paramList^.first;
		while param <> nil do begin
		    atn := ActualType(param^.paramType);
		    if atn <> nil then begin
			if atn^.kind = DTARRAY then begin
			    if atn^.nocount then begin
				ErrorName(param^.name,'Modula-2 routines may not have nocount parameters');
			    end;
			end;
		    end;
		    case param^.kind of
			PARAMVAR  : begin
			    { reference parameter: allocate address }
			    vn := DefineVar(param^.name,addressTypeNode,MEMPARAM,false);
			    vn^.varType := param^.paramType;
			    vn^.indirect := true;
			end;
			PARAMVALUE : begin
			    if param^.reference then begin
				{ multiword parameter: allocate address }
				vn := DefineVar(param^.name,addressTypeNode,
					MEMPARAM,false);
				vn^.varType := param^.paramType;
				vn^.indirect := true;
			    end else begin
				vn := DefineVar(param^.name,param^.paramType,
					MEMPARAM,false);
			    end;
			end;
			PARAMARRAYVAR, PARAMARRAYVALUE : begin
			    vn := DefineVar(param^.name,addressTypeNode,MEMPARAM,false);
			    vn^.varType := param^.paramType;
			    param^.numElements :=
					DefineVar(nil,integerTypeNode,MEMPARAM,false);
			end;
		    end;
		    param^.paramVar := vn;
		    param := param^.next;
		end;
	    end;
	end;
	if (name <> nil) and (name <> proc^.name) then begin
	    ErrorName(proc^.name,'Name of procedure does not appear on end');
	end;
	currProc := currProc^.enclosing;
	EndScope;
    end;
end;

procedure CheckProc{(pn : ProcNode)};
var
    saveScope : Scope;
    saveProc : ProcNode;
    param : ParamNode;
    vn : VarNode;
begin
    saveScope := currScope;
    saveProc := currProc;
    currScope := pn^.scope;
    currProc := pn;

    if pn^.body <> nil then begin
	if 'c' in debugSet then begin
	    write(output,'Unchecked statements for module ');
	    WriteString(output,pn^.name);
	    writeln(output);
	    PrintStmtList(pn^.body,0);
	end;
	returnSeen := false;
	CheckStmtList(pn^.body);
	if pn^.procType^.funcType <> nil then begin
	    CheckReturn(pn);
	end;
	if 'c' in debugSet then begin
	    write(output,'Checked statements for module ');
	    WriteString(output,pn^.name);
	    writeln(output);
	    PrintStmtList(pn^.body,0);
	end;
	currFile := pn^.fileName;
	currLine := pn^.lineNumber;
	{ allocate variables for parameters }
	if pn^.procType^.paramList <> nil then begin
	    param := pn^.procType^.paramList^.first;
	    while param <> nil do begin
		vn := param^.paramVar;
		case param^.kind of
		    PARAMARRAYVAR,
		    PARAMVAR  : begin
		    end;
		    PARAMVALUE : begin
			{ value parameter: check for modifications }
			if (vn^.varType^.size > WORDSIZE) and
			    (vn^.varType^.kind <> DTLONGREAL)
			then begin
			    { large and modified :  copy it }
			    param^.docopy := vn^.changed;
			    if param^.docopy and
				    (param^.paramType^.kind = DTARRAY)
			    then begin
				if param^.paramType^.nocount then begin
				    ErrorName(param^.name,
				    'NOCOUNT parameter must not require copying');
				end;
			    end;
			end;
		    end;
		    PARAMARRAYVALUE : begin
			if vn^.changed then begin
			    { modified value open array parameter:  must copy it }
			    param^.docopy := true;
			end;
		    end;
		end;
		param := param^.next;
	    end;
	end;
    end;
    currScope := saveScope;
    currProc := saveProc;
end;

procedure CheckModule{(mn : ModuleNode)};
var
    submn : ModuleNode;
    pn : ProcNode;
    saveScope : Scope;
    saveModule : ModuleNode;
    imp : ImportNode;
begin
    saveModule := currModule;
    saveScope := currScope;
    currModule := mn;
    currScope := mn^.scope;

    { look for any unresolved imports }
    if mn^.imports <> nil then begin
	imp := mn^.imports^.first;
	while imp <> nil do begin
	    ProcessImport(imp,true);
	    imp := imp^.next;
	end;
    end;

    submn := mn^.modules^.first;
    while submn <> nil do begin
	CheckModule(submn);
	submn := submn^.next;
    end;
    pn := mn^.procs^.first;
    while pn <> nil do begin
	CheckProc(pn);
	pn := pn^.next;
    end;
    if mn^.body <> nil then begin
	if 'c' in debugSet then begin
	    write(output,'Unchecked statements for module ');
	    WriteString(output,mn^.name);
	    writeln(output);
	    PrintStmtList(mn^.body,0);
	end;
	CheckStmtList(mn^.body);
	if 'c' in debugSet then begin
	    write(output,'Checked statements for module ');
	    WriteString(output,mn^.name);
	    writeln(output);
	    PrintStmtList(mn^.body,0);
	end;
    end;
    currModule := saveModule;
    currScope := saveScope;
end;

function MakeParamList{(kindToken : Token; idents : IdentList;
	paramType : TypeNode) : ParamList};
var
    pl : ParamList;
    pn : ParamNode;
    id : IdentNode;
    kind : ParamKind;
    reference : boolean;
begin
    reference := false;
    if kindToken = TKVAR then begin
	kind := PARAMVAR;
	if (paramType^.kind = DTARRAY) then begin
	    if paramType^.arrayKind = ARRAYOPEN then begin
		kind := PARAMARRAYVAR;
	    end;
	end;
	reference := true;
    end else begin
	kind := PARAMVALUE;
	if (paramType^.kind = DTARRAY) then begin
	    if paramType^.arrayKind = ARRAYOPEN then begin
		kind := PARAMARRAYVALUE;
		reference := true;
	    end;
	end;
	if (SizeOf(paramType) > WORDSIZE) and
		(BaseType(paramType) <> longrealTypeNode)
	then begin
	    reference := true;
	end;
    end;
    { put first param on list. }
    { Note: this works even if idents is nil, as in proc type definition }
    new(pn);
    if idents = nil then begin
	pn^.name := nil;
    end else begin
	pn^.name := idents^.first^.name;
    end;
    pn^.kind := kind;
    pn^.paramType := paramType;
    pn^.next := nil;
    pn^.docopy := false;
    pn^.reference := reference;
    new(pl);
    pl^.first := pn;
    pl^.last := pn;
    if idents <> nil then begin
	{ do additional parameters, if more idents }
	id := idents^.first^.next;
	while id <> nil do begin
	    new(pn);
	    pn^.name := id^.name;
	    pn^.kind := kind;
	    pn^.paramType := paramType;
	    pn^.next := nil;
	    pn^.docopy := false;
	    pn^.reference := reference;
	    pl^.last^.next := pn;
	    pl^.last := pn;
	    id := id^.next;
	end;
    end;
    MakeParamList := pl;
end;

function AppendIdentList{(some, more : IdentList) : IdentList};
begin
    if some = nil then begin
	some := more;
    end else if more = nil then begin
	{ nothing to do }
    end else if more^.first = nil then begin
	{ nothing to add }
	dispose(more);
    end else if some^.first = nil then begin
	{ nothing to add to }
	dispose(some);
	some := more;
    end else begin
	some^.last^.next := more^.first;
	some^.last := more^.last;
	dispose(more);
    end;
    AppendIdentList := some;
end;

function AppendParamList{(some, more : ParamList) : ParamList};
begin
    if some = nil then begin
	some := more;
    end else if more = nil then begin
	{ nothing to do }
    end else if more^.first = nil then begin
	{ nothing to add }
	dispose(more);
    end else if some^.first = nil then begin
	{ nothing to add to }
	dispose(some);
	some := more;
    end else begin
	some^.last^.next := more^.first;
	some^.last := more^.last;
	dispose(more);
    end;
    AppendParamList := some;
end;

function ProcType{(paramList : ParamList; funcType : Typenode) : TypeNode};
var
    tn : TypeNode;
    num : integer;
    pn : ParamNode;
begin
    tn := NewTypeNode(DTPROC);
    tn^.size := WORDSIZE;
    tn^.paramList := paramList;
    tn^.funcType := funcType;
    num := 0;
    if paramList <> nil then begin
	pn := paramList^.first;
	while pn <> nil do begin
	    num := num + 1;
	    pn := pn^.next;
	end;
    end;
    tn^.numParams := num;
    ProcType := tn;
end;

function PointerForwardType (name : String; option : Token) : TypeNode;
var
    tn, otn : TypeNode;
    sym : Symbol;
begin
    tn := nil;
    { look for ident.  If not found, create a forward reference to it }
    sym := LookUpSymbol(name,nil,ONECASE);
    if sym <> nil then begin
	if sym^.kind <> SYMTYPE then begin
	    ErrorName(name,'Must be a type for pointer type definition');
	end else begin
	    tn := PointerType(sym^.symType,option);
	end;
    end else begin
	if not DefineSymbol(sym,name,nil,SCOPECASE) then begin
	    ErrorName(name,'Unexpected error in PointerForwardType');
	end else begin
	    { treat toType as a rename (indirect) type }
	    otn := NewTypeNode(DTRENAME);
	    otn^.size := WORDSIZE;
	    otn^.renameType := nil;
	    tn := PointerType(otn,option);
	    sym^.kind := SYMTYPE;
	    sym^.symType := otn;
	end;
    end;
    PointerForwardType := tn;
end;

function PointerType {(toType : TypeNode; option : Token) : TypeNode};
var
    tn : TypeNode;
begin
    tn := NewTypeNode(DTPOINTER);
    tn^.size := WORDSIZE;
    tn^.toType := toType;
    if option = TKPOINTER then begin
	tn^.ptrCheck := CHECKPTRMODULA;
    end else if option = TKATPASCAL then begin
	tn^.ptrCheck := CHECKPTRPASCAL;
    end else if option = TKATC then begin
	tn^.ptrCheck := CHECKPTRC;
    end else if option = TKATNONE then begin
	tn^.ptrCheck := CHECKPTRNONE;
    end else if option = TKATNIL then begin
	tn^.ptrCheck := CHECKPTRNIL;
    end;
    PointerType := tn;
end;

function SetType {(setRange : TypeNode) : TypeNode};
var
    tn : TypeNode;
begin
    tn := NewTypeNode(DTSET);
    tn^.setRange := setRange;
    tn^.size := NumberOf(setRange);
    SetType := tn;
end;

function ArrayType {(indexType : TypeNode; elementType : TypeNode;
	kind, option : Token) : TypeNode};
var
    atn, btn : TypeNode;
begin
    atn := NewTypeNode(DTARRAY);
    atn^.indexType := indexType;
    atn^.elementType := elementType;
    if indexType = nil then begin
	{ open array parameter }
	atn^.size := 2 * WORDSIZE;	{ for address and number of elements }
	atn^.nocount := option = TKNOCOUNT;
	atn^.arrayKind := ARRAYOPEN;
    end else begin
	atn^.arrayKind := ARRAYNORMAL;
	atn^.nocount := false;
	case target of
	    TARGETVAX : begin
		atn^.size := NumberOf(indexType) * SizeOf(elementType);
		atn^.alignment := AlignmentOf(elementType);
	    end;
	    TARGETTITAN : begin
		btn := BaseType(elementType);
		if btn^.kind = DTCHAR then begin
		    atn^.size := RoundUp(NumberOf(indexType) * CHARSIZE,WORDSIZE);
		end else begin
		    atn^.size := NumberOf(indexType) * SizeOf(elementType);
		end;
		atn^.alignment := WORDSIZE;
	    end;
	end;
    end;
    ArrayType := atn;
end;

function MakeFieldList{(idents : IdentList; fieldType : TypeNode) : FieldList};
	var
    fl : FieldList;
    fn : FieldNode;
    id : IdentNode;
begin
    { put first field on list. }
    new(fn);
    fn^.kind := FIELDNORMAL;
    fn^.name := idents^.first^.name;
    fn^.fieldType := fieldType;
    fn^.containingVariant := nil;
    fn^.next := nil;
    new(fl);
    fl^.first := fn;
    fl^.last := fn;
    if idents <> nil then begin
	{ do additional fields, if more idents }
	id := idents^.first^.next;
	while id <> nil do begin
	    new(fn);
	    fn^.kind := FIELDNORMAL;
	    fn^.name := id^.name;
	    fn^.fieldType := fieldType;
	    fn^.containingVariant := nil;
	    fn^.next := nil;
	    fl^.last^.next := fn;
	    fl^.last := fn;
	    id := id^.next;
	end;
    end;
    MakeFieldList := fl;
end;


function AppendFieldList{(some, more : FieldList) : FieldList};
begin
    if some = nil then begin
	some := more;
    end else if more = nil then begin
	{ nothing to do }
    end else if more^.first = nil then begin
	{ nothing to add }
	dispose(more);
    end else if some^.first = nil then begin
	{ nothing to add to }
	dispose(some);