!Master diagnostic routine for VAX IMP
%control 0

%system   %routine %spec  EXIT (%integer status)
%external %routine %spec  PHEX (%integer n)
%external %predicate %spec  PROBER (%integer add, len)
%external %integer %function %spec  IN STREAM
%external %integer %function %spec  OUT STREAM
%external %string(127) %function %spec  IN FILE NAME
%external %string(127) %function %spec  OUT FILE NAME
%external %string(127) %function %spec  SYSMESS (%integer n)

%constinteger    stx char    = 2
!!!%externalintegerspec alpha mode ;         !for graphics

%external %integer %spec  eventz         %alias "IMP$L_EVENT"
%external %integer %spec  sub eventz     %alias "IMP$L_SUBEVENT"
%external %integer %spec  event infoz    %alias "IMP$L_EVENTINF"
%external %string(255) %spec  event text %alias "IMP$S_EVENTTXT"
%record %format  event fm (%integer event, sub, extra, %string(255) text)


%external %record(event fm) %map  V8EVENT %alias "IMP$_EVENT"
   %result == record(addr(eventz))
%end

%external %integer %function  EVENT
   ! Pre V8 events
   %result = eventz
%end

%external %integer %function  SUB EVENT
   %result = sub eventz
%end

%external %integer %function  EVENT INFO
   %result = event infoz
%end

%external %routine  MDIAG %alias "IMP$MDIAG" (%integer fp, event, sub, extra)

   %record %format  proc diag fm (%c
      %short       size, line,
      %integer     limit,
      %string(31)  name           %c
   )
   %record %format  var diag fm (%c
      %byte        type, base,
      %integer     disp,
      %string(31)  name          %c
   )
   %record %format  gla fm (%c
      %integer    un1, un2,
      %string(3)  id, 
      %integer    code, diags, lines,
      %byte       null, spare,
      %integer    envir     %c
   )

   %const %integer  integers  = 1,
                    reals     = 2,
                    strings   = 3,
                    records   = 4,
                    bytes     = 5,
                    shorts    = 6,
                    longints  = 7,
                    longreals = 8

   %record(gla fm) %name  g
   %record(proc diag fm) %name  p
   %own %integer  looping = 1, here = 0
   %integer  dp, mask, gla, line no, base pc, pc
   %integer  monitor call, entering, enter line, enter base
   %string(31)  enter name
   %string(13)  entex
   %string(127) in name, out name
   %integer  inst, outst, nlines = 0

   %integer %array  base reg (11:15)

   %routine  NEW LINE
      print symbol (nl)
      nlines = nlines + 1
   %end

   %routine  FIND LINE (%integer  pc, lines)
      %integer  len, p, j
      line no = 0
      %return %unless prober (lines, 2)
      len = shortinteger(lines)&16_FFFF - 2
      lines = lines + 2
      %cycle
         %return %unless prober (lines, 4)
         %if pc < integer(lines) %start
            line no = shortinteger(lines-2)&16_FFFF
            %return
         %finish
         len = len - 6
         lines = lines + 6
      %repeat %until len <= 0
   %end

   %routine FIND BLOCK (%integer  pc)
      dp = 0
      %return %unless prober (gla, 40)
      g == record(gla)
      %return %unless g_id = "GLA"
      pc = pc - (g_code+addr(g_code));         !file relative
      base pc = pc
      %return %if pc <= 0;                     !not in this file
      dp = 0 %and %return %if g_diags = 0
      dp = g_diags + addr(g_diags);            !address of diag table
      %return %if dp = 0

      %while prober (dp, 6) %cycle
         p == record(dp)
         %exit %if p_size = 0
         %return %if pc <= p_limit
         dp = dp + p_size
      %repeat
      dp = 0
   %end

   %routine  PRINT LOCAL (%record(var diag fm) %name  v)
      %integer  t, ad, val, lo, hi, base, indirect, badchar

      %routine  PRINT SAFE (%string(*) %name  s, %integer show, lim)
         ! Print s, but ignore or flag non-printing 
         ! chars (marked as <character value>).
         %integer  c, p
         bad char = 0
         %if show # 0 %start      {as string}
            print symbol ('"')
            lim = length(s)       {print all of it}
         %else                    {as ident}
            lim = length(s) %if length(s) < lim  {at most LIM chars}
         %finish
         %for p = 1, 1, lim %cycle
            c = charno(s,p)
            %if ' ' <= c <= 126 %or c = nl %start
               print symbol (c)
               %if show = 0 {identifier} %start
                  bad char = 1 %unless 'A' <= c <= 'Z' %or
                                       ('0' <= c <= '9' %and p # 1)
               %finish
            %else 
               bad char = 1   {Nasty, flag it}
               %if show # 0 %start
                  print symbol ('<');  write (c, 0);  print symbol ('>')
               %finish
            %finish
         %repeat
         print symbol ('"') %if show # 0
         print string (" (doctored)") %if bad char # 0 # show
      %end

      spaces (15-length(v_name));  print safe (v_name, 0, 31)
      print string (" =")
      indirect = v_base&128
      base = v_base&127
      %unless bad char = 0 %and 11 <= base <= 15 %start
         printstring("  *corrupt diags*");  ->new
      %finish
      t = v_type
      indirect = 1 %if base = 12 %and t = 64;      !string params
      ad = v_disp + base reg(base)
      %if indirect # 0 %start
         ! Object is a %name of some sort
         indirect = 0 %and -> iva %unless prober (ad, 4)
         ad = integer(ad)
         -> rna %if ad = 16_80808080
      %finish
      %if t = 16 %or t = integers %start
         t = integers
         -> iva %unless prober (ad, 4)
         val = integer(ad);       ->wr
      %finish
      %if t = 18 %or t = bytes %start
         t = bytes
         -> iva %unless prober (ad, 1)
         val = byteinteger(ad);   ->wr
      %finish
      %if t = 17 %or t = shorts %start
         t = shorts
         -> iva %unless prober (ad, 2)
         val = shortinteger(ad);  ->wr
      %finish
      %if t = 21 %or t = longints %start
         t = longints
         -> iva %unless prober (ad, 8)
         lo = integer(ad);  hi = integer(ad+4)
         -> uav %if lo = 16_80808080 = hi
         space
         %if lo >= 0 = hi %or lo <= -1 = hi %start
            write (lo, 0);  print string (", ")
         %finish
         phex (integer(ad+4));  phex (integer(ad));  -> new
      %finish
      %if t = 64 %or t = strings %start
         t = strings
         -> iva %unless prober (ad, 1) %and 
                        prober (ad+byteinteger(ad), 1)
         -> uav %if shortinteger(ad)&16_FFFF = 16_8080
         space;  print safe (string(ad), 1, 0);  -> new
      %finish
      %if t = 35 %or t = reals %start
         t = reals
         -> iva %unless prober (ad, 4)
         -> uav %if integer(ad) = 16_80808080
         %if integer(ad)&16_FF80 = 16_8000 %start
            print string (" reserved real value")
         %else
            printfl (real(ad), 7)
         %finish
         -> new
      %finish
      %if t = 36 %or t = longreals %start
         t = longreals
         -> iva %unless prober (ad, 8)
         -> uav %if integer(ad) = 16_80808080 = integer(ad+4)
         %if integer(ad)&16_FF80 = 16_8000 %start
            print string (" reserved longreal value")
         %else
            printfl (longreal(ad), 14)
         %finish
         -> new
      %finish
      %if t = 128 %or t = records %start
         t = records
         !???? 
      %finish
      -> iva %unless prober (ad, 24)
      %for t = 1, 1, 6 %cycle;          !dump the object
         space;  phex (integer(ad))
         ad = ad + 4
      %repeat
      -> new
rna:  print string (" reference")
uav:  print string (" not assigned");       -> new
iva:  %if indirect # 0 %start
         print string (" invalid reference (16_")
         phex (ad);  print symbol (')')
      %else
         print string (" invalid address")
      %finish
      -> new
wr:   -> uav %if val = 16_80808080
      space;  write (val, 0)
      %if val = 10 %start
         printstring(", NL")
      %else %if ' ' <= val <= 126
         print string (", '");  print symbol (val);  print symbol ('''')
      %else %if t = shorts %and val&16_FFFF = 16_8080
         print string ("  (not assigned?)")
      %else %unless 16_ffff8000 <= val <= 16_7fff
         print string (", 16_");  phex (val)
      %finish
new:  newline
   %end

   %routine  PRINT LOCALS
      %record(var diag fm) %name  v
      %while prober (dp, 40) %cycle
         v == record(dp)
         %exit %if v_type = 0
         print local (v)
         dp = dp + 7 + length(v_name)
      %repeat
   %end

   %routine report system error(%integer code)
      %switch c(-8:0)
      %string(72) text, temp
      ->c(code)
c(0): text = sysmess(sub)
      %if text -> text.(" at PC").temp %or text -> text.(",").temp %start
      %finish
      printstring(text);  %return
c(-1):printstring("Address error");  %return
c(-2):printstring("Decimal overflow");  %return
c(-3):printstring("Floating underflow");  %return
c(-4):printstring("Illegal opcode (customer)");  %return
c(-5):printstring("Illegal opcode (Digital)");  %return
c(-6):printstring("Reserved addressing mode");  %return
c(-7):printstring("Reserved operand");  %return
c(-8):printstring("Subscript range trap");  %return
   %end

   %routine  report imp error
      %externalstring(255)%spec error message
      %const %integer  max keys = 21
      %switch  e (0 : max keys)
      %integer  en
 
      %integerfn event key
         %constbyteintegerarray keys(1:max keys) =
            6+2<<4,  6+3<<4,  8+2<<4,  8+1<<4,  7+1<<4,  1+1<<4,
            1+2<<4,  1+3<<4,  2+1<<4,  9+1<<4,  5+3<<4,  3+1<<4,
            9+2<<4,  5+1<<4,  5+2<<4,  5+4<<4,  5+5<<4,  1+4<<4,
            9+3<<4,  3+2<<4,  6+5<<4
         %integer key, e
         %result = 0 %if event = 0
         key = sub<<4+event
         %for e = 1, 1, max keys %cycle
            %result = e %if keys(e) = key
         %repeat
         %result = 0
      %end

      en = event key
      %if en = 0 %start
         printstring("Signal ")
         write(event, 0)
         printstring(", ");  write(sub, 0)
         printstring(", ");  write(extra, 0)
         %return
      %finish
      -> e (en)
e(1): print string ("Array index (")
oob:  write (extra, 0)
      print string (") out of bounds");                     %return
e(2): print string ("Switch index (");  ->oob
e(3): print string ("No switch label ");  write(extra, 0);  %return
e(4): print string ("Unassigned variable");                 %return
e(5): print string ("Resolution fails");                    %return
e(6): print string ("Integer value too large");             %return
e(7): print string ("Real value too large");                %return
e(8): print string ("String capacity exceeded");            %return
e(9): print string ("Not enough store");                    %return
e(10):print string ("Input ended");                         %return
e(11):print string ("Array inside-out");                    %return
e(12):print string ("Symbol '");  printsymbol(extra)
      print string ("' instead of a number");               %return
e(20):print string ("Symbol '"); printsymbol(extra)
      print string ("' instead of a string");               %return
e(13):print string ("Illegal stream ");  write(extra, 0);   %return
e(14):print string ("%for cannot terminate");               %return
e(15):print string ("Illegal exponent ");  write(extra, 0); %return
e(16):print string ("String inside-out");                   %return
e(17):print string ("Illegal parameter for READ");          %return
e(18):print string ("Division by zero");                    %return
e(19):print string (error message." ".sysmess(extra));      %return
e(21):print string ("CHARNO index (");  write(extra, 0)
      print string (") out of range");                      %return
e(0): print string ("Program error ");  write(sub, 0)
      print string (" (");  write(extra, 0)
      print symbol (')')
   %end

!!   printsymbol(alpha mode);            !be kind to graphics terminals
   looping = looping-1
   inst = in stream;  outst = out stream
   in name = in file name;  out name = out file name
   here = here + 256
   %if event # 0 %or sub > 0 %start
      monitor call = 0
      open output (3,"SYS$ERROR")
      selectoutput(3)
      print symbol (stx char);           !make tekkys happy
      %if looping < 0 %start
         print string ("Imp77 diagnostics looping")
         newline
         exit(16_1000002c)
      %finish
      printstring("
**Execution error: ")
      %if event < 0 %start
         report system error(event+1)
         printstring(" at PC: "); phex(extra)
      %else
         report imp error
      %finish
      newline
   %else
      monitor call = 1;                    ! from %monitor
   %finish
   newline
   print string ("Current  input stream (");   write (inst, 0); 
   print string (") is ");   print string (in name)
   newline
   print string ("Current output stream (");   write (outst, 0)
   print string (") is ");   print string (out name)
   newlines (2)
   entex = "Executing "
   entering = 1;  enter line = -1
   %cycle
      %exit %unless prober (fp, 68);     ! Check that FP is sensible
      ! Pick up GLA pointer (r11)
      mask = integer(fp+6) & 16_fff;     ! procedure entry mask
      gla = 16;                          ! offset to first saved register - 4
      %for pc = 0,1,11 %cycle;           ! skip other saved registers
         gla = gla + 4 %if (1<<pc) & mask # 0
      %repeat
      base reg(11) = integer(fp+gla) %if mask&(1<<11) # 0;! r11 for prev frame
      base reg(12) = integer(fp+8);      !ap
      base reg(13) = integer(fp+12);     !fp
      pc = integer(fp+16)
      gla = base reg(11)
      find block (pc)
      %if dp # 0 %start
         print string (entex)
         find line (base pc, g_lines+addr(g_lines))
         line no = line no & 16_FFFF;    ! unsigned, held in short
         %if line no # 0 %start
            %if entering # 0 %start
               ! this is the first line number found
               nlines = 0;        ! Count lines of diags from here on
               enter line = line no 
               entering = 0
               enter name = p_name;  enter base = p_line
            %finish
            print string ("line ");  write (line no, 0);  print string (" in ")
         %finish
         %if p_name = "$GO$" %start
            print string ("block")
            entex = "entered from "
         %else
            print string (p_name)
            entex = "called from "
         %finish
         print string (" starting at line");  write (p_line, 1)
         newline
         dp = dp + 9 + length(p_name);    ! Past proc name etc
         print locals
         newline
         %if g_null # here %start
            g_null = here
            dp = g_diags+addr(g_diags)+g_envir
            %if prober (dp, 1) %and byteinteger(dp) # 0 %start
               print string ("Environmental variables");  newline
               print locals
               newline
            %finish
         %finish
      %finish
      fp = base reg(13)
   %repeat %until fp = 0
   %if nlines > 10 %and enter line > 0 %start
      ! Repeat point of entry information
      newline
      %if monitor call # 0 %start
         print string ("Monitor called from")
      %else
         print string ("Failed at")
      %finish
      print string (" line ")
      write (enter line, 0);  print string (" in ")
      %if enter name = "$GO$" %start
         print string ("block")
      %else
         print string (enter name)
      %finish
      print string (" starting at line ");  write (enter base, 0)
      newline
   %finish
   newline
   looping = looping + 1
%end

%end %of %file