decls.p

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

    error := false;
    cln := nil;
    if lower = nil then begin
	{ do nothing }
    end else begin
	if upper = nil then begin
	    upper := lower;
	end else if (lower^.kind <> upper^.kind) and
	    not ((lower^.kind in [DTCARDINAL, DTINTEGER])
		and (upper^.kind in [DTCARDINAL,DTINTEGER]))
	then begin
	    error := true;
	end else if lower^.kind = DTENUMERATION then begin
	    if lower^.enumVal^.enumType <> upper^.enumVal^.enumType then begin
		error := true;
	    end;
	end;
	if error then begin
	    Error('Lower bound and upper bound of range must be same type');
	end else if not (lower^.kind in indexableTypes) then begin
	    ErrorName(stringDataType[lower^.kind],'Range type must be indexable');
	end else begin
	    new(cln);
	    cln^.lower := lower;
	    cln^.upper := upper;
	end;
    end;
    MakeConstSet := cln;
end;

function AddToConstSetList {(list : ConstSetList; newOne : ConstSetNode)
	: ConstSetList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToConstSetList := list;
end;

function AddToModuleList {(list : ModuleList; newOne : ModuleNode) : ModuleList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToModuleList := list;
end;

function AddToProcList {(list : ProcList; newOne : ProcNode) : ProcList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToProcList := list;
end;

function AddToFieldList {(list : FieldList; newOne : FieldNode) : FieldList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToFieldList := list;
end;

function AddToVariantList {(list : VariantList; newOne : VariantNode) : VariantList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToVariantList := list;
end;

function AddToEnumList {(list : EnumList; newOne : EnumNode) : EnumList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToEnumList := list;
end;

function AddToImportList {(list : ImportList; newOne : ImportNode) : ImportList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToImportList := list;
end;

function AddToIdentList {(list : IdentList; newOne : IdentNode) : IdentList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToIdentList := list;
end;

function AddToVarList {(list : VarList; newOne : VarNode) : VarList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToVarList := list;
end;

function AddToPortList {(list : PortList; newOne : PortNode) : PortList};
begin
    if list = nil then begin
	new(list);
	list^.first := nil;
	list^.last := nil;
    end;
    if newOne = nil then begin
	{ empty statement, do nothing }
    end else if list^.last = nil then begin
	newOne^.next := nil;
	list^.first := newOne;
	list^.last := newOne;
    end else begin
	newOne^.next := nil;
	list^.last^.next := newOne;
	list^.last:= newOne;
    end;
    AddToPortList := list;
end;

function BaseType {(tn : TypeNode) : TypeNode};
var
    bt : TypeNode;
    found : boolean;
begin
    found := false;
    bt := tn;
    while (bt <> nil) and not found do begin
	if bt^.kind = DTRENAME then begin
	    if bt^.renameType <> nil then begin
		bt := bt^.renameType;
	    end else begin
		found := true;
	    end;
	end else if bt^.kind = DTSUBRANGE then begin
	    bt := bt^.baseType;
	end else begin
	    found := true;
	end;
    end;
    BaseType := bt;
end;

function ActualType {(tn : TypeNode) : TypeNode};
var
    at : TypeNode;
    found : boolean;
begin
    found := false;
    at := tn;
    while not found and (at <> nil) do begin
	if at^.kind <> DTRENAME then begin
	    found := true;
	end else if at^.renameType = nil then begin
	    found := true;
	end else if (at^.size <> at^.renameType^.size) or
		((at^.alignment <> -1) and
			(at^.alignment <> at^.renameType^.alignment))
	then begin
	    found := true;
	end else begin
	    at := at^.renameType;
	end;
    end;
    ActualType := at;
end;

{ NumberOf returns the number of elements in a range }
{	0 if nil (unbounded array parameter), -1 if invalid type }
function NumberOf {(tn : TypeNode) : cardinal};
var
    at : TypeNode;
    count : cardinal;
    found : boolean;
begin
    found := false;
    at := tn;
    while (at <> nil) and not found do begin
	if at^.kind <> DTRENAME then begin
	    found := true;
	end else begin
	    at := at^.renameType;
	end;
    end;
    if at = nil then begin
	count := 0;
    end else begin
	if at^.kind = DTSUBRANGE then begin
	    count := at^.subMaxOrd - at^.subMinOrd + 1;
	end else if at^.kind = DTBOOLEAN then begin
	    count := 2;
	end else if at^.kind = DTCHAR then begin
	    count := 256;
	end else if at^.kind = DTENUMERATION then begin
	    count := at^.enumCount;
	end else begin
	    count := -1;
	end;
    end;
    NumberOf := count;
end;

{ LowerBoundOf returns the value of the first element in the range }
function LowerBoundOf {(tn : TypeNode) : cardinal};
var
    at : TypeNode;
    low : cardinal;
    found : boolean;
begin
    found := false;
    at := tn;
    while (at <> nil) and not found do begin
	if at^.kind <> DTRENAME then begin
	    found := true;
	end else begin
	    at := at^.renameType;
	end;
    end;
    if at = nil then begin
	low := 0;
    end else if at^.kind = DTSUBRANGE then begin
	low := at^.subMinOrd;
    end else if at^.kind = DTINTEGER then begin
	low := -MAXINT-1;
    end else if at^.kind in [DTCARDINAL, DTENUMERATION, DTCHAR, DTBOOLEAN]
    then begin
	low := 0;
    end else begin
	low := 0;
    end;
    LowerBoundOf := low;
end;

{ UpperBoundOf returns the value of the last element in a range }
function UpperBoundOf {(tn : TypeNode) : cardinal};
var
    at : TypeNode;
    up : cardinal;
    found : boolean;
begin
    found := false;
    at := tn;
    while (at <> nil) and not found do begin
	if at^.kind <> DTRENAME then begin
	    found := true;
	end else begin
	    at := at^.renameType;
	end;
    end;
    if at = nil then begin
	up := -1;
    end else if at^.kind = DTSUBRANGE then begin
	up := at^.subMaxOrd;
    end else if at^.kind = DTINTEGER then begin
	up := MAXINT;
    end else if at^.kind = DTCARDINAL then begin
	up := MAXCARD;
    end else if at^.kind = DTBOOLEAN then begin
	up := 1;
    end else if at^.kind = DTCHAR then begin
	up := 255;
    end else if at^.kind = DTENUMERATION then begin
	up := at^.enumCount-1;
    end else begin
	up := -1;
    end;
    UpperBoundOf := up;
end;

function AlignmentOf{(tn : TypeNode) : cardinal};
var
    alignment : cardinal;
    atn : TypeNode;
begin
    atn := tn;
    alignment := -1;
    while (atn <> nil) and (alignment = -1) do begin
	alignment := atn^.alignment;
	if atn^.kind = DTRENAME then begin
	    atn := atn^.renameType;
	end else if atn^.kind = DTSUBRANGE then begin
	    atn := atn^.baseType;
	end else begin
	    atn := nil;
	end;
    end;
    if alignment = -1 then begin
	case target of
	    TARGETVAX : begin
		if tn^.size >= WORDSIZE then begin
		    alignment := WORDSIZE;
		end else begin
		    alignment := 1;
		    while (alignment < tn^.size) do begin
			alignment := alignment * 2;
		    end;
		end;
	    end;
	    TARGETTITAN : begin
		alignment := WORDSIZE;
	    end;
	end;
    end;
    AlignmentOf := alignment;
end;

function SizeOf{(tn : TypeNode) : cardinal};
begin
    { fix AlignmentOf if this is changed }
    SizeOf := tn^.size;
end;

function WordSizeOf{(tn : TypeNode) : cardinal};
begin
    WordSizeOf := RoundUp(tn^.size,WORDSIZE);
end;


procedure CheckEqualType{(sym : Symbol; tn : TypeNode)};
var
    symTn : TypeNode;
begin
    symTn := ActualType(sym^.symType);
    tn := ActualType(tn);
    if symTn = tn then begin
	{ do nothing }
    end else if (symTn^.kind = DTRENAME) and (symTn^.renameType = nil)
    then begin
	symTn^.renameType := tn;
	symTn^.size := tn^.size;
	symTn^.alignment := tn^.alignment;
	if symTn^.name = tn^.name then begin
	    symTn^.name := nil;
	end;
    end else if symTn^.kind = DTOPAQUE then begin
	if tn^.size <> WORDSIZE then begin
	    ErrorName(sym^.name,'Size of actual type for opaque type must be one word');
	end;
	symTn^.kind := DTRENAME;
	symTn^.renameType := tn;
	if symTn^.name = tn^.name then begin
	    tn^.name := nil;
	end;
    end else begin
	ErrorName(sym^.name,'Redefined type');
    end;
end;

procedure CheckEqualVar{(sym : Symbol; tn : TypeNode)};
begin
    ErrorName(sym^.name,'Redefined variable');
end;

function SameTypeParam{(dst, src : Typenode) : boolean};
var
    same : boolean;
begin
    same := false;
    src := ActualType(src);
    dst := ActualType(dst);
    if dst = src then begin
	same := true;
    end else if (dst = nil) or (src = nil) then begin
	{ do nothing }
    end else if (dst^.kind = DTARRAY) and (src^.kind = DTARRAY) then begin
	if (dst^.elementType = src^.elementType) and (dst^.indexType = nil)
	    and (src^.indexType = nil)
	then begin
	    same := true;
	end;
    end; 
    SameTypeParam := same;
end;

procedure CheckEqualProc{(proc : ProcNode; procType : TypeNode)};
var
    pn1, pn2 : ParamNode;
    error : boolean;
begin
    error := false;
    if proc^.procType^.paramList = nil then begin
	pn1 := nil;
    end else begin
	pn1 := proc^.procType^.paramList^.first;
    end;
    if procType^.paramList = nil then begin
	pn2 := nil;
    end else begin
	pn2 := procType^.paramList^.first;
    end;
    while not error and (pn1 <> nil) and (pn2 <> nil) do begin
	if (pn1^.name <> pn2^.name) then begin
	    if not standardKeywordFlag then begin
		error := true;
	    end else begin
		pn1^.name := pn2^.name;
	    end;
	end;
	if (pn1^.kind <> pn2^.kind) or
		not SameTypeParam(pn1^.paramType,pn2^.paramType)
	then begin
	    error := true;
	end;
	pn1 := pn1^.next;
	pn2 := pn2^.next;
    end;
    error := error or (pn1 <> nil) or (pn2 <> nil) or
       (ActualType(proc^.procType^.funcType) <> ActualType(procType^.funcType));
    if error then begin
	ErrorName(proc^.name,
	    'Redefinition of procedure not identical to original');
    end;
end;

procedure ErrorMissingIdent;
begin
    Error('Missing identifier on procedure/module end');
end;

procedure ErrorExtraSemicolon;
begin
    Error('Extra semi-colon');
end;

procedure ErrorMissingSemicolon;
begin
    Error('Missing semi-colon');
end;

procedure ErrorModuleDot;
begin
    Error('Global module must end with a period.');
end;