SECTION "map"

GET "LibHdr"

MANIFEST
$( t.hunk	      = 1000
   t.end	      = 1002
   secword	      = 12345
   libword	      = 23456
   freeblock	      = #x40000000
   blocklength	      = #x3FFFFF
   unsetglobal.number = 33
   linelength	      = 80
   JSR.PROFILE	      = #X0064967F
   ENTRYWORD	      = #X1744442F
   maxaddress	      = 640*1024
$)

GLOBAL
$( g0		      : 0
   unsetglobal	      : unsetglobal.number
$)

LET backtrace() BE
$( LET firstloc = 0	  // first local variable in stack
   stackbase!4 := ((@firstloc) << 2)+52
	    // store resumption ptr for current coroutine
   writes("*N*NBacktrace called*N")
   $( LET base = stackbase+6
      LET p = (stackbase!4-52) >> 2  // resumption ptr for this coroutine
      LET topframe = p-1

      IF topframe>stackbase!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(p!(-1), p)
	 writes("  ")
	 FOR j = p TO topframe DO
	 $( writearg(!j, p)
	    IF ((j-p) REM 5)=4 & (j~=topframe)
	       THEN writes("*n                            ")
	 $)
	 newline();
	 topframe := p-3
	 p := (p!(-2)-52) >> 2	   // next frame down
	 IF p=base THEN $( writes("Base of stack*N")
			   BREAK
			$)
	 UNLESS base<p<=topframe THEN
	 $( writef("Improper link %X8 %X8 %X8*N", base, p, topframe)
	    BREAK
	 $)
	 IF topframe-p>50 THEN topframe := p+50  // not more than 50 args
      $)

   $)

   writes("*NEnd of backtrace*N*N")
$)

AND writefname(n, p) BE
   TEST n=-1
      THEN writes("ROOT      ")
      ELSE writearg(n, p)  // function name


AND mapstore() BE
$( LET g = @G0
   LET nglobs = G0
   LET column = 0
   LET p = blocklist

   writes("*N*NMapstore called*N")

   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
      IF g!t~=unsetglobal | t=unsetglobal.number THEN
      $( IF column>linelength-20 THEN
	 $( newline()
	    column := 0
	 $)
	 TEST t>=1000
	    THEN writef("%i4: ",t)
	    ELSE writef("G%I3: ", t)
	 writearg(g!t, 0)
	 writes("   ")
	 column := column+20
      $)


   writes("*N*NMemory blocks:*N")

   UNTIL !p = 0 DO
   $( writef("*n%x6/%x6: ", p+1, p+1 << 2)
      TEST (!p & freeblock)=0
      THEN  // used block
      $( TEST g = p+1
	    THEN writes("Global vector*N")
	 ELSE TEST stackbase = p+1
	    THEN writes("Current stack*N")
	 ELSE TEST p!1=t.hunk
	    THEN $( LET q = p+3
		    LET column = 0
		    writes("Program code*N")
		    UNTIL !q=t.end DO
		    $( TEST (!q = entryword) |
			    (q!-3 = libword) |
			    (!q = jsr.profile)
		       THEN
		       $( IF column>=linelength-10 THEN
			  $( newline()
			     column := 0
			  $)
			  TEST !q = jsr.profile THEN
			  $( LET count = 1!q
			     writef( "  %x6:[ ~ %IA]" , q , count )
			     q := q+1
			  $)
			  ELSE
			     writef("  %x6/%x6: %s", q, q<<2, q-2)
			  column := column+24
		       $)
		       ELSE IF !q=secword THEN
		       $( writef("*n  %x6/%x6: Section %S*N", q, q<<2, q+1)
			  column := 0
		       $)
		       q := q+1
		    $)
		    newline()
		 $)
	 ELSE writef("Allocated Block of %N. BCPL words*N",
					 (!p & blocklength)-1 )
      $)

      ELSE  // freeblock
	 writef("Free Block of %N. BCPL words*N", (!p & blocklength)-1 )

      p := p+(!p & blocklength)  // next block
   $)
   writes("*NEnd of mapstore*N*N")
$)


AND writearg(n,p) BE  // WRITES a hex no./function name in a 10 char field
$( // P is BCPL stack pointer
   LET f = (n>>2)-2

   IF 8<f<=maxaddress
   THEN IF (f!2=entryword | f!(-1)=libword) & (f%0=7)
	THEN $( writef("%s   ", f)
		RETURN
	     $)

   IF -1000<n<1000 & n~=0 THEN
   $( WRITEF("%X3(%I4) ", N, N)
      RETURN
   $)

   IF p+2<=n<=p+52 THEN  // does n point to an item in this stack frame?
			 // (first 50 args)
   $( n := n-p-1
      writef("-> Arg%I2  ", n)
      RETURN
   $)

   writef("%x8  ", n)
$)

