dbstab.p

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

(*#@(#)dbstab.p	4.1	Ultrix	7/17/90 *)
(****************************************************************************
 *									    *
 *  Copyright (c) 1984 by						    *
 *  DIGITAL EQUIPMENT CORPORATION, Maynard, Massachusetts.		    *
 *  All rights reserved.						    *
 * 									    *
 *  This software is furnished under a license and may be used and copied   *
 *  only in  accordance with  the  terms  of  such  license  and with the   *
 *  inclusion of the above copyright notice. This software or  any  other   *
 *  copies thereof may not be provided or otherwise made available to any   *
 *  other person.  No title to and ownership of  the  software is  hereby   *
 *  transferred.							    *
 * 									    *
 *  The information in this software is  subject to change without notice   *
 *  and  should  not  be  construed as  a commitment by DIGITAL EQUIPMENT   *
 *  CORPORATION.							    *
 * 									    *
 *  DIGITAL assumes no responsibility for the use  or  reliability of its   *
 *  software on equipment which is not supplied by DIGITAL.		    *
 * 									    *
$Header: dbstab.p,v 1.5 84/05/19 11:37:56 powell Exp $
 ****************************************************************************)
#include "globals.h"
#include "pcode.h"
#include "optim.h"
#include "ocount.h"
#include "genpcf.h"
#include "genpc.h"
#include "dbstab.h"
#include "decls.h"

const
    STABNMOD2 = 80;	(* same as N_MOD2 in /usr/include/stab.h *)

    STABSOURCEFILE = 100;
    STABSYMBOL = 128;
    STABGLOBAL = 32;
    STABPARAM = 160;
    STABLINE = 68;
    STABPROC = 36;
    STABTOKENSPERLINE = 10;
    MAXBUILTINTYPES = 20;
var
    generateTypeNumber : TypeNumber;
    stabFileName : String;
    stabLineNumber : integer;
    stabTokenCount : integer;
    inTypeDef : boolean;

function NewTypeNumber : TypeNumber;
begin
    generateTypeNumber := generateTypeNumber + 1;
    NewTypeNumber := generateTypeNumber;
end;

procedure StabEndLine;
begin
    EndLine;
    stabTokenCount := 0;
end;

procedure StabComma;
begin
    GenChar(',');
end;

procedure StabSemicolon;
begin
    GenChar(';');
end;

procedure StartTypeDef;
begin
    GenOp(PCSYM); GenChar('t'); StabComma; GenChar('''');
end;

procedure EndTypeDef;
begin
    GenChar(''''); StabComma; GenInteger(STABSYMBOL); Comma;
    GenInteger(0); StabComma; GenInteger(0); Comma;
    GenInteger(0);
    StabEndLine;
end;

procedure StabCommaX;
begin
    GenChar(',');
    stabTokenCount := stabTokenCount + 1;
    if inTypeDef and (stabTokenCount > STABTOKENSPERLINE) then begin
	GenChar('?');
	EndTypeDef;
	StartTypeDef;
    end;
end;

procedure StabSemicolonX;
begin
    GenChar(';');
    stabTokenCount := stabTokenCount + 1;
    if inTypeDef and (stabTokenCount > STABTOKENSPERLINE) then begin
	GenChar('?');
	EndTypeDef;
	StartTypeDef;
    end;
end;

function NamedType(tn : TypeNode) : TypeNode;
var
    ntn : TypeNode;
    found : boolean;
begin
    found := false;
    ntn := tn;
    while not found and (ntn <> nil) do begin
	found := true;
	if (ntn^.opaqueName = nil) and (ntn^.module = nil) and
		(ntn^.kind = DTRENAME)
	then begin
	    if ntn^.renameType <> nil then begin
		ntn := ntn^.renameType;
		found := false;
	    end;
	end;
    end;
    NamedType := ntn;
end;

procedure InitStab;
var
    fileLabel : LabelNumber;
    tn : TypeNode;
begin
    generateTypeNumber := 0;
    stabTokenCount := 0;
    integerTypeNode^.number := NewTypeNumber;
    charTypeNode^.number := NewTypeNumber;
    booleanTypeNode^.number := NewTypeNumber;
    cardinalTypeNode^.number := NewTypeNumber;
    realTypeNode^.number := NewTypeNumber;
    longrealTypeNode^.number := NewTypeNumber;
    wordTypeNode^.number := NewTypeNumber;
    byteTypeNode^.number := NewTypeNumber;
    addressTypeNode^.number := NewTypeNumber;
    fileTypeNode^.number := NewTypeNumber;
    processTypeNode^.number := NewTypeNumber;
    cardIntTypeNode^.number := NewTypeNumber;
    generateTypeNumber := MAXBUILTINTYPES;
    inTypeDef := false;

    fileLabel := NewLabel;
    GenOp(PCSYM); GenChar('s'); StabComma; 
	GenChar(''''); GenString(mainFileName); GenChar(''''); StabComma;
	GenInteger(STABSOURCEFILE); StabComma; GenInteger(0); 
	StabComma; GenInteger(0); Comma; GenLabel(fileLabel); 
    StabEndLine;
    GenLabel(fileLabel); GenOpL(PCLAB);

end;

procedure StabFieldList(fl : FieldList);
var
    fn : FieldNode;
    vn : VariantNode;
begin
    fn := fl^.first;
    while fn <> nil do begin
	if fn^.name <> nil then begin
	    GenString(fn^.name);
	    GenChar(':');
	    StabTypeNumber(fn^.fieldType);
	    StabComma;
	    GenInteger(fn^.offset);
	    StabComma;
	    GenInteger(SizeOf(fn^.fieldType));
	    StabSemicolonX;
	end;
	if fn^.kind = FIELDVARIANT then begin
	    vn := fn^.variantList^.first;
	    while vn <> nil do begin
		StabFieldList(vn^.fieldList);
		vn := vn^.next;
	    end;
	end;
	fn := fn^.next;
    end;
end;

procedure StabProcType(tn : TypeNode);
var
    param : ParamNode;
    ptn : TypeNode;
begin
    if tn^.funcType = nil then begin
	GenChar('p');
    end else begin
	GenChar('f'); StabTypeNumber(tn^.funcType); Comma;
    end;
    GenInteger(tn^.numParams); StabSemicolon;
    if tn^.paramList <> nil then begin
	param := tn^.paramList^.first;
	while param <> nil do begin
	    if param^.name <> nil then begin
		GenString(param^.name); GenChar(':');
	    end;
	    ptn := param^.paramType;
	    StabTypeNumber(ptn);
	    StabComma;
	    GenInteger(ord(param^.kind)); StabSemicolon;
	    param := param^.next;
	end;
    end;
    StabSemicolon;
end;

procedure StabTypeDef{(tn : TypeNode)};
var
    enum : EnumNode;
begin
    tn := NamedType(tn);
    if tn^.opaqueName <> nil then begin
	GenChar('o');
	GenString(tn^.opaqueName);
	if tn^.kind <> DTOPAQUE then begin
	    StabComma;
	end;
    end else if tn^.module <> nil then begin
	{ indirect type name }
	GenChar('i');
	GenString(tn^.module^.name);
	GenChar(':');
	GenString(tn^.name);
	StabComma;
    end;
    case tn^.kind of
	DTINTEGER : StabTypeNumber(integerTypeNode);
	DTCHAR : StabTypeNumber(charTypeNode);
	DTBOOLEAN : StabTypeNumber(booleanTypeNode);
	DTREAL : StabTypeNumber(realTypeNode);
	DTLONGREAL : StabTypeNumber(longrealTypeNode);
	DTCARDINAL : StabTypeNumber(cardinalTypeNode);
	DTNULL, DTSTRING, DTANY, { should not occur }
	DTWORD : StabTypeNumber(wordTypeNode);
	DTBYTE : StabTypeNumber(byteTypeNode);
	DTOPAQUE : ;
	DTRENAME : begin { treat like opaque type }
	    StabTypeNumber(tn^.renameType);
	end;
	DTPOINTER : begin
	    GenChar('*');
	    StabTypeNumber(tn^.toType);
	end;
	DTPROC : begin
	    StabProcType(tn);
	end;
	DTSET :	begin
	    GenChar('S');
	    StabTypeNumber(tn^.setRange);
	end;
	DTSUBRANGE : begin
	    GenChar('r');
	    StabTypeNumber(tn^.baseType);
	    StabSemicolon;
	    GenInteger(tn^.subMinOrd);
	    StabSemicolon;
	    GenInteger(tn^.subMaxOrd);
	end;
	DTRECORD : begin
	    GenChar('s');
	    GenInteger(CardDiv(SizeOf(tn),BYTESIZE));
	    StabFieldList(tn^.fieldList);
	    StabSemicolon;
	end;
	DTARRAY : begin
	    if tn^.indexType = nil then begin
		GenChar('A');
		StabTypeNumber(tn^.elementType);
	    end else begin
		GenChar('a');
		StabTypeNumber(tn^.indexType);
		StabSemicolon;
		StabTypeNumber(tn^.elementType);
	    end;
	end;
	DTENUMERATION : begin
	    GenChar('e');
	    enum := tn^.enumList^.first;
	    while enum <> nil do begin
		GenString(enum^.name);
		GenChar(':');
		GenInteger(enum^.enumOrd);
		StabCommaX;
		enum := enum^.next;
	    end;
	    StabSemicolon;
	end;
    end;
    if tn^.module <> nil then begin
	StabSemicolon;
    end else if tn^.opaqueName <> nil then begin
	StabSemicolon;
    end;
end;

procedure StabCheckType(tn : TypeNode);
begin
    if TraceStab then begin
	write(output,'StabCheckType: ');
	if tn = nil then begin
	    write(output,'tn=nil');
	end else begin
	    write(output,tn^.kind,' ',tn^.number,' ');
	    WriteString(output,tn^.name);
	end;
	writeln(output);
    end;
    if tn = nil then begin
	{ do nothing }
    end else if tn^.number = 0 then begin
	StabNamedType(tn^.name,tn);
    end else if tn^.kind = DTRENAME then begin
	StabCheckType(tn^.renameType);
    end;
end;

procedure StabCheckFieldList(fl : FieldList);
var
    fn : FieldNode;
    vn : VariantNode;
begin
    fn := fl^.first;
    while fn <> nil do begin
	if TraceStab then begin
	    write(output,'StabCheckFieldList: ');
	    WriteString(output,fn^.name);
	    writeln(output);
	end;
	StabCheckType(fn^.fieldType);
	if fn^.kind = FIELDVARIANT then begin
	    vn := fn^.variantList^.first;
	    while vn <> nil do begin
		StabCheckFieldList(vn^.fieldList);
		vn := vn^.next;
	    end;
	end;
	fn := fn^.next;
    end;
end;

procedure StabCheckProcType(tn : TypeNode);
var
    pn : ParamNode;
begin
    StabCheckType(tn^.funcType);
    if tn^.paramList <> nil then begin
	pn := tn^.paramList^.first;
	while pn <> nil do begin
	    StabCheckType(pn^.paramType);
	    pn := pn^.next;
	end;
    end;
end;


{ try to make sure dependent types are output before this one is }
procedure StabNamedType{(name : String; tn : TypeNode)};
var
    enum : EnumNode;
begin
    if TraceStab then begin
	write(output,'StabNamedType: ',tn^.kind,' ',tn^.number,' ');
	WriteString(output,name);
	writeln(output);
    end;
    tn := NamedType(tn);
    if tn^.number = 0 then begin
	tn^.number := NewTypeNumber;
	case tn^.kind of
	    DTINTEGER,
	    DTCHAR,
	    DTBOOLEAN,
	    DTREAL,