-- CheckCodeImpl.mesa  
-- Last edited by Sweet on 22-Aug-83 14:02:53

DIRECTORY
  BcdDefs,
  BcdOps,
  CatchFormat,
  Environment,
  Exec,
  FileName,
  FileTransfer,
  Format,
  Heap,
  Mopcodes,
  MSegment,
  OpTableDefs,
  PrincOps,
  Stream,
  String,
  SymbolPack,
  Symbols,
  SymbolSegment,
  SymbolTable,
  Table;

CheckCodeImpl: PROGRAM
  IMPORTS
    mySymbols: SymbolPack, Exec, FileName, FileTransfer, Format, 
    Heap, MSegment, OpTableDefs, Stream, String =
  BEGIN OPEN Symbols;
  
  IgnoreReason: TYPE = {long, old, binder, defs, table, other};
  why: ARRAY IgnoreReason OF LONG CARDINAL;

  BYTE: TYPE = Environment.Byte;
  
  SymbolHandle: TYPE = LONG POINTER TO FRAME [SymbolPack];

  exec: Exec.Handle _ NIL;
  conn: FileTransfer.Connection _ NIL;
  vfn: FileName.VFN _ NIL;

  buffer: LONG POINTER _ NIL;
  bufferPages: Environment.PageCount _ 100;
  bufferSegment: MSegment.Handle _ NIL;
  last: CARDINAL = CARDINAL[bufferPages*Environment.bytesPerPage];
  currentDir: LONG STRING _ NIL;

  bcd: BcdOps.BcdBase _ NIL;
  mtb, sgb, enb: BcdDefs.Base _ NIL;
  mth: BcdOps.MTHandle _ NIL;
  sgh: BcdOps.SGHandle _ NIL;

  symHeader: LONG POINTER TO SymbolSegment.STHeader _ NIL;
  
  codebase: PrincOps.PrefixHandle;
  code: LONG POINTER TO PACKED ARRAY [0..0) OF BYTE;  
  
  totalFiles, totalBad, totalIgnored: LONG CARDINAL _ 0;
  
  -- Exec window output
  execProc: Format.StringProc;

  PutCR: PROC = {Format.CR[execProc]};
  PutString: PROC [s: LONG STRING] = {execProc[s]};
  PutSubString: PROC [ss: String.SubString] = {Format.SubString[execProc, ss]};
  PutLine: PROC [s: LONG STRING] = {execProc[s]; Format.CR[execProc]};
  PutChar: PROC [c: CHARACTER] = {Format.Char[execProc, c]};
  PutDecimal: PROC [n: INTEGER] = {Format.Decimal[execProc, n]};
  PutLongDecimal: PROC [n: LONG INTEGER] = {Format.LongDecimal[execProc, n]};
  PutNumber: PROC [n: INTEGER, f: Format.NumberFormat] = {
    Format.Number[execProc, n, f]};
  PutOctal: PROC [n: CARDINAL] = {
    Format.Number[execProc, n, [base: 8, zerofill: FALSE, unsigned: TRUE, columns: 1]]};
  
  -- a few procs stolen from SymbolCache
  
  InstallTable: PROC [base: SymbolTable.Base, sym: LONG POINTER] = {
    SetBases[base, sym];  base.notifier _ base.NullNotifier};

  SetBases: PROC [base: SymbolTable.Base, b: LONG POINTER] = {
    tB: Table.Base = LOOPHOLE[b];
    p: LONG POINTER TO SymbolSegment.STHeader = b;
    q: LONG POINTER TO SymbolSegment.FGHeader;
    base.cacheInfo _ NIL;
    base.hashVec _ b+p.hvBlock.offset;
    base.ht _ DESCRIPTOR[
      b+p.htBlock.offset, p.htBlock.size/SIZE[Symbols.HTRecord]];
    base.ssb _ b + p.ssBlock.offset;
    base.seb _ tB + p.seBlock.offset;
    base.ctxb _ tB + p.ctxBlock.offset;
    base.mdb _ tB + p.mdBlock.offset;
    base.bb _ tB + p.bodyBlock.offset;
    base.tb _ tB + p.treeBlock.offset;
    base.ltb _ tB + p.litBlock.offset;
    base.extb _ tB + p.extBlock.offset;
    base.mdLimit _ FIRST[Symbols.MDIndex] + p.mdBlock.size;
    base.extLimit _ FIRST[SymbolSegment.ExtIndex] + p.extBlock.size;
    base.mainCtx _ p.outerCtx;  base.stHandle _ p;
    IF p.fgRelPgBase = 0 
      THEN {base.sourceFile _ NIL; base.fgTable _ NIL}
      ELSE {
	offset: CARDINAL = LOOPHOLE[
	  @(NIL[POINTER TO SymbolSegment.FGHeader]).sourceFile];
	q _ b + p.fgRelPgBase*Environment.wordsPerPage;
	base.sourceFile _ (b + p.fgRelPgBase*Environment.wordsPerPage) + offset;
	base.fgTable _ DESCRIPTOR[
	    b + p.fgRelPgBase*Environment.wordsPerPage + q.offset, q.length]}};


  -- end of SymbolPack stuff

    
  Octal4: Format.NumberFormat = [
    base: 8, unsigned: TRUE, zerofill: FALSE, columns: 4];
  Octal6: Format.NumberFormat = [
    base: 8, unsigned: TRUE, zerofill: FALSE, columns: 6];

  PutHash: PROC [symbols: SymbolHandle, hti: Symbols.HTIndex] = {
    ss: String.SubStringDescriptor;
    IF hti = Symbols.HTNull THEN PutString["[Anon]"L]
    ELSE {
      symbols.ops.SubStringForHash[@ss, hti];
      PutSubString[@ss]}};

  CheckRemoteCode: Exec.ExecProc = {
    ENABLE {
      ABORTED => GO TO aborted;
      FileTransfer.Error --[code]-- =>
        SELECT code FROM
          retry => GOTO timedOut;
          ENDCASE => GOTO fileTransferProblem;
      UNWIND => Finalize[]};
    exec _ h;
    execProc _ exec.OutputProc[];
    Initialize[];
    OpenConnection[];
    DoChecks[];
    Finalize[];
    outcome _ normal;
    EXITS
      aborted => {outcome _ abort; Finalize[]; PutCR[]; PutLine["...aborted"L]};
      timedOut => {
        outcome _ error;
        Finalize[];
        PutCR[];
        PutLine["...connection timed out!"L]};
      fileTransferProblem => {
        outcome _ error;
        Finalize[];
        PutCR[];
        PutLine["...FileTransfer problem!"L]}};

  Initialize: PROC = {
    PutHeading[];
    conn _ NIL;
    bufferSegment _ MSegment.Create[pages: bufferPages, release: []];
    buffer _ MSegment.Address[bufferSegment];
    totalFiles _ totalBad _ totalIgnored _ 0;
    currentDir _ Heap.systemZone.NEW[StringBody[200]];
    why _ ALL[0]};

  Finalize: PROC = {
    IF bufferSegment # NIL THEN {
      MSegment.Delete[bufferSegment]; bufferSegment _ buffer _ NIL};
    IF currentDir # NIL THEN Heap.systemZone.FREE[@currentDir];
    IF vfn # NIL THEN {FileName.FreeVFN[vfn]; vfn _ NIL};
    CloseConnection[]};

  PutHeading: PROC = {PutCR[]; PutLine["Remote Code Checker"L]; PutCR[]};

  OpenConnection: PROC = {
    conn _ FileTransfer.Create[];
    conn.SetProcs[clientData: NIL, messages: PutMessages];
    };
    
  PutMessages: FileTransfer.MessageProc = {
    IF level = fatal THEN {
      PutString["FileTransfer error: "L];
      IF s1 # NIL THEN PutString[s1];
      IF s2 # NIL THEN PutString[s2];
      IF s3 # NIL THEN PutString[s3];
      IF s4 # NIL THEN PutString[s4]}};

  CloseConnection: PROC = {
    IF conn # NIL THEN {conn.Close[]; conn.Destroy[]; conn _ NIL}};

  verbose: BOOLEAN _ FALSE;

  DoChecks: PROC = {
    token, switches: LONG STRING;
    Stats: PROC = {
      name: ARRAY IgnoreReason OF STRING = [
        long: " too long"L, old: " old bcd version"L, binder: " binder output"L,
	defs: " defs"L, table: "table compiled"L, other: " other"L];
      PutCR[];
      PutCR[];
      PutLongDecimal[totalBad];
      PutString[" bad files out of "L];
      PutLongDecimal[totalFiles];
      PutLine[" files"L];
      PutLongDecimal[totalIgnored];
      PutLine[" were ignored"L];
      FOR r: IgnoreReason IN IgnoreReason DO
        IF why[r] # 0 THEN {
	  PutLongDecimal[why[r]];
	  PutLine[name[r]]};
	ENDLOOP;
      };

    verbose _ FALSE;
    DO
      ENABLE ABORTED => Stats[];
      sense: BOOLEAN _ TRUE;
      [token: token, switches: switches] _ exec.GetToken[];
      IF token = NIL AND switches = NIL THEN EXIT;
      IF switches # NIL THEN FOR n: CARDINAL IN [0..switches.length) DO
        SELECT switches[n] FROM 
          'v, 'V => {verbose _ sense; sense _ TRUE};
	  '-, '~ => sense _ ~sense;
	  ENDCASE;
	ENDLOOP;
      switches _ Exec.FreeTokenString[switches];
      IF token # NIL THEN
        Check[token ! UNWIND => token _ Exec.FreeTokenString[token]];
      token _ Exec.FreeTokenString[token];
      ENDLOOP;
    Stats[]};

  Check: PROC [token: LONG STRING] = {
    stream: Stream.Handle _ NIL;
    vfn _ FileName.AllocVFN[token]; 
    stream _ conn.ReadStream[vfn, NIL, FALSE, remote];
    WHILE stream # NIL DO
      ENABLE FileTransfer.Error => 
        IF code = skip OR code = spare1 THEN LOOP;
      stream.options.signalEndOfStream _ TRUE;
      CheckFile[stream];
      stream _ FileTransfer.ReadNextStream[stream];
      ENDLOOP;
    FileName.FreeVFN[vfn]; vfn _ NIL};

  CheckFile: PROC [stream: Stream.Handle] = {
    source: FileTransfer.FileInfo;
    nameShown: BOOLEAN _ FALSE;
    problems: BOOLEAN;
    
    Complain: PROC [text: LONG STRING, reason: IgnoreReason] = {
      IF verbose THEN {
        IF ~nameShown THEN PutString[source.body];
        PutLine[text]}
      ELSE IF nameShown THEN PutCR[];
      totalIgnored _ totalIgnored + 1;
      why[reason] _ why[reason] + 1};
      
    BEGIN -- to make Complain visible in EXITS clause
    more: BOOLEAN _ TRUE;
    IF exec.CheckForAbort[] THEN ERROR ABORTED;
    source _ FileTransfer.GetStreamInfo[stream];
    IF ~String.EquivalentString[source.directory, currentDir] THEN {
      PutLine[source.directory];
      currentDir.length _ 0;
      String.AppendString[currentDir, source.directory]};
    IF (((totalFiles _ totalFiles + 1) MOD 10) = 0) OR verbose THEN {
      IF ~verbose THEN {
        PutString["  Checking file "L];
        PutLongDecimal[totalFiles];
        PutString[": "L]};
      PutString[source.body];
      nameShown _ TRUE};
    [] _ stream.GetBlock[
      [buffer, 0, last] ! Stream.EndOfStream => {more _ FALSE; CONTINUE}];
      IF more THEN GO TO tooLong;
      bcd _ LOOPHOLE[buffer, BcdOps.BcdBase];
      IF bcd.definitions THEN GO TO defs;
      IF bcd.versionIdent # BcdDefs.VersionID THEN GOTO obsoleteBcd;
      IF bcd.nConfigs # 0 THEN GOTO binderBcd;
      IF bcd.nPages > bufferPages THEN GOTO tooLong;
      mtb _ LOOPHOLE[bcd + bcd.mtOffset];
      mth _ @mtb[FIRST[BcdDefs.MTIndex]];
      sgb _ LOOPHOLE[bcd + bcd.sgOffset];
      enb _ LOOPHOLE[bcd + bcd.enOffset];
      sgh _ @sgb[mth.code.sgi];  -- Bcd's code segment table entry
      IF sgh.pages > bufferPages THEN GOTO tooLong;
      IF mth.tableCompiled THEN GOTO table;  
      IF sgh.file # BcdDefs.FTSelf THEN GOTO punt; 
      codebase _ LOOPHOLE[buffer + (sgh.base - 1)*Environment.wordsPerPage];
      codebase _ codebase + mth.code.offset;
      code _ LOOPHOLE[codebase];
      sgh _ @sgb[mth.sseg];  -- Bcd's symbol segment table entry
      IF sgh.base + sgh.pages > bufferPages THEN GOTO tooLong;
      IF sgh.file # BcdDefs.FTSelf THEN GOTO punt;  -- tablecompiled, or ...
      symHeader _ LOOPHOLE[buffer + (sgh.base - 1)*Environment.wordsPerPage];
      IF symHeader.versionIdent # SymbolSegment.VersionID THEN GOTO badSymbols;
      InstallTable[mySymbols, symHeader];
      problems _ ExamineModule[
        file: source.body,
	nameShown: nameShown,
	entries: @enb[mth.entries],
	symbols: mySymbols];
      IF problems THEN {totalBad _ totalBad + 1; PutCR[]}
      ELSE IF nameShown THEN PutCR[];
    EXITS
      tooLong => {Complain[" too long"L, long]};
      obsoleteBcd => {Complain[" obsolete BCD format"L, old]};
      binderBcd => {Complain[" binder output"L, binder]};
      defs => {Complain[" definitions"L, defs]};
      punt => {Complain[" other problem"L, other]};
      table => {Complain[" table compiled"L, table]};
      badSymbols => {Complain[" bad symbols"L, other]};
    END};
    
  -- problem specific stuff
  
  ExamineModule: PROC [
      file: LONG STRING, nameShown: BOOLEAN,
      entries: BcdOps.ENHandle, 
      symbols: SymbolHandle] 
    RETURNS [problems: BOOLEAN _ FALSE] = 
    BEGIN
    catchEV: CatchFormat.CatchEV = LOOPHOLE[codebase.header.catchCode/2];
    catchEntry: CatchFormat.CatchEVHandle = @codebase[catchEV];
    
    OneBody: PROC [bti: Symbols.BTIndex] RETURNS [BOOLEAN] = {
      start, nBytes: CARDINAL;
      WITH b: symbols.bb[bti] SELECT FROM
        Callable => IF ~b.inline THEN {
	  WITH info: b.info SELECT FROM
	    External => nBytes _ info.bytes;
	    ENDCASE;
	  WITH cc: b SELECT FROM
	    Catch => start _ catchEntry[cc.index];
	    ENDCASE => start _ entries.initialPC[b.entryIndex];
	  problems _ problems OR ExamineBody[
	    start, nBytes, symbols, LOOPHOLE[bti], file, nameShown OR problems]};
	ENDCASE;
      RETURN[FALSE]};
      
    [] _ symbols.ops.EnumerateBodies[Symbols.RootBti, OneBody];
    IF problems THEN PutCR[];
    END;
    
  Pair: TYPE = RECORD [fill: BYTE, first, last: [0..16)];

  ExamineBody: PROC [
      start, nBytes: CARDINAL, 
      symbols: SymbolHandle, bti: Symbols.CBTIndex,
      file: LONG STRING, nameShown: BOOLEAN] 
    RETURNS [problems: BOOLEAN _ FALSE] = {
    catch: BOOLEAN = symbols.bb[bti].nesting = Catch;
    inst: BYTE;
    il: CARDINAL;
    pc: CARDINAL;
    none: CARDINAL = CARDINAL.LAST;
    rilOffset, rigOffset, linkLoaded: CARDINAL _ none;
    offset: CARDINAL;
    extra: CARDINAL;
    IF catch THEN
      IF code[start] = Mopcodes.zJ2 THEN pc _ start + 2
      ELSE pc _ start
    ELSE pc _ start + 1; 
    WHILE pc < start + nBytes DO
      OPEN Mopcodes;
      inst _ code[pc];
      BEGIN -- to set up bingo
      BEGIN -- to set up checkLocal and checkGlobal
      SELECT inst FROM
        zRLI00, zRLI01, zRLI02, zRLI03 => {
	  rilOffset _ 0; rigOffset _ linkLoaded _ none; extra _ 0};
	zRLIP, zRLIPF => {
	  pair: Pair; 
	  extra _ 0;
	  pair _ LOOPHOLE[code[pc+1]]; 
	  rigOffset _ linkLoaded _ none; rilOffset _ pair.first};
	zRLILP, zRLILPF => {
	  pair: Pair; 
	  extra _ 1;
	  pair _ LOOPHOLE[code[pc+1]]; 
	  rigOffset _ linkLoaded _ none; rilOffset _ pair.first};
	zRGIP => {
	  pair: Pair; 
	  extra _ 0;
	  pair _ LOOPHOLE[code[pc+1]]; 
	  rilOffset _ linkLoaded _ none; rigOffset _ pair.first};
	zRGILP => {
	  pair: Pair; 
	  extra _ 1;
	  pair _ LOOPHOLE[code[pc+1]]; 
	  rilOffset _ linkLoaded _  none; rigOffset _ pair.first};
	zLLKB => {
	  linkLoaded _ LOOPHOLE[code[pc+1]]; 
	  rilOffset _ rigOffset _  none};
	zDUP => IF linkLoaded # none THEN GO TO bingo;
	IN [zSLD0..zSLD6] => {offset _ inst - zSLD0; GO TO checkLocal};
	zSLD8 => {offset _ 8; GO TO checkLocal};
	zSLDB, zPLDB => {offset _ code[pc+1]; GO TO checkLocal};
	zPLD0 => {offset _ 0; GO TO checkLocal};
	zSGDB => {offset _ code[pc+1]; GO TO checkGlobal};
	ENDCASE => rilOffset _ rigOffset _ linkLoaded _ none;
      EXITS
        checkLocal => {
	  IF offset >= rilOffset AND offset <= rilOffset + extra THEN
	    GO TO bingo;
	  rilOffset _ rigOffset _ linkLoaded _ none};
        checkGlobal => {
	  IF offset >= rigOffset AND offset <= rigOffset + extra THEN
	    GO TO bingo;
	  rilOffset _ rigOffset _ linkLoaded _ none};
      END;
      EXITS
        bingo => {
	  IF ~nameShown THEN PutString[file];
	  PutString["*****"L];
	  PutHash[symbols, symbols.ops.HashForSe[symbols.bb[bti].id]];
	  PutChar['(];
	  PutOctal[pc];
	  PutChar[')];
	  RETURN[TRUE]};
      END;
      il _ OpTableDefs.InstLength[inst];
      IF il = 0 THEN EXIT;
      pc _ pc + il;
      ENDLOOP;

    };

  -- User niceness

  CheckHelp: Exec.ExecProc = {
    h.OutputProc[][
      "This command takes all bcds on a remote directory and looks for bad code
    
    	CheckRemoteCode.~ remotefilename(/v for verbose)"L]};

  -- MAIN BODY CODE

  RegisterSelf: PROC = {
    Exec.AddCommand[name: "CheckCode.~"L, proc: CheckRemoteCode, help: CheckHelp]};

  RegisterSelf[];

  END.