!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"
%external %string(255) %spec  error message
%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(13)  entex
   %string(75)  line text, entry text
   %string(127)  in name, out name
   %integer  inst, outst, nlines = 0, bad char = 0, r, fail point
   %integer %array  base reg (11 : 15)

   %predicate  VALID IDENTIFIER (%string(*) %name  s, %integer  as proc)
      %integer  c, p
      %false %unless 0 < length(s) <= 31
      %true %if as proc # 0 %and s = "$GO$"
      %false %unless 'A' <= charno(s,1) <= 'Z'
      %for p = 2, 1, length(s) %cycle
         c = charno(s, p)
         %false %unless 'A' <= c <= 'Z' %or
                        '0' <= c <= '9'
      %repeat
      %true
   %end

   %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 len >= 4 %and 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";       ! check R11 sensible
      %return %if pc < 0;                 ! in system space
      pc = pc - (g_code+addr(g_code));    ! file relative
      %return %if pc <= 0;                ! at lower address than this module
      %return %if g_diags = 0
      base pc = pc
      dp = g_diags + addr(g_diags);       ! address of diag table
      %return %if dp = 0;                 ! corrupt or compiled /nodiag
      ! Scan block descriptors
      %while prober (dp, 6) %cycle
         p == record(dp)
         %exit %if p_size = 0;            ! end of descriptors
         %exit %if %not valid identifier (p_name, 1); ! otherwise invalid dp
         %return %if pc <= p_limit;       ! got it!
         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

      %routine  PRINT SAFE (%string(*) %name  s)
         ! Print s as string, flagging non-printing 
         ! chars (marked as <character value>).
         %integer  c, p, bad = 0
         print symbol ('"')
         %for p = 1, 1, length(s) %cycle
            c = charno(s,p)
            %if ' ' <= c <= 126 %or c = nl %start
               print symbol (c)
            %else 
               print symbol ('<');  write (c, 0);  print symbol ('>')
               bad = 1
            %finish
         %repeat
         print symbol ('"')
         print string (" (filtered)") %if bad # 0
      %end

      %return %unless valid identifier (v_name, 0)
      spaces (15-length(v_name));  print string (v_name)
      print string (" =")
      indirect = v_base&128
      base = v_base&127
      %unless 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));  -> 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 (0 : 8)
      %string(72) text, temp
      -> c (code)
   c(0): text = sysmess(sub)
         %if text -> text.(" at PC").temp %or text -> text.(",").temp %start
         %finish
         print string (text);                         %return
   c(1): print string ("Address error");              %return
   c(2): print string ("Decimal overflow");           %return
   c(3): print string ("Floating underflow");         %return
   c(4): print string ("Illegal opcode (customer)");  %return
   c(5): print string ("Illegal opcode (Digital)");   %return
   c(6): print string ("Reserved addressing mode");   %return
   c(7): print string ("Reserved operand");           %return
   c(8): print string ("Subscript range trap");       %return
   %end

   %routine  REPORT IMP ERROR
      %const %integer  max keys = 21
      %switch  e (0 : max keys)
      %integer  en
 
      %integer %function  EVENT KEY
         %const %byte %array  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
      -> e (en)
   e(0): print string ("Signal ");   write (event, 0)
         print string (", ");        write (sub, 0)
         print string (", ");        write (extra, 0);         %return
   e(1): print string ("Array");   -> oob
   e(2): print string ("Switch")
   oob:  print string (" index (");  write (extra, 0)
         print string (") out of bounds");                     %return
   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
   %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 + 1) & 255
   %if event # 0 %or sub > 0 %start
      open output (3, "SYS$ERROR")
      select output (3)
      print symbol (stx char);           !make tekkys happy
      %if looping < 0 %start
         print string ("Imp77 diagnostics looping")
         newline
         exit (16_1000002c)
      %finish
      print string ("
**Execution error: ")
      %if event < 0 %start
         ! code complemented to distinguish non-Imp signal
         report system error (\event)
         print string (" at PC: ");   phex (extra)
      %else
         integer(fp+16) = integer(fp+16) - 1;  ! fiddle %signal return addr.
         report imp error
      %finish
      newline
      monitor call = 0
   %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;  fail point = 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 r = 0, 1, 11 %cycle;          ! skip other saved registers
         gla = gla + 4 %if (1<<r) & mask # 0
      %repeat
      base reg(11) = integer(fp+gla) %if mask&(1<<11) # 0;!saved r11
      base reg(12) = integer(fp+8);      !saved ap
      base reg(13) = integer(fp+12);     !saved fp
      ! Now pick up return pc from here
      pc = integer(fp+16)
      %if fail point # 0 %and event < 0 %and monitor call = 0 %start
         ! If the pc we are attempting to connect with a line number
         ! is that at which the error occured, and the error is not
         ! an imp %signal or %monitor call, then we leave the PC
         ! alone, since the first instruction in a statment may have
         ! faulted (eg address error).
      %else
         ! Otherwise we can be sure that the point of error is NOT 
         ! the code address of the first instruction for the line 
         ! (since a perm must have been called for any other case,
         ! or we are back-tracking, and the current pc is that of
         ! the instruction following a CALL), so we back up the pc 
         ! slightly to ensure that it relates to the correct line...
         pc = pc - 1
         fail point = 0;                 !always true from here on
      %finish
      gla = base reg(11);                !pick up saved gla reg
      find block (pc)
      %if dp # 0 %start
         print string (entex)
         find line (base pc, g_lines+addr(g_lines))
         %if line no # 0 %start
            line text = "line " . itos (line no, 0) . " in "
         %else
            line text = "unknown line in "
         %finish
         %if p_name = "$GO$" %start
            line text = line text . "block"
            entex = "entered from "
         %else
            line text = line text . p_name
            entex = "called from "
         %finish
         line text = line text . " starting at line " . %c
                     itos (p_line&16_FFFF, 0)
         print string (line text);   newline
         %if entering # 0 %start
            entering = 0;      ! this is the first source point found
            nlines = 0;        ! Count lines of diags from here on
            entry text = line text
         %finish
         dp = dp + 9 + length(p_name);    ! Past proc name etc
         print locals
         newline
         %if g_spare # here %start
            g_spare = 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 > 15 %and entering = 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 (entry text)
      newline
   %finish
   newline
   looping = looping + 1
%end

%end %of %file