decls.p

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

	some := more;
    end else begin
	some^.last^.next := more^.first;
	some^.last := more^.last;
	dispose(more);
    end;
    AppendFieldList := some;
end;

function MakeVariant {(tag : ConstSetList; fieldList : FieldList)
	: VariantNode};
var
    vn : VariantNode;
begin
    new(vn);
    vn^.tag := tag;
    vn^.fieldList := fieldList;
    vn^.tagField := nil;
    MakeVariant := vn;
end;

function MakeVariantField {(ident : String; fieldType : TypeNode;
	variantList : VariantList; elseVariant : VariantNode) : FieldList};
var
    fl : FieldList;
    fn : FieldNode;
begin
    new(fn);
    fn^.name := ident;
    fn^.fieldType := fieldType;
    fn^.kind := FIELDVARIANT;
    fn^.containingVariant := nil;
    fn^.variantList := AddToVariantList(variantList,elseVariant);
    new(fl);
    fl^.first := fn;
    fl^.last := fn;
    fn^.next := nil;
    MakeVariantField := fl;
end;

procedure DefineFields{(fieldList : FieldList; scope : Scope;
	an : AllocationNode; recType : TypeNode;
	containingVariant : VariantNode; var alignment : cardinal)};
var
    fn : FieldNode;
    vn : VariantNode;
    sym : Symbol;
    san : AllocationNode;
    address : Address;
    fieldAlign : cardinal;
    atn : TypeNode;
begin
    fn := fieldList^.first;
    while fn <> nil do begin
	fn^.recType := recType;
	fn^.containingVariant := containingVariant;
	if fn^.name <> nil then begin
	    if DefineSymbol(sym,fn^.name,scope,SCOPECASE) then begin
		atn := ActualType(fn^.fieldType);
		if atn <> nil then begin
		    if atn^.kind = DTARRAY then begin
			if atn^.arrayKind = ARRAYOPEN then begin
			    ErrorName(fn^.name,'Open array type is valid only for parameters');
			end;
		    end;
		end;
		sym^.kind := SYMFIELD;
		sym^.symField := fn;
		fieldAlign := AlignmentOf(fn^.fieldType);
		AllocateMemory(an,MEMNORMAL,SizeOf(fn^.fieldType),
		    fieldAlign,nil,address);
		fn^.offset := address.offset;
		if fieldAlign > alignment then begin
		    alignment := fieldAlign;
		end;
	    end else begin
		ErrorName(fn^.name,'Field name reused in record');
	    end;
	end else begin
	    fn^.offset := -1;
	end;
	if fn^.kind = FIELDVARIANT then begin
	    vn := fn^.variantList^.first;
	    while vn <> nil do begin
		vn^.tagField := fn;
		san := SaveAllocationNode(an);
		DefineFields(vn^.fieldList,scope,an,recType,vn,alignment);
		RestoreAllocationNode(an,san);
		vn := vn^.next;
	    end;
	    UpdateAllocationNode(an);
	end;
	fn := fn^.next;
    end;
end;

function RecordType {(fieldList : FieldList) : TypeNode};
var
    tn : TypeNode;
    an : AllocationNode;
begin
    tn := NewTypeNode(DTRECORD);
    tn^.fieldList := fieldList;
    tn^.recScope := StartScope(false);
    EndScope;
    an := InitAllocationNode;
    tn^.alignment := 1;
    DefineFields(fieldList, tn^.recScope, an, tn, nil,tn^.alignment);
    tn^.size := RoundUp(an^.maximum[MEMNORMAL],tn^.alignment);
    dispose(an);
    RecordType := tn;
end;

function MakeSubrange {(low, up : cardinal; baseType : Typenode)
	    : TypeNode};
var
    tn : TypeNode;
begin
    tn := NewTypeNode(DTSUBRANGE);
    tn^.subMaxOrd := up;
    tn^.subMinOrd := low;
    tn^.baseType := baseType;
    tn^.size := baseType^.size;
    tn^.alignment := baseType^.alignment;
    MakeSubrange := tn;
end;

function SubrangeType {(lower, upper : ConstNode) : TypeNode};
var
    tn, baseType : TypeNode;
    low, up : cardinal;
begin
    tn := nil;
    if (lower = nil) or (upper = nil) then begin
	{ do nothing }
    end else if (lower^.kind <> upper^.kind) and
	    (not (lower^.kind in [DTINTEGER,DTCARDINAL]) or
	    not (upper^.kind in [DTINTEGER,DTCARDINAL]))
    then begin
	Error('Subrange lower and upper bounds are not the same type');
    end else if not (lower^.kind in indexableTypes) then begin
	ErrorName(stringDataType[lower^.kind],'Invalid type for subrange');
    end else begin
	low := OrdOf(lower);
	up := OrdOf(upper);
	case lower^.kind of
	    DTINTEGER, DTCARDINAL: begin
		if low < 0 then begin
		    if (low < -MAXINT-1) or (up > MAXINT) then begin
			Error('Subrange bounds exceed implementation limits');
		    end;
		    baseType := integerTypeNode;
		end else if standardCardinalFlag or (up > MAXINT) then begin
		    if up > MAXCARD then begin
			Error('Subrange bounds exceed implementation limits');
		    end;
		    baseType := cardinalTypeNode;
		end else begin
		    baseType := cardIntTypeNode;
		end;
	    end;
	    DTCHAR: begin
		baseType := charTypeNode;
	    end;
	    DTENUMERATION: begin
		if lower^.enumVal^.enumType <> upper^.enumVal^.enumType
		then begin
		    Error('Subrange lower and upper bounds are not the same enumeration');
		end;
		baseType := lower^.enumVal^.enumType;
	    end;
	    DTBOOLEAN: begin
		baseType := booleanTypeNode;
	    end;
	end;
	if low > up then begin
	    Error('Start of subrange greater than end');
	end else begin
	    tn := MakeSubrange(low,up,baseType);
	end;
    end;
    SubrangeType := tn;
end;

function EnumerationType{(idList : IdentList) : TypeNode};
var
    tn : TypeNode;
    id, idnext : IdentNode;
    sym : Symbol;
    enum : EnumNode;
    enumList : EnumList;
    enumOrd : integer;
    redefinedType : TypeNode;
    error : boolean;
begin
    error := false;
    tn := NewTypeNode(DTENUMERATION);
    tn^.size := WORDSIZE;
    enumList := AddToEnumList(nil,nil);
    enumOrd := 0;
    redefinedType := nil;
    id := idList^.first;
    while id <> nil do begin
	if DefineSymbol(sym,id^.name,nil,SCOPECASE) then begin
	    sym^.kind := SYMENUM;
	    new(enum);
	    enum^.name := id^.name;
	    enum^.enumOrd := enumOrd;
	    enum^.enumType := tn;
	    enum^.enumSym := sym;
	    sym^.symEnum := enum;
	    enumList := AddToEnumList(enumList,enum);
	end else begin
	    if sym^.kind <> SYMENUM then begin
		ErrorName(id^.name,'Enumeration constant redefined');
		error := true;
	    end else if sym^.symEnum^.enumOrd <> enumOrd then begin
		ErrorName(id^.name,'Enumeration constant redefined');
		error := true;
	    end else if redefinedType = nil then begin
		redefinedType := sym^.symEnum^.enumType;
	    end else if sym^.symEnum^.enumType <> redefinedType then begin
		Error('Enumeration partially redefined');
		error := true;
	    end;
	end;
	enumOrd := enumOrd + 1;
	id := id^.next;
    end;
    id := idList^.first;
    while id <> nil do begin
	idnext := id^.next;
	dispose(id);
	id := idnext;
    end;
    dispose(idList);
    if error then begin
	dispose(tn);
	tn := nil;
    end else if redefinedType = nil then begin
	tn^.enumList := enumList;
	tn^.enumCount := enumOrd;
    end else begin
	dispose(tn);
	if enumOrd = redefinedType^.enumCount then begin
	    tn := redefinedType;
	end else begin
	    Error('Enumeration partially redefined');
	    tn := nil;
	end;
    end;
    EnumerationType := tn;
end;


function TypeWithSize(tn : TypeNode; size : ConstNode) : TypeNode;
var
    stn : TypeNode;
begin
    stn := NewTypeNode(DTRENAME);
    stn^.renameType := tn;
    stn^.size := OrdOf(size);
    TypeWithSize := stn;
end;

function TypeWithAlign(tn : TypeNode; alignment : ConstNode) : TypeNode;
var
    stn : TypeNode;
begin
    stn := NewTypeNode(DTRENAME);
    stn^.renameType := tn;
    stn^.size := tn^.size;
    stn^.alignment := OrdOf(alignment);
    TypeWithAlign := stn;
end;


function MakeIdent {(name : String) : IdentNode};
var
    idn : IdentNode;
begin
    new(idn);
    idn^.name := name;
    MakeIdent := idn;
end;

procedure PrintType{(tn:TypeNode;indent:integer)};
begin
    if tn = nil then begin
	writeln(output,' ':indent,'nil pointer');
    end else begin
	writeln(output,' ':indent,tn^.kind);
	if not(tn^.kind in [DTINTEGER, DTBOOLEAN, DTCHAR, DTREAL, DTLONGREAL,
		DTCARDINAL])
	then begin
	    case tn^.kind of
		DTPOINTER : begin
		    PrintType(tn^.toType,indent+INDENT);
		end;
		DTSET : begin
		    PrintType(tn^.setRange,indent+INDENT);
		end;
		DTRENAME : begin
		    PrintType(tn^.renameType,indent+INDENT);
		end;
		DTOPAQUE : begin
		    write(output,' ':indent+INDENT);
		    WriteString(output,tn^.opaqueName);
		    writeln(output);
		end;
		DTARRAY : begin
		    PrintType(tn^.indexType,indent+INDENT);
		    PrintType(tn^.elementType,indent+INDENT);
		end;
		DTRECORD : begin
		    writeln(output,' ':indent+INDENT,'Record fields');
		end;
		DTSUBRANGE : begin
		    writeln(output,' ':indent+INDENT,tn^.subMinOrd:1,'..',
			tn^.subMaxOrd:1);
		    PrintType(tn^.baseType,indent+INDENT);
		end;
	    end;
	end;
    end;
end;

function Import{(fromIdent : String; idents : IdentList) : ImportNode};
var
    imp : ImportNode;
begin
    if TraceDecls then begin
	writeln(output,'Import: start');
    end;
    new(imp);
    imp^.fileName := currFile;
    imp^.lineNumber := currLine;
    imp^.fromIdent := fromIdent;
    imp^.idents := idents;
    if fromIdent <> nil then begin
	imp^.searchList := AddToIdentList(nil,MakeIdent(fromIdent));
    end else begin
	imp^.searchList := idents;
    end;
    imp^.currSearch := imp^.searchList^.first;
    imp^.saveModule := nil;
    imp^.saveScope := nil;
    currModule^.imports := AddToImportList(currModule^.imports,imp);
    Import := imp;
end;

procedure EndImport(imp : ImportNode);
var
    modSym : Symbol;
begin
    if imp^.saveModule <> nil then begin
	{ just returned from a declaration module }
	{ restore to normal mode }
	if currModule <> globalModule then begin
	    ErrorName(imp^.currSearch^.name,'Missing end in imported module');
	end else begin
	    modSym := LookUpSymbol(imp^.currSearch^.name,currScope,ONECASE);
	    if modSym = nil then begin
		ErrorName(imp^.currSearch^.name,'Did not find expected module in import file');
	    end;
	end;
	currModule := imp^.saveModule;
	currScope := imp^.saveScope;
	imp^.saveModule := nil;
	imp^.saveScope := nil;
	imp^.currSearch := imp^.currSearch^.next;
    end;
end;

function ReadImport{(imp : ImportNode) : ImportNode};
var
    modSym : Symbol;
    fileString : String;
    fileName : FileName;
    inMemory : boolean;
    i : integer;
begin
    if TraceDecls then begin
	writeln(output,'ReadImport: continue=',imp^.saveModule<>nil);
    end;
    EndImport(imp);
    inMemory := true;
    while inMemory and (imp^.currSearch <> nil) do begin
	if TraceDecls then begin
	    write(output,'Import module ');
	    WriteString(output,imp^.currSearch^.name);
	    writeln(output);
	end;
	modSym := LookUpSymbol(imp^.currSearch^.name,currScope^.enclosing,ONECASE);
	if modSym <> nil then begin
	    { found, make sure it's a module }
	    if modSym^.kind = SYMMODULE then begin
		if modSym^.symModule^.doingImport then begin
		    ErrorName(modSym^.name,'Recursive import of module');
		end;
	    end;
	    imp^.currSearch := imp^.currSearch^.next;
	end else if currModule^.enclosing = globalModule then begin
	    { not found, look for file }
	    if TraceDecls then begin
		writeln(output,' Looking for file');
	    end;
	    assert(currProc = globalProc);

	    i := 0;
	    while (i < imp^.currSearch^.name^.length)
		and (i < FILENAMESIZE-4)
	    do begin
		AddChar(GetChar(imp^.currSearch^.name,i));
		i := i + 1;
	    end;
	    AddText('.def');
	    fileString := NewString;

	    { Look for external module }
	    if not InitFile(fileString) then begin
		ErrorName(fileString,'Cannot find file for imported module');
		imp^.currSearch := imp^.currSearch^.next;
	    end else begin
		{ save state of current module }
		imp^.saveModule := currModule;
		imp^.saveScope := currScope;
		currModule := globalModule;
		currScope := globalModule^.scope;
		{ continue parsing with definition module }
		inMemory := false;
	    end;
	end else begin
	    { non-global module, must be defined later }
	    imp^.currSearch := imp^.currSearch^.next;
	end;
    end;
    if TraceDecls then begin
	writeln(output,'ReadImport: exit');
    end;
    ReadImport := imp;
end;

procedure ProcessImport{(imp : ImportNode; complain : boolean)};
var
    id, idnext : IdentNode;
    sym, nsym, msym : Symbol;
    scope : Scope;
    remainder : IdentList;
    fromModule, mn : ModuleNode;
    qualified : boolean;
begin
    if TraceDecls then begin
	writeln(output,'ProcessImport: start');
    end;
    EndImport(imp);
    currFile := imp^.fileName;
    currLine := imp^.lineNumber;
    scope := nil;
    if imp^.fromIdent <> nil then begin
	{ import from }
	sym := LookUpSymbol(imp^.fromIdent,currScope^.enclosing,ONECASE);
	if sym = nil then begin
	    if complain then begin
		ErrorName(imp^.fromIdent,'Module not found for import');
	    end;
	end else if sym^.kind <> SYMMODULE then begin
	    if complain then begin
		ErrorName(imp^.fromIdent,'Import "from" is not a module');
	    end;
	end else begin
	    scope := sym^.symModule^.exportScope;
	    fromModule := sym^.symModule;
	    qualified := true;
	    { if module exists, complain on first pass, not on second }
	    complain := not complain;
	end;   
    end else begin
	scope := currScope^.enclosing;
	fromModule := currModule^.enclosing;
	qualified := false;
    end;
    if scope = nil then begin
	{ do nothing }
    end else if imp^.idents <> nil then begin
	remainder := nil;
	id := imp^.idents^.first;
	while id <> nil do begin
	    idnext := id^.next;
	    sym := LookUpSymbol(id^.name,scope,ONECASE);
	    if sym = nil then begin
		if complain then begin
		    ErrorName(id^.name,'Not found on import');
		end;
		remainder := AddToIdentList(remainder,id);
	    end else begin
		nsym := Port(sym,nil);    
		if currModule^.enclosing = globalModule then begin
		    GlobalPort(sym,fromModule,currModule,qualified);
		    if sym^.kind = SYMMODULE then begin
			mn := sym^.symModule;
			if mn^.qualExports <> nil then begin
			    id := mn^.qualExports^.first;
			    while id <> nil do begin
				msym := LookUpSymbol(id^.name,mn^.exportScope,
					    ONECASE);
				if msym = nil then begin
				    if complain then begin
					ErrorName(id^.name,'Not found on import');
				    end;
				end else begin
				    GlobalPort(msym,mn,currModule,true);
				end;
				id := id^.next;
			    end;
			end;
			if mn^.unqualExports <> nil then begin
			    id := mn^.unqualExports^.first;
			    while id <> nil do begin
				msym := LookUpSymbol(id^.name,mn^.exportScope,
					    ONECASE);
				if msym = nil then begin
				    if complain then begin
					ErrorName(id^.name,'Not found on import');
				    end;
				end else begin
				    GlobalPort(msym,mn,currModule,false);
				end;
				id := id^.next;
			    end;
			end;
		    end;
		end;
	    end;
	    id := idnext;
	end;
	imp^.idents := remainder;
    end;
end;

procedure Export{(idents : IdentList; qualToken : Token)};
begin
    if (qualToken = TKQUALIFIED) or
      ((currModule^.enclosing = globalModule) and (qualToken <> TKUNQUALIFIED))
    then begin
	currModule^.qualExports := AppendIdentList(currModule^.qualExports,
					idents);
    end else begin
	currModule^.unqualExports := AppendIdentList(currModule^.unqualExports,
					idents);
    end;
end;

function MakeConstSet {(lower, upper : ConstNode) : ConstSetNode};
var
    cln : ConstSetNode;
    error : boolean;
begin