SECTION "map"

GET "LibHdr"

STATIC {
// Version of 19 Feb 88 12:00:00
   dummy = VersionMark;
   version = 1*256 + 5 }

MANIFEST {
   SectionStart       = #x4c504342;
   StartRelocation    = #x12345678;
   EndRelocation      = #x87654321;
   EndMark	      = 1002;
   HunkMark	      = 1001;
   LineLength	      = 80;
   UnsetGlobalMask    = #xFFFF0000;
   UnsetGlobalValue   = #xAE950000;
   PCMask	      = #x03FFFFFC }

GLOBAL { g0: 0 };

LET BackTrace() BE {
   LET firstLoc = 0	  // first local variable in stack
   LET sb = stackBase;
   stackBase!4 := Level();
   WriteS("*NBacktrace called*N")

   {  LET base = (sb+6)<<2
      LET lastP = sb!4;
      LET newP = ?
      LET p = VCAR[lastP+4]
      LET topFrame = lastP-4

      TEST sb!5 = -1 THEN
	 WriteS("*NRoot stack:*N")
      ELSE {
	 NewLine()
	 WriteArg(sb!5, p)
	 WriteS(" coroutine stack:*N") }

      IF topFrame>[(sb!2)<<2] THEN
	 WriteS("WARNING: Stack has overflowed or been corrupted*N");

      WriteS("*NStack-frame     Function    Arg 1     Arg 2     Arg 3     .....*N")

      FOR i = 1 TO 50 DO {
	 WriteF("%x6/%x6:  ", p, p>>2)	// stack frame
	 WriteFName(VCAR p, p)
	 WriteS("  ")
	 FOR j = p+16 TO topFrame BY 4 DO {
	    WriteArg(VCAR j, p)
	    IF ((j-p-16) REM 20)=16 & (j~=topFrame) THEN
	       WriteS("*n                            ") }
	 NewLine();
	 topFrame := p-4;
	 newP := VCAR[p+4]
	 IF newP=p THEN { WriteS("Base of stack*N"); BREAK };
	 p := newP;
	 UNLESS base<=p<=topFrame THEN {
	    WriteF("Improper link %X8 %X8 %X8*N", base, p, topFrame);
	    BREAK }
	 IF topFrame-p>200 THEN topFrame := p+200 } // not more than 50 args
      sb := sb!1 } REPEATUNTIL sb=-1;
   WriteS("*NEnd of backtrace*N") }

AND WriteFName(n, p) BE
   TEST n=-1 THEN
      WriteS("ROOT      ")
   ELSE
      WriteArg(n, p)  // function name


AND WriteArg(n,p) BE {
// WriteS a hex no./function name in a 10 char field
// P is BCPL stack pointer
   LET f = n-8

   IF #x1000<f<=topOfStore & 0%f=7 & VCAR[f-4]=-1 THEN {
      WriteF("%s   ", f>>2); RETURN };

   IF -1000<n<1000 THEN {
      WriteF("%x3(%i4) ", n, n); RETURN };

   p := p>>2;
   IF p+4<=n<=p+54 THEN {
     // does n point to an item in this stack frame? (first 50 args)
      n := n-p-3
      WriteF("-> Arg%I2  ", n)
      RETURN }

   WriteF("%x8  ", n) }

AND MapStore() BE {
   LET g = @G0
   LET nglobs = G0
   LET column = 0
   LET p = blockList

   WriteS("*NMapstore called*N")

   DescribeCode(loadPoint);
   TEST ug<=G0<=10000 THEN
      WriteF("*N%N globals allocated*N", G0)
   ELSE {
      WriteS("Global zero is corrupted*N"); nglobs := 250 };

   WriteF("*NValues set in Global Vector (%X6/%X6):*N", g, g<<2);

   FOR t = 0 TO nglobs DO {
      LET val = g!t;
      IF [val&UnsetGlobalMask]~=UnsetGlobalValue THEN {
	 IF column>LineLength-20 THEN { NewLine(); column := 0 };
	 TEST t>=1000
	    THEN WriteF("%i4: ",t)
	    ELSE WriteF("G%I3: ", t);
	 WriteArg(val, 0);
	 WriteS("   ");
	 column := column+20 } }

 /*
   WriteS("*n*nMemory blocks:")
   UNTIL !p=0 DO {
      LET len = !p;
      WriteF("*n%x6/%x6: ", p+1, (p+1)<<2)
      TEST len<0 THEN { // used block
	 TEST g = p+1 THEN
	    WriteS("Global vector")
	 ELSE TEST stackbase = p+1 THEN
	    WriteS("Current stack")
	 ELSE TEST p!1=HunkMark THEN
	    DescribeCode(p)
	 ELSE
	    WriteF("Allocated Block of %N BCPL words", -len-1);
	 len := -len }

      ELSE  // freeblock
	 WriteF("Free Block of %N BCPL words", len-1)

      p := p+len }  // next block */

   WriteS("*NEnd of mapstore*N") }

AND DescribeCode(q) BE {
   LET column = 0;
   LET sectionEnd = q;
   WriteS("Program code")
   UNTIL q>=sectionEnd & !q=EndMark DO {
      LET word = !q;
      TEST q>=sectionEnd & word=SectionStart THEN {
	 LET name = VEC 2
	 AND date = VEC 2
	 AND time = VEC 2
	 AND unsetstring = "<unset>";
	 LET namel = 8;
	 LET versionWord = q!9;
	 sectionEnd := q+[(q!1)>>2];
	 FOR i = 0 TO 7 DO {
	    LET c = q%(i+8);
	    IF c=0 & namel=8 THEN { namel := i; BREAK };
	    name%(i+1) := c }
	 name%0 := namel;
	 TEST q%16='<' THEN
	    date, time := unsetstring, unsetstring
	 ELSE {
	    FOR i = 0 TO 8 DO {
	       date%(i+1) := q%(i+16);
	       time%(i+1) := q%(i+26) };
	    date%0 := 9;
	    time%0 := 8 };
	 WriteF("*n*n%X6  Section %s", q<<2, name);
	 IF q!11=-1 & q%48=7 THEN {
	    LET local = q!10;
	    IF VCAR local = VersionMark THEN {
	       LET n = VCAR(local+4);
	       WriteF("  version %n.%n", n>>8, n&255) } }
	 WriteF("*n    compiled on %s at %s", date, time);
	 IF versionWord~=0 THEN
	    WriteF(" using CG version %n.%n",
		     versionWord>>24, (versionWord>>16)&255);
	 NewLine();
	 q := q+10;
	 column := 0 }

      ELSE TEST q=SectionEnd THEN // skip global initialisations
	 q := q+2 REPEATWHILE (-1)!q~=0

      ELSE TEST q>=SectionEnd & word=StartRelocation THEN
	 q := q+1 REPEATWHILE !q~=EndRelocation

      ELSE TEST word=-1 & q%4=7 THEN {
	 LET procStart = q+2;
	 IF [(!procstart)>>24]=0 THEN procStart := procStart+1;
	 IF column>=LineLength-16 THEN { NewLine(); column := 0 };
	 WriteF("  %x6: %s", procStart<<2, q+1);
	 column := column+17;
	 q := procStart }

      ELSE q := q+1 }

   NewLine() }


MANIFEST {
   Error_IllegalInstruction = #x80000000
   Error_PrefetchAbort	    = #x80000001
   Error_DataAbort	    = #x80000002
   Error_AddressException   = #x80000003
   Error_UnknownIRQ	    = #x80000004
   Error_BranchThroughZero  = #x80000005

   Error_FPBase 	    = #x80000200
   Error_FPLimit	    = #x80000300 }

LET Abort(n) BE {
   LET pc = (VCAR[Level()+12])&PCMask;
   IF n~=0 THEN {
      SWITCHON n INTO {
	 CASE Error_IllegalInstruction:WriteS("*nIllegal Instruction"); ENDCASE
	 CASE Error_PrefetchAbort:     WriteS("*nPrefetch Abort"); ENDCASE
	 CASE Error_DataAbort:	       WriteS("*nData Abort"); ENDCASE
	 CASE Error_AddressException:  WriteS("*nAddress Exception"); ENDCASE
	 DEFAULT:
	    {  LET v = VEC 64;
	       TKRErr(v, 255);
	       {  LET n = v%0;
		  WHILE n>0 & (v%n='*C' | v%n='*N') DO n := n-1;
		  v%0 := n };
	       WriteF("*nAbort %x8: %s", n, v) } };

      WriteF(" at %x8", pc) };
   IF (pc&UnsetGlobalMask)=(UnsetGlobalValue&PCMask) THEN
      WriteF("*nIs Global %N defined?", [(pc&~UnsetGlobalMask)>>2]-1);
   BackTrace();
   MapStore();
   Stop(256) }
