!  File  NMOUSE:DIAGS

! Diagnostics

%option "-low-nocheck-nodiag-nostack"
%include "mouse.inc"

%record(mar fm)%map mainmodule
%record(mar fm)%name mar == poa_filelist, mainmar == nil
%integer mingla = maxint
  %while mar##nil %cycle
    mainmar == mar %and mingla = mar_gla %if poa_stacklimit<mar_gla<mingla
    mar == mar_next
  %repeat
  %result == mainmar
%end

%integerfn codestart(%record(fe02 header fm)%name h)
  %result = addr(h)+sizeof(h)+h_import+h_export+h_main<<1
%end

%integerfn mainentry
  %result = codestart(mainmodule_header)
%end

%integerfn maingla
  %result = mainmodule_gla
%end

%string(255)%fn nameof(%record(fe02 header fm)%name h)
%string(255)s
%record(marfm)%name mar
  mar == poa_filelist
  %while mar##nil %cycle
    %if mar_header==h %start
      s = substring(mar_name,1,length(mar_name)-4)
      %if mar_gla=maingla %then s = "program ".s %else s = "module ".s
      %result = s
    %finish
    mar == mar_next
  %repeat
  %result = "system"
%end

%routine PUT CHAR(%integer k,quote)
  %if k < 32 %start
    printsymbol('^');  printsymbol(k+'@')
  %else %if k < 127
    printsymbol(quote);  printsymbol(k);  printsymbol(quote)
  %finish
%end

%routine PUT INT(%integer v,word)
  write(v,0)
  %if v < -1000 %or v > 1000 %start
    printstring(" (")
    %if word # 0 %then phex4(v) %else phex(v)
    printsymbol(')')
  %else %if 32 <= v <= 126
    printstring(" (");  put char(v,'''');  printsymbol(')')
  %finish
%end

%routine PRINT LINENO(%integer l)
  printstring("Line");  write(l&16_3FFF,1)
  printsymbol('&') %if l>>14 # 0
%end

%routine INTERPRET EVENT
%integer i
  printstring("*Event"); write(event_event,1)
  write(event_sub,1) %if event_sub # 0
  space %and space %and put int(event_extra,0) %if event_extra # 16_80808080
  space %and space %and printstring(event_message) %if event_message # ""
  space %and space %and print lineno(event_line) %if event_line # 0
! %if event_event = 0 %start              {low-level error}
!   printstring("   PC "); phex(poa_eventpc)
!   space %and phex4(half(poa_eventpc+i)) %for i = -4,2,4
!   %if event_sub <= 3 %start             {Address/Bus error}
!     %for i = 0,1,15 %cycle
!       newline %if i&7 = 0
!       space;  phex(poa_eventregs(i))
!     %repeat
!   %finish
! %finish
  newline
%end

%constinteger JMP=16_4EF9, JSR=16_4EB9,
              JMPW=16_4EF8, JSRW=16_4EB8,
              JSRA1=16_4E91, JSRA4=16_4EAC,
              BRA=16_6000, BSR=16_6100

%routine DIAGNOSE(%integer pc,sp,limit)
{Diagnostic cell}
%recordformat DIAGINFO(%short type,link,
                       %half text,(%short val %or %half ep))
{PC identity}
%record%format ENV F(%integer modstart,modlim,gla,dlim,charbase,
                              proclim,id,line,
       %record(diaginfo)%name d0, %string(31) name)
!Flags on TYPE:-
%constinteger NAME=-16_8000, INDIRECT=16_4000, VAR=16_2000, DYN=16_1000
!Categories (MS 4 bits of LINK):-
%constinteger INTY=0, CHARY=1, BOOLY=2, ENUMY=3,
              POINTY=4, REALY=5,
              STRINGY=8, ARRY=9, SETY=10,
              RECY=12, FILEY=13,
              NONORD=12

%record(envf) E,EE
%record(diaginfo)%name DI
%integer I,LEVEL,FRAME,EPC,FIRST,MODE
%constinteger MAXDEPTH=8

%routine PUT STRING(%string(*)%name s, %integer max)
%integer i
  printsymbol('"')
  %for i = 1,1,length(s) %cycle
    %if 32 <= charno(s,i) < 127 %then printsymbol(charno(s,i)) -
    %else printsymbol('_')
    %return %if i = max       {without closing quote}
  %repeat
  printsymbol('"')
%end

%integer%fn LINENO(%integer line,pc,pos)
!Find line number corresponding to relative PC (words)
!  LINE = base line number
!  POS  = starting position in line info table
%integer max,p
  %cycle
    %if byteinteger(pos)&128 = 0 %start      {PC delta}
      max = 127
      %cycle
        pc = pc-byteinteger(pos)
        %result = line %if pc <= 0
        %exit %if byteinteger(pos) # max
        pos = pos+1;  max = 255
      %repeat
      line = line+1
    %else %if byteinteger(pos) # 255         {line delta}
      line = line+(byteinteger(pos)-128)
    %else                                    {absolute line}
      line = byteinteger(pos+1)<<8+byteinteger(pos+2)
      pos = pos+2
    %finish
    pos = pos+1
  %repeat
%end

%routine FIND(%integer pc,%record(envf)%name e)
%record(mar fm)%name M
%record(fe02 header fm)%name H
%record(diaginfo)%name DI
%integer I,J
  e_id = -1;  e_line = 0
  %unless e_modlim >= pc >= e_modstart %start
    e = 0; e_id = -1
    m == poa_filelist
    %cycle
      %returnif m==nil
      h == m_header;  i = codestart(h)
      %exit %if i <= pc <= i+h_codesize
      m == m_next
    %repeat
    e_modstart = i;  e_modlim = e_modstart+h_codesize
    e_gla = m_gla&\1
    e_d0 == record(e_modlim)
    e_dlim = h_dlim
    e_charbase = e_modlim+e_dlim*sizeof(di)
    e_name = nameof(h)
  %finish
  %return %if e_dlim = 0         {no Diag info}
 {Locate procedure containing PC}
 { procedures are ordered by decreasing address}
  pc = (pc-e_modstart)>>1
  i = 0;  j = 65535
  %cycle
    di == e_d0[i]
    %exit %if pc >= di_ep
    j = di_ep
    %return %if di_link <= i {safety} %or di_link >= e_dlim  {not found}
    i = di_link
  %repeat
  e_id = i
  e_proclim = e_modstart+j+j
  e_proclim = e_modlim %if e_proclim > e_modlim
  e_line = lineno(di[1]_ep,pc-di_ep,e_charbase+di[1]_text) %if di[1]_text # 0
%end

%integer%fn CAT(%record(diaginfo)%name TP)
  %result = tp_link>>12&15
%end

%predicate ADOK(%integer ad)
@16_3ff8 %integer membot,memtop
  %trueif 0<=ad<16_4000 %or membot<=ad<memtop
  %false
%end
%predicate OK8(%integer ad)
  %false %if byteinteger(ad) = 16_80
  %true
%end
%predicate OK16(%integer ad)
  %false %if ad&1 # 0 %or shortinteger(ad) = 16_FFFF8080
  %true
%end
%predicate OK32(%integer ad)
  %false %if ad&1 # 0 %or integer(ad) = 16_80808080
  %true
%end

%predicate OK(%record(diaginfo)%name tp,%integer ad)
%integer k
%switch c(0:15)
  %false %unless adok(ad)
again:
  -> c(cat(tp))
c(inty):
  %if |tp_val| = 1 %start
    %true
c(booly):c(enumy):c(chary):
    %true %if ok8(ad);  %false
  %finish
  %if |tp_val| = 2 %start
c(*):
    %true %if ok16(ad);  %false
  %finish
c(realy):
  %true %if ok32(ad);  %false
c(arry):
  tp == e_d0[tp_type&4095] %until cat(tp) # arry
  %false %if cat(tp) > arry
  -> again                    {!}
c(recy):                      {!}
  k = |tp_val|                {!}
  %while k > 0 %cycle         {!}
    %true %if ok8(ad)         {!}
    ad = ad+1;  k = k-1       {!}
  %repeat                     {!}
  %false                      {!}
c(stringy):                   {!}
  %true %if ok8(ad)           {!}
  %true %if ok8(ad+1)
c(sety):c(filey):c(pointy):  {for now: not implemented}
  %false
%end

%record%format IDINFO(%string(*)%name s,%record(idinfo)%name link)

%routine SHOW(%record(diaginfo)%name DI, %record(idinfo)%name PRE,
              %integer AD,DEPTH)
%record(idinfo) id
%record(diaginfo)%name tp

%routine PUT OBJECT(%record(diaginfo)%name TP,%integer AD)
%switch c(0:15)
  -> c(cat(tp))
c(inty):
  %if tp_val = -1 %start               {unsigned byte}
    putint(byteinteger(ad),0)
  %else %if tp_val = 1                 {signed byte}
    putint(miteinteger(ad),0)
  %else %if tp_val = -2                {half}
    putint(halfinteger(ad),1)
  %else %if tp_val = 2                 {short}
    putint(shortinteger(ad),1)
  %else                                {integer}
    putint(integer(ad),0)
  %finish
  %return
c(chary):
  putchar(byteinteger(ad),'"')
  %return
c(booly):
  %if byteinteger(ad) # 0 %then printstring("TRUE") -
  %else printstring("FALSE")
  %return
c(enumy):
  printstring(string(e_charbase+tp[byteinteger(ad)+1]_text))
  %return
c(realy):
  printfl(real(ad),5)
  %return
c(stringy):
  put string(string(ad),50)
  %return
c(recy):
  %while tp_link&4095 # 0 %cycle
    tp == e_d0[tp_link&4095]
    newline
    show(tp,id,ad+tp_val,depth+1)
  %repeat
  %return
c(arry):
  tp == e_d0[tp_type&4095] %until cat(tp) # arry
  put object(tp,ad)
  printstring(", ...")
  %return
c(*):
  printstring("Unknown category:")
  write(cat(tp),1)
%end  {put object}

%routine PRINT IDENT(%record(idinfo)%name id,%integer field)
  field = field-length(id_s)
  %if id_link ## nil -
  %then print ident(id_link,field-1) %and printsymbol('_') -
  %else spaces(field)
  printstring(id_s)
%end

  id_link == pre;  id_s == string(e_charbase+di_text)
  tp == e_d0[di_type&4095]
  print ident(id,24)
  %if di_type&indirect # 0 %start
    %return %unless ok32(ad)
    ad = integer(ad)
  %finish
  %if di_type < 0 %start                  {%name}
    %return %unless ok32(ad)
    printstring(" @")
    ad = integer(ad)
    %if ad = 0 %then printstring("NIL") %else phex(ad)
    %return %unless depth = 1
  %finish
  %if ok(tp,ad) %start
    printstring(" = ")
    put object(tp,ad)
  %finish
%end  {show}

%integer%fn OKSHORT(%integer p)
{Including ROM and local RAM?}
  %result = 0 %unless p&1 = 0 %and adok(p)
  %result = shortinteger(p)
%end

  first = 1
! mode = terminal mode
! set terminal mode(0) %if mode # 0
  newline
  e_modlim = 0
%cycle
  find(pc,e)                                 {Locate PC}
 {Find most recent LINK to locate next stack frame}
  %cycle
    frame = limit;  level = 0
    %for i = 1,1,7 %cycle
      %if 0 < poa_eventdisplay(i) < frame %start
        frame = poa_eventdisplay(i);  level = i
      %finish
    %repeat
    %exit %if frame >= sp                    {sound FRAME value}
    %return %if level = 0                    {SP >= LIMIT}
   {event_display(LEVEL) < SP}
    printstring("*Stack corrupt 1: ")
    write(level,1);  space;  phex(frame)
    newline
    poa_eventdisplay(level) = maxint
  %repeat
  epc = mainentry
  %if level # 0 %start                   {frame located below LIMIT}
    pc = integer(frame+4)                {return address}
   {Establish entry-point PC}
    %if okshort(pc-4) = bsr %start       {internal call}
      epc = pc-4
      epc = epc+2+okshort(epc+2) %until okshort(epc) # bra
    %else %if okshort(pc-4) = jsra4      {external call}
      find(pc,ee)                        {locate calling module}
      epc = ee_gla+okshort(pc-2)
      epc = epc+6 %if okshort(epc) # jmp {external v system}
      %unless okshort(epc) = jmp %start
        printstring("*Stack corrupt 3: ")
        epc = ee_gla+okshort(pc-2)
        phex(epc); space
        phex4(okshort(epc)); phex4(okshort(epc+2)); phex4(okshort(epc+4))
        space
        phex4(okshort(epc+6)); phex4(okshort(epc+8)); phex4(okshort(epc+10))
        newline; %exit
      %finish
      epc = integer(epc+2)
    %else %if okshort(pc-2) # jsra1      {EXEC call}
      printstring("*Stack corrupt 2: ")
      phex4(okshort(pc-4));  newline
      %exit
    %finish
  %finish
  %if e_id < 0 %start                        {PC not located}
    find(epc,e)                              {locate entry-point PC}
    e_line = 0
    %exit %if epc = mainentry %and e_id # 0  {should be zero}
    %if e_id < 0 %start                      {entry-point not located}
      %if e_dlim # 0 %start
        printstring("*Procedure not located for ")
        phex(epc); space; phex(pc); newline
      %finish
    %else
     {Search stack for plausible call}
     {  probably should be tightened to (a) apply to first PC only}
     {   and (b) stop on JSR only}
      %while sp < frame %cycle
        i = integer(sp);  sp = sp+2
        %if epc < i <= e_proclim  {could be PC in this proc} -
        %and (shortinteger(i-4) = bsr -
              %or shortinteger(i-4)&16_FFE0 = jsr&16_FFE0) %start
          find(i,ee)
          e = ee %and %exit %if ee_id >= 0
        %finish
      %repeat
    %finish
  %finish
  event_line = e_line %if first # 0
  %if e_id >= 0 %start
    %if first # 0 %then spaces(11) %else printstring("Called from")
    space %and print lineno(e_line) %if e_line # 0
    di == e_d0[e_id]
    %if di_text # 0 %start
      printstring(" of") %if e_line # 0
      printstring(" Procedure ");  printstring(string(e_charbase+di_text))
!      space; printsymbol('@'); phex(e_modstart+di_ep+di_ep)
    %finish
    printstring(" in") %if e_line # 0 %or di_text # 0
    space; printstring(e_name)
    newline
    first = 0
    pc = epc %and %continue %if e_id # 0 -
    %and (epc-e_modstart)>>1 # di_ep  {FRAME not for this proc} -
    %and sp < frame                {to prevent looping}
    i = e_id+2                     {first cell for proc}
    %while i < e_d0[e_id]_link %cycle
      di == e_d0[i]
      %if di_type&var # 0 %and di_text # 0 %start
        %if di_type&dyn # 0 %start
          show(di,nil,frame+di_val,1) %and newline %if frame+di_val >= sp
        %else
          show(di,nil,e_gla+di_val,1);  newline
        %finish
      %finish
      i = i+1
    %repeat
    newline
  %finish
  %exit %if level = 0
  first = 0
  poa_eventdisplay(level) = integer(frame)         {unlink}
  sp = frame+4
%repeat
!set terminal mode(mode)
%end

%system%routine MONITOR
{*no vars to perturb SP*}
  *movem.l d0-d7/a0-a7,poa_eventregs; !Save registers (rather late)
  poa_display(1) = a6
  poa_eventdisplay = poa_display
  poa_eventpc = integer(poa_eventregs(15))
  diagnose(integer(a7),a7,maingla)
%end

%externalroutinespec connectfile(%string(255)f,%integer m,%integername p,s)
%externalrecord(mar fm)%namespec connected mar
%externalintegerfnspec load module(%record(mar fm)%name m)
%externalroutinespec abortoutput

%externalroutine RUN PROGRAM (%string(255)file)
%record(fe02 header fm)%name header
%record(mar fm)%name mar
%integer pc,gla,result,start,size,i

  %routine run
    %onevent 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
      %return
    %finish
    gla = (a7-header_ownsize)&-4
    *move.l gla,sp
    mar_gla = -gla
    pc = load module(mar)
    %signal 0,1 %if pc=0
    *move.l sp,a4
    *move.l pc,a1
    *jsr (a1)
    %stop
  %end

  %on 3 %start
    selectinput(0); selectoutput(0)
    file = "Run program fails: ".event_message
    %signal 3,event_sub,event_extra,file
  %finish

  event = 0
  event_extra = d7
  start = 0
  start = start<<8!32!charno(file,i) %for i = 1,1,length(file)
  file = file.".mob" %unless start='.mob'
  connectfile(file,1,start,size)
  mar == connected mar
  header == mar_header
  run
  mar_gla = 0
  result = poa_event<<8!poa_sub
  %if 1#result#0 %start
    selectoutput(0)
    event_line = 0; interpret event
    diagnose(poa_eventpc,poa_eventregs(15),maingla)
    interpret event %if event_line#0
  %finish
  %for i = 1,1,7 %cycle
    selectinput(i); closeinput
    selectoutput(i)
    %if result=0 %then closeoutput %else abortoutput
  %repeat
  selectinput(0)
  selectoutput(0)
%end