! Executable file header:-
%record%format MOB HEADER F(%short version,flags,export,import,
                           %integer code,%short reset,main,
                           %integer own,stack,
                           %short dlim,charlim,spare1,spare2)

! List of loaded modules:-
%record%format MODLIST F(%record(modlistf)%name pre,
                         %record(objf)%name file,
                         %record(mobheaderf)%name header,
                         %integer gla)
@736(a5){#MODLISTSLOT} %record(modlistf)%name MODLIST

!!!!!!!!!!!!!!!!!!!!!!   Diagnostics   !!!!!!!!!!!!!!!!!!!!!!!!!!!!

%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(event_pc)
    %if event_sub <= 3 %start             {Address/Bus error}
      printstring("  Code="); phex4(event_spare>>16)
      printstring(" IR="); phex4(event_spare)
      %for i = 0,1,15 %cycle
        newline %if i&7 = 0 
        space;  phex(event_r(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 usermon&redefmon # 0 %start
!!max=127;p=pos
!!write(line,1)
!!%cycle
!!write(byteinteger(p),1)
!!%exit %if byteinteger(p) # max
!!p = p+1;  max = 255
!!%repeat
!!newline
!!%finish
    %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(modlistf)%name M
%record(mobheaderf)%name H
%record(diaginfo)%name DI
%integer I,J
  e_id = -1;  e_line = 0
  %unless e_modlim >= pc >= e_modstart %start
    m == modlist
    %cycle
      %return %if m == nil   {not found}
      h == m_header;  i = codestart(h)
      %exit %if i <= pc <= i+h_code
      m == m_pre
    %repeat
    e_modstart = i;  e_modlim = e_modstart+h_code
    e_gla = m_gla&\1
    e_d0 == record(e_modlim)
    e_dlim = m_header_dlim
    e_charbase = e_modlim+e_dlim*sizeof(di)
    e_name = nameof(m_file);  truncate(e_name,".MOB")
!%if usermon&redefmon # 0 %start
!  i = 0;  di == e_d0[i]
!  %while i < e_dlim %cycle
!    %if di_type!di_link # 0 %start
!      phex4(i)
!      print ident(e_charbase+di_text,20)
!      space;  phex4(di_type)
!      space;  phex4(di_link)
!      space;  phex4(di_val)
!      newline
!    %finish
!    i = i+1;  di == di[1]
!  %repeat
!%finish
  %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 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 storemin <= ad < storelim
again:                {!}
  -> c(cat(tp))
c(inty):
  %if |tp_val| = 1 %start
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)           {!}
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):
  print(real(ad),0,3)
  %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 0 < p < storelim %and p&1 = 0
  %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 disp(i) < frame %start
        frame = disp(i);  level = i
      %finish
    %repeat
    %exit %if frame >= sp                    {sound FRAME value}
    %return %if level = 0                    {SP >= LIMIT}
   {DISP(LEVEL) < SP}
    printstring("*Stack corrupt 1: ")
    write(level,1);  space;  phex(frame)
    newline
    disp(level) = 16_7FFFFFFF
  %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}
      -> err %unless okshort(epc) = jmp
      epc = integer(epc+2)
    %else %if okshort(pc-2) # jsra1  {EXEC call}
err:  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);  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
    printstring(" Module ");  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
  disp(level) = integer(frame)         {unlink}
  sp = frame+4
%repeat
set terminal mode(mode)
%end;  !diagnose

%system%routine MONITOR
{*no vars to perturb SP*}
  disp(1) = a6
  disp(2) = display(2)
  disp(3) = display(3)
  disp(4) = display(4)
  disp(5) = display(5)
  disp(6) = display(6)
  disp(7) = display(7)
  diagnose(integer(a7),a7,maingla)
%end

.........................
.........................


! ******************************   NB   ******************************
! Open new block so that the variables of RUN PROGRAM are not accessed
! via SP since the stack is extended by OWN storage for main program
!  *** NB all returns must be via Signal to ensure stack restored ***
! ********************************************************************

%routine RUN
%on %event 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
  %return
%finish
  stack = prog_header_own
! ******************
  A7 = A7-stack-1024   {1024 extra for DIAG}
! ******************
  gla = A7
  prog_gla = gla!1

  initialise(prog_file,gla)

 ! Enter program
  prompt(":")
  cliparam = param
  stage = 1
%option "-noass"
  D4 = 0; D7 = 16_80808080
  A4 = gla
  A0 = addr(cliparam)            {in case procedure with %string parm}
  A1 = code
  maingla = a4;  mainentry = a1
  *jsr (a1)                      {enter program/procedure}
  %stop                          {if procedure, to restore stack}
%end;  !run

  run
  -> notstarted %if stage <= 0
  set terminal mode(mode)
  terminalmask = 0
  close all(event_eventsub)
  %return %if event_eventsub = 0 {normal %stop}
  selectinput(0);  select output(0)
  in(0) == defaultin(0);  out(0) == defaultout(0)
  closeinput;  closeoutput
  %while testsymbol >= 0 %cycle; %repeat
  %return %if event_eventsub = 1        {Event 0,1: ^Y}
  newline
  vreset
  event_line = 0;  interpret event
  diagnose(event_pc,event_r(15),gla)
  interpret event %if event_line # 0  {repeat after diag}
%end;  !run program