imc.mod

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

(*#@(#)imc.mod	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: imc.mod,v 1.5 84/06/06 12:22:05 powell Exp $
 ****************************************************************************)
module imc;
import unix;
from io import output, writef, sreadf, swritef;
from system import size, tsize, address, BITSPERWORD, BYTESPERWORD, MAXINT;
from memory import Allocate, Deallocate;
from parameters import NumParameters, GetParameter;
from strings import Compare, Assign, Append;
from stringtab import AddChar, NewString, String, CopyString, WriteString;
from list import List, AddToList;
from numtab import Number, LookUpNumber, DefineNumber,
    MAXBUILTINTYPES, DumpNumTab, traceNumtab;
from symtab import Symbol, TypeNode, EnumNode, LookUpSymbol, DefineSymbol,
	DataType, DumpSymTab, currScope, FieldNode, ParamNode,
	ModuleNode, PortNode, ConstNode, SetValue, ParamKind, SymbolKind,
	traceSymtab;
from porttab import DefinePort, DefineModule, DumpExports, CheckExports,
	currModule, tracePorttab, errorCount, autoMakeFlag, WatchModule,
	moduleList, logErrorsFlag, IgnoreModule, libraryCheckFlag,
	fatalErrorFlag;
from execute import AddArg, AddString, Execute, MAXARGS, ArgString;
from libfile import LIBFILENAME;

const
    BYTESIZE = BITSPERWORD div BYTESPERWORD;

    STABNMOD2 = 80;		(* = N_MOD2 in /usr/include/stab.h *)
    EXPORTSYMBOL = STABNMOD2;	(* nlist type for export symbol *)
    LOCALSYMBOL = 128;		(* nlist type for local symbol *)

    OBJECTMAGICNUMBER = 407B;	(* marker for first word of object *)
    ARCHIVEMAGICSTRING = "!<arch>\n";	(* marker for archive file *)
    ARCHIVEMAGICSTRINGSIZE = 8;
    ARCHIVEDIRECTORYSIZE = 60;

    OBJECTHEADERSIZE = 32;	(* size of a.out header *)
type
    ObjectHeader = record
	case boolean of
	TRUE : 		(* header for an object file *)
	    magic : integer;
	    textSize, dataSize, bssSize, symSize : cardinal;
	    entryPoint : cardinal;
	    textRelocSize, dataRelocSize : cardinal;
	|
	FALSE : 	(* header for an archive file *)
	    armagic : array [1..ARCHIVEMAGICSTRINGSIZE] of char;
	end;
    end;
    ArchiveDirectory = record
	name : array [1..16] of char;
	date : array [1..12] of char;
	usergroup : array [1..12] of char;	(* beware alignment! *)
	mode : array [1..8] of char;
	size : array [1..12] of char;		(* last 2 chars are `\n *)
    end;

    CharPtr = pointer @nocheck to array [0..MAXINT] of char;

    CharSet = set of char;
var
    moduleName : ArgString;
    errorMsg : array [1..100] of char;
    echoFlag, executeFlag : boolean;
    makeFlags : ArgString;
    inArchive : boolean;
    fileListIndex : cardinal;
    fileList : array [1..MAXARGS] of String;

procedure Panic(name, msg : array of char);
begin
    writef(output,"%s : %s\n",name,msg);
    halt;
end Panic;

procedure SaveArg(arg : array of char);
var
    i : cardinal;
begin
    inc(fileListIndex);
    i := 0;
    while (i < number(arg)) and (arg[i] # 0C) do
	AddChar(arg[i]);
	inc(i);
    end;
    fileList[fileListIndex] := NewString();
end SaveArg;

procedure BuildProc(retType : TypeNode) : TypeNode;
var
    tn : TypeNode;
    pn : ParamNode;
begin
    new(tn);
    tn^.kind := DTPROC;
    tn^.retType := retType;
    tn^.numParams := GetNumber();
    tn^.paramList := nil;
    SkipOver(';');
    while currChar # ';' do
	new(pn);
	if currChar in CharSet{'0'..'9'} then
	    pn^.name := nil;
	else
	    pn^.name := GetString();
	    SkipOver(':');
	end;
	pn^.paramType := GetType();
	SkipOver(',');
	pn^.kind := val(ParamKind,cardinal(GetNumber()));
	tn^.paramList := AddToList(tn^.paramList,pn);
	SkipOver(';');
    end;
    return tn;
end BuildProc;

procedure BuildRecord(tn : TypeNode);
var
    fn : FieldNode;
begin
    tn^.kind := DTRECORD;
    tn^.size := GetNumber();
    tn^.fieldList := nil;
    repeat
	new(fn);
	fn^.name := GetString();
	SkipOver(':');
	fn^.fieldType := GetType();
	SkipOver(',');
	fn^.offset := GetNumber();
	SkipOver(',');
	fn^.size := GetNumber();
	tn^.fieldList := AddToList(tn^.fieldList,fn);
	SkipOver(';');
    until currChar = ';';
    NextChar();
end BuildRecord;

procedure BuildEnum(tn : TypeNode);
var
    en : EnumNode;
begin
    tn^.kind := DTENUMERATION;
    tn^.enumCount := 0;
    tn^.enumList := nil;
    repeat
	inc(tn^.enumCount);
	new(en);
	en^.name := GetString();
	SkipOver(':');
	en^.enumOrd := GetNumber();
	en^.enumType := tn;
	tn^.enumList := AddToList(tn^.enumList,en);
	SkipOver(',');
    until currChar = ';';
    NextChar();
end BuildEnum;

(* GetType: Get a type pointer *)
procedure GetType():TypeNode;
var
    tn, retType, ignoreTn : TypeNode;
    indirectType : boolean;
begin
    if currChar = 'i' then
	repeat
	    NextChar();
	until currChar = ',';
	NextChar();
	indirectType := true;
    else
	indirectType := false;
    end;
    case currChar of
    | '0'..'9':
	tn := GetTypeNumber();
    | 'r':
	NextChar;
	new(tn);
	tn^.kind := DTSUBRANGE;
	tn^.baseType := GetType();
	SkipOver(';');
	tn^.subMinOrd := GetNumber();
	SkipOver(';');
	tn^.subMaxOrd := GetNumber();
    | 'a':
	NextChar;
	new(tn);
	tn^.kind := DTARRAY;
	tn^.indexType := GetType();
	SkipOver(';');
	tn^.elementType := GetType();
    | 'A':
	NextChar;
	new(tn);
	tn^.kind := DTARRAY;
	tn^.indexType := nil;
	tn^.elementType := GetType();
    | 'S':
	NextChar;
	new(tn);
	tn^.kind := DTSET;
	tn^.setRange := GetType();
    | 'o':
	NextChar;
	new(tn);
	tn^.kind := DTOPAQUE;
	tn^.opaqueName := GetString();
	if currChar = ',' then
	    NextChar();
	    ignoreTn := GetType();
	end;
	SkipOver(';');
    | 's':
	NextChar;
	new(tn);
	BuildRecord(tn);
    | 'f':
	NextChar;
	retType := GetType();
	SkipOver(',');
	tn := BuildProc(retType);
    | 'p':
	NextChar;
	tn := BuildProc(nil);
    | 'e':
	NextChar;
	new(tn);
	BuildEnum(tn);
    | '*':
	NextChar;
	new(tn);
	tn^.kind := DTPOINTER;
	tn^.toType := GetType();
    else
	DataError('Unknown type');
	tn := nil;
    end;
    if indirectType then
	SkipOver(';');
    end;
    return tn;
end GetType;

procedure BuildConst():ConstNode;
var
    cn : ConstNode;
    sv : SetValue;
    en : EnumNode;
begin
    new(cn);
    case currChar of
    | 'r':
	NextChar;
	cn^.kind := DTREAL;
	cn^.realVal := GetValue();
    | 'i':
	NextChar;
	cn^.kind := DTCARDINAL;
	cn^.cardVal := GetNumber();
    | 'b':
	NextChar;
	cn^.kind := DTBOOLEAN;
	cn^.boolVal := GetNumber();
    | 'c':
	NextChar;
	cn^.kind := DTCHAR;
	cn^.charVal := GetNumber();
    | 's':
	NextChar;
	cn^.kind := DTSTRING;
	SkipOver('''');
	loop
	    if currChar = '''' then
		NextChar;
		if currChar # '''' then
		    exit;
		end;
		AddChar('''');
	    else
		AddChar(currChar);
	    end;
	    NextChar;
	end;
	cn^.strVal := NewString();
    | 'S':
	NextChar;
	cn^.kind := DTSET;
	new(sv);
	sv^.setType := GetType();
	SkipOver(',');
	sv^.size := GetNumber();
	SkipOver(',');
	sv^.value := GetValue();
	cn^.setVal := sv;
    | 'e':
	NextChar;
	cn^.kind := DTENUMERATION;
	new(en);
	en^.enumType := GetType();
	SkipOver(',');
	en^.enumOrd := GetNumber();
	cn^.enumVal := en;
    else
	DataError('Unknown constant');
	cn := nil;
    end;
    return cn;
end BuildConst;

procedure DefineTypeNumber(number : cardinal) : Number;
var
    num : Number;
    tn : TypeNode;
begin
    tn := GetType();
    if not DefineNumber(num,number,0) then
	if num^.numType^.kind # DTOPAQUE then
	    swritef(errorMsg,'Type %d already defined',number);
	    DataError(errorMsg);
	else
	    (* update the type, but don't affect pointers to it *)
	    num^.numType^ := tn^;
	end;
    else
	num^.numType := tn;
    end;
    return num;
end DefineTypeNumber;

(* GetTypeNumber: Get the type corresponding to the type number *)
procedure GetTypeNumber():TypeNode;
var
    number : integer;
    num : Number;
    tn : TypeNode;
begin
    number := GetNumber();
    if currChar = '=' then
	NextChar();
	num := DefineTypeNumber(number);
    else
	num := LookUpNumber(number,0);
	if num = nil then
	    new(tn);
	    tn^.kind := DTOPAQUE;
	    if not DefineNumber(num,number,0) then
		swritef(errorMsg,'Missing type %d already defined',number);
		DataError(errorMsg);
	    else
		num^.numType := tn;
	    end;
	end;
    end;
    return num^.numType;
end GetTypeNumber;

var
    currEntry : CharPtr;
    currCharIndex : cardinal;
    currChar : char;

procedure NextChar();
begin
    currCharIndex := currCharIndex + 1;
    currChar := currEntry^[currCharIndex];
end NextChar;

procedure SkipOver(c : char);
var
    eligible : boolean;
    entry : CharPtr;
begin
    if currChar # c then
	swritef(errorMsg,'Expected "%c", found "%c"',c,currChar);
	DataError(errorMsg);
    else
	eligible := currChar in CharSet{',', ';'};
	NextChar;
	if eligible and (currChar = '?') then
	    (* continuation: go to the next entry *)
	    entry := CharPtr(stringTab+symTab^[symTabIndex].name-4);
	    inc(symTabIndex);
	    InitChar(entry);
	end;
    end;
end SkipOver;

const
    MAXDATAERRORS = 100;
var
    dataErrorCount : cardinal;
procedure DataError(msg : array of char);
begin
    writef(output,'Error in symbol table information: %s: char %d "%s"\n',
	msg,currCharIndex,currEntry^);
    inc(dataErrorCount);
    if dataErrorCount > MAXDATAERRORS then
	Panic('Too many errors','files are messed up');
    end;
end DataError;

procedure GetNumber() : integer;
var
    n : integer;
    negative : boolean;
begin
    n := 0;
    if not (currChar in CharSet{'0'..'9','-'}) then
	DataError('Number expected');
	return n;
    end;
    if currChar = '-' then
	negative := true;
	NextChar;
    else
	negative := false;
    end;
    while currChar in CharSet{'0'..'9'} do
	n := n * 10 + integer(ord(currChar) - ord('0'));
	NextChar;
    end;
    if negative then
	n := -n;
    end;
    return n;
end GetNumber;

procedure GetString() : String;
begin
    if not (currChar in CharSet{'a'..'z','A'..'Z'}) then
	DataError('Identifier expected');
	return nil;
    end;
    while currChar in CharSet{'a'..'z','A'..'Z','0'..'9','_'} do
	AddChar(currChar);
	NextChar;
    end;
    return NewString();
end GetString;