%begin; !EXEC: Mini Winchester version

%owninteger testing=0
%owninteger trouble
%ownstring(11)version="15/05/84"
%ownstring(255)cliparam=""

%constinteger debug=1,nolookup=2
%constinteger debugsym='?',nolookupsym='_'

%integer i        {!!!}

%integerspec(16_3ff0)freebot
%integerspec(16_3ff4)freetop
%shortintegerspec(16_1000)linenum
%shortintegerspec(16_3652)terminalmode
%byteintegerspec(16_372c)cylock
%owninteger botstore; botstore = freebot
%owninteger topstore; topstore = freetop
%recordformat dictf(%integer beg,pos,lim,alt)
%byteintegerspec(16_372d)fsport
%integerspec(16_3fac)cliparamad; cliparamad = addr(cliparam)
%record(dictf)%spec(16_3fb0)comdict
%record(dictf)%spec(16_3fc0)fildict
%integerfnspec(16_117c)defname(%string(255)s,%record(dictf)%name d,%integer size)
%integerfnspec(16_1180)refname(%string(255)s,%record(dictf)%name d)
%routinespec(16_1184)transname(%integer tag,%string(255)%name s)
%routinespec(16_1188)define event handler
%integerfnspec(16_1104)etherread(%integer port,%bytename buf,%integer max)
%integerfnspec(16_1108)fcomm(%integer cn,%string(255)s)
%routinespec diagnose
%owninteger tmode,sym
%ownstring(7)defowner="FMAC:"
%ownstring(5)defext=".MOB"
%ownstring(15)sysp
%ownbyteintegername osep,esep
  osep == charno(defowner,length(defowner))
  esep == charno(defext,1)

%routine close all ins
%integer i=4
  %onevent 9 %start
  %finish
  %cycle
    i = i-1; selectinput(i)
    %returnif i=0; closeinput
  %repeat
%end

%routine close all outs
%integer i=4
  %onevent 9 %start
  %finish
  %cycle
    i=i-1; selectoutput(i)
    %returnif i=0; closeoutput
  %repeat
%end

%routine uclose all outs
%integer i=4
  %onevent 9 %start
  %finish
  %cycle
    i = i-1; %exitif i=0
    openoutput(i,"")
  %repeat
  selectoutput(0)
%end

%routine symbol(%integer x)
  %if ' '<=x<=126 %start
    printsymbol('''') %if '0'<=x<='9'
    printsymbol(x)
    printsymbol('''') %if '0'<=x<='9'
  %finishelse write(x,0)
%end

%routine nhex(%integer x)
  x = x&15; x = x+7 %if x>9; printsymbol(x+'0')
%end

%routine bhex(%integer x)
  nhex(x>>4); nhex(x)
%end

%routine whex(%integer x)
  bhex(x>>8); bhex(x)
%end

%routine phex(%integer x)
  whex(x>>16); whex(x)
%end

%integerfnspec(16_408)loadfile(%string(255)%name file,%integer where)
%integerfn binary(%string(255)file)
%integer size
  cylock = cylock+1
  size = loadfile(file,freebot)
  cylock = cylock-1; %signal 0,1 %if cylock=128
  %result = freebot+size
%end

%routine obey(%integer from,to)

%integerfn nsym
  %result = byteinteger(from) %if from<to
  %result = nextsymbol
%end

%routine rsym(%integername x)
  %if from<to %start
    x = byteinteger(from); from = from+1
  %else
    readsymbol(x)
  %finish
%end

%routine skipsymbol
%integer x
  rsym(x)
%end

%routine readname(%string(255)%name s,%integername flags)
%integer t
  s=""
  %cycle
    sym = nsym; %exitunless sym=' '; skipsymbol
  %repeat
  %while sym>' ' %cycle; !%while nl#sym#' ' %cycle
    %exitif sym=',' %or sym='/' %or sym='='
    %exitif sym=debugsym %or sym=nolookupsym
    sym = sym&95 %if 'a'<=sym<='z'
    s = s.tostring(sym); skipsymbol; sym = nsym
  %repeat
  flags = 0
  %cycle
    %if sym=nolookupsym %start
      flags = flags!nolookup
    %finishelseif sym=debugsym %start
      flags = flags!debug
    %finishelseexit
    skipsymbol; sym = nsym
  %repeat
  %if length(s)>=2 %and charno(s,1)='%' %start; !translate parameter
    t = refname(s,comdict)
    transname(integer(t),s) %if t>0
  %finish
%end

%routine getparms
%string(255)s
%integer dummy
  cliparam = ""
  %cycle
    readname(s,dummy); cliparam = cliparam.s
    %exitif sym=nl
    cliparam = cliparam.tostring(sym)
    skipsymbol
  %repeat
%end

%routine run(%integer at,free,flags)
%integer env
  %onevent 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
    *move.l env,a6
    set terminal mode(tmode)
    %if event_event!event_subevent=0 %c
    %then close all outs %elsestart
      uclose all outs
      openinput(0,":")
      %cycle; %repeatuntil testsymbol<0
    %finish
    close all ins; diagnose; %return
  %finish
  tmode = terminalmode; !*?
  selectinput(0)
  *move.l a6,env
  %if at=0 %start;                ! Load failed
    rsym(at) %until at=nl
    %return
  %finish
  getparms
  flags = flags&debug
  flags = 16_8000 %unless flags=0
  prompt(":")
  selectinput(0); selectoutput(0)
  free = (free+3)&\3;                 ! Longword-align
  linenum = 0
  *move.l flags,d0
  *move.l at,a0
  *move.l #256,d6
  *add.l free,d6
  *trap #0
  *jsr -4(a0)
  %stop
%end

%predicate in(%integer tag,%record(dictf)%name d)
  %cycle
    %trueif d_beg<tag<=d_pos
    %falseif d_alt=0
    d == record(d_alt)
  %repeat
%end

%predicate loaded(%integer x)
%integer i = integer(x), j = integer(x+4)
  %falseif i=0 %or j=0 %or i>=j
  %true
%end

%string(255)verb,other,file                   {Main part of OBEY}
%integer starter,tag,equiv,flags,endad,base

  %onevent 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
    %if base#0 %and from>=to %start; !end of command file
      freebot = base %if freebot=(to+3)&\3
      %return
    %finish
    selectoutput(0)
    diagnose
    sym = testsymbol %until sym<0
  %finish

  base = from
  %if base#0 %start
    freebot = (to+3)&\3
  %else
    openinput(0,":")
  %finish
  *move.l sp,freetop
  freetop = freetop-2048

  openoutput(0,":tt")
  %cycle
    selectinput(0); selectoutput(0)
    cylock = 0
    prompt("{}")
    %cycle
      sym = nsym
      %exitunless sym<=' ' %or sym='{'
      skipsymbol
    %repeat
    %if sym='!' %start;              ! Ignore comments (?)
      rsym(sym) %until sym=nl
      %continue
    %finish
    readname(verb,flags)
    %if sym='=' %start;      ! Symbol definition
      skipsymbol
      readname(other,flags)
      rsym(sym) %until sym=nl
      tag = defname(verb,comdict,8)
      %if tag=0 %start
        printstring("*Command dictionary full"); newline; %continue
      %finish
      equiv = 0
{*temp%if length(other)>0 %start
        equiv = defname(other.defext,fildict,8)
        %if equiv=0 %start
          printstring("*File dictionary full"); newline; %continue
        %finish
        %if equiv<0 %start
          equiv = equiv<<1>>1
          integer(equiv) = 0; integer(equiv+4) = 0
        %finish
{*temp%finish
      %if tag<0 %start
        tag = tag<<1>>1
        %unless integer(tag)=equiv %start
          printstring("*".verb.": ".other." replaces ")
          transname(integer(tag),other)
          length(other) = length(other)-length(defext)
          printstring(other); newline
        %finish
      %finish
      integer(tag) = equiv; integer(tag+4) = flags
      %continue
    %finish
    %if nl#sym<' ' %or verb="" %start;     ! Rubbish typed
      %if sym=27 %start
        rsym(sym); rsym(sym); rsym(sym) %if sym='?'
      %finish
      printsymbol('?')
      %cycle
        rsym(sym); printsymbol(sym)
      %repeatuntil sym=nl
      %continue
    %finish
    tag = 0
    file = verb.defext
    %if flags&nolookup=0 %start
      tag = refname(verb,comdict)
      equiv = integer(tag)
      %if tag>0 %and in(equiv,fildict) %start
        flags = integer(tag+4)!flags
        transname(equiv,file)
        ->ok %if loaded(equiv)
      %finishelse tag = 0
    %finish
ok:
    %if tag#0 %start;                     ! Already loaded?
      endad = integer(equiv+4)
      %if loaded(equiv) %start
        run(endad,freebot,flags)
        %continue
      %finish
    %finish
    endad = binary(file)
    starter = byteinteger(freebot)
    %if starter='{' %start;               ! Command file
      obey(freebot,endad)
      %continue
    %finish
    %unless starter=16_fe %start
      endad = 0
      printstring("File ".file." is corrupt"); newline
    %finish
    selectinput(0)
    %continue %if endad=0;            ! Loader failed
    %if tag#0 %start;                 ! Remember where loaded
      integer(equiv) = freebot
      integer(equiv+4) = endad
      freebot = endad
    %finish
    run(endad,endad,flags)
  %repeat
%end

%routine obeyfile(%string(255)file)
%integer lo,hi
  lo = freebot; hi = binary(file)
  obey(lo,hi)
%end

%routine diagnose; !Print event message, line number, etc
%switch main(0:15)
%integer e=event_event&15
%integer s=event_subevent
%integer x=event_extra
%shortintegername ac,ir,sr
%integer i
  %returnif e=0 %and s>>1=0; ! 0,0: %stop;  0,1: ^Y
  %while testsymbol>=0 %cycle; %repeat
  newline; printstring("** ")
  ->main(e)
main(0):
  %if s>>1<<1=2 %start
    %if s=2 %then printstring("Bus") %else printstring("Address")
    ac == shortinteger(addr(event_message)+2)
    ir == shortinteger(addr(event_message)+4)
    sr == shortinteger(addr(event_message)+6)
    event_r(0) = integer(addr(event_message)+8)
    printstring(" error, Code="); whex(ac)
    printstring(", Addr="); phex(x)
    printstring(", IR="); whex(ir)
    printstring(", SR="); whex(sr); newline
    space %and phex(event_r(i)) %for i=0,1,7; newline
    space %and phex(event_r(i)) %for i=8,1,15
    ->norest
  %finish
  %if s=4 %start
    printstring("Illegal Instruction"); ->norest
  %finish
  %if s=5 %start
    printstring("Reserved Exception"); ->norest
  %finish
  %if s=8 %start
    printstring("Privilege violation"); ->norest
  %finish
  ->unknown
main(1):
  printstring("Overflow")
  printstring(" (division by zero)") %if s=4
  ->rest
main(2):
  printstring("Not enough store"); ->rest
main(3):
  printstring("Transmission error"); ->rest
main(4):
  printstring("Non-numeric character "); symbol(x)
  printstring(" in data"); ->norest
main(5):
  printstring("Invalid arguments"); ->rest
main(6):
  printstring("Index "); write(x,0); printstring(" out of range"); ->norest
main(7):
  printstring("Resolution fails"); ->rest
main(8):
  printstring("Unassigned variable"); ->rest
main(9):
  %if s=1 %start
    printstring("End of file reached"); ->rest
  %finish
  %if s=2 %start
    printstring("Illegal stream "); write(x&7,0); ->rest
  %finish
  %if s=3 %start
    %if event_message="" %start
      printstring("Filestore Error ")
      write(x,0)
    %finishelse printstring(event_message)
    newline; %returnif linenum=0
    ->norest
  %finish
  ->unknown
main(10):
  printstring("Library procedure error ")
  write(s,0); ->rest
main(11):main(12):main(13):main(14):main(15):unknown:
  printstring("Event "); write(e,0); space; write(s,0)
rest:
  space %and write(x,0) %unless x=0
somerest:
  space %and printstring(event_message) %unless event_message=""
norest:
  newline; printstring("Stopped at")
  %if linenum#0 %start
    printstring(" line "); write(linenum,0)
  %finish
  %if linenum=0 %or e=0 %start
    printstring(" PC "); phex(event_pc)
  %finish
  newline
%end

%integerfn handle event; ! Unwind stack frames until event trap is found
%constinteger bsr=16_6100,jsrel=16_4eba,bra=16_6000,link=16_4e50
%constinteger jmpabslong=16_4ef9,moveltoa6=16_2c7c
%constinteger jsra6=16_4eae,jsrabsshort=16_4eb8,jsrabslong=16_4eb9
%integer frame,bit=1<<event_event
%integer retad,entry,eventbeg,eventend,temp,olda6{},i
%integername a4,a5,a6,fp,sp

  %predicate ok(%integer lo,hi); ! False if access would cause BE or HANG
    %falseunless lo<=hi %and lo&1=0
    %trueif 16_800000<=lo %and hi<topstore
    %trueif 0<=lo %and hi<=16_3ff7
    %false
  %end

!  %returnif event_event=9 %and event_subevent=3 %and event_extra=0;!FShangup

! A4 and A5 are assumed to be used as base registers.  Their values
! are interpreted as stack frame pointers established using the
! LINK instruction, but only if they point into the stack at an
! even address.  The lower of A4 and A5 is selected as pointing to
! the most recent stack frame.  It is assumed to point at a pair
! (Old Frame Pointer, Return Address).  The return address is used
! to find the BSR instruction which called the current procedure,
! thereby locating its entry-point.  As confirmation, the first
! instruction of the thus located procedure is verified to be a
! LINK instruction with the appropriate register number.  The word
! preceeding the entry point is taken to be the event mask, bit i
! being set if event i is trapped at this level. The word
! preceeding that is taken to be the relative displacement of the
! (start of the) event block.  The trap is ignored if the event was
! signalled from within that event block, so we need to know where
! the end is.  We assume that the event block is preceeded by a BRA
! instruction to just past the event block.

{}selectoutput(0) %if testing#0
  a4 == event_r(12); a5 == event_r(13); a6 == event_r(14); sp == event_r(15)
  %cycle
    %cycle
{}%if testing#0 %start
{}  printstring("PC="); phex(event_pc)
{}  printstring(" SP="); phex(sp)
{}%finish
      frame = 0; fp == sp
      frame = 5 %and fp == a5 %if ok(a5,a5+7) %and sp<=a5
      frame = 4 %and fp == a4 %if ok(a4,a4+7) %and sp<=a4 %c
                              %and (frame=0 %or a4<fp)
!!    frame = 3 %and fp == a3 %if ok(a3,a3+7) %and sp<=a3 %c
!!                            %and (frame=0 %or a3<fp)
{}%if testing#0 %start
{}  printstring(" A"); write(frame,0); printsymbol('='); phex(fp)
{}%finish
      %result=1 %if frame=0
      retad = integer(fp+4)
      olda6 = a6
{}%if testing#0 %start
{}  printstring(" Retad="); phex(retad)
{}  printstring(" A6="); phex(a6)
{}%finish
      %result=2 %unless ok(retad-6,retad-1)
{}%if testing#0 %start
{}  newline; whex(shortinteger(retad-i)) %and space %for i = 8,-2,2
{}  printsymbol('*'); space %and whex(shortinteger(retad+i)) %for i = 0,2,6
{}%finish
      %if shortinteger(retad-4)=bsr %start
{}printstring(" BSR") %if testing#0
        entry = shortinteger(retad-2)+retad-2
      %elseif shortinteger(retad-4)=jsrel %start
{}printstring(" JSR PC") %if testing#0
        entry = shortinteger(retad-2)+retad-2
      %elseif shortinteger(retad-4)=jsrabsshort %start
{}printstring(" JSR.W") %if testing#0
        entry = shortinteger(retad-2)
      %elseif shortinteger(retad-4)=jsra6 %start
{}printstring(" JSR A6=") %if testing#0
        %result=3 %unless ok(fp+8,fp+11)
        a6 = integer(fp+8)
{}phex(a6) %and space %if testing#0
        temp = a6+shortinteger(retad-2)
{}printsymbol('@') %and phex(temp) %if testing#0
        %result=4 %unless ok(temp,temp+11)
{}%if testing#0 %Start
{}  newline; whex(shortinteger(temp)); space
{}  phex(integer(temp+2)); space
{}  whex(shortinteger(temp+6)); space
{}  phex(integer(temp+8)); newline
{}%finish
        %result=5 %unless shortinteger(temp)=moveltoa6 %c
                 %and shortinteger(temp+6)=jmpabslong
        %result=6 %unless integer(temp+2)=olda6
        entry = integer(temp+8)
      %elseif shortinteger(retad-6)=jsrabslong %start
{}printstring(" JSR.L") %if testing#0
        entry = integer(retad-4)
      %finishelseresult=7
      %cycle
{}newline %and phex(entry) %and space %if testing#0
        %result=8 %unless ok(entry-4,entry+3)
{}%if testing#0 %Start
{}  phex(integer(entry-8))
{}  phex(integer(entry-4)); printsymbol(':')
{}  phex(integer(entry)); phex(integer(entry+4))
{}%finish
        temp = shortinteger(entry)
        %if temp=bra %start
          entry = shortinteger(entry+2)+entry+2
        %elseif temp=jmpabslong %start
          entry = integer(entry+2)
        %finishelseexit;                       ! Not stepping stone ->
      %repeat
{}newline %if testing#0
      %result=9 %unless temp=link+frame
      %exitif shortinteger(entry-2)&bit#0;     ! Trap found ->
      sp = fp+8; fp = integer(fp);             ! Simulate UNLK, RTS
    %repeat
    eventbeg = shortinteger(entry-4)+entry-4
{}printstring("EB=") %and phex(eventbeg) %if testing#0
    %result=10 %unless ok(eventbeg-4,eventbeg-1)
{}space %and phex(integer(eventbeg-4)) %if testing#0
    %result=11 %unless shortinteger(eventbeg-4)=bra
    eventend = shortinteger(eventbeg-2)+eventbeg-2
{}printstring(" EE=") %and phex(eventend) %and newline %if testing#0
    %result=12 %unless ok(eventbeg,eventend-1)
    a6 = olda6 %andexitunless eventbeg<event_pc<=eventend
    sp = fp+8; fp = integer(fp)
  %repeat
  sp = fp+shortinteger(entry+2);  !simulate link
  event_r(8) = eventbeg
  temp = addr(event_r(0))
  *move.l temp,a0
  *movem.l (a0),#16_ffff
  *jmp (a0)
%end

cylock = 0
printstring("Exec version ".version); newline
event_event = -1
define event handler
%unless event_event=-1 %start
  trouble = handle event;        !Returns only if trouble
  selectoutput(0)
  set terminal mode(tmode)
  printstring("*Trouble("); write(trouble,0); printstring("):")
  uclose all outs; close all ins
  selectoutput(0); diagnose
  newline;  newline
  printstring("Rebooting.....")
  newline;  newline
  %for i = 1, 1, 1 000 000 %cycle;  %repeat
  *move.w #16_2700,d0; *trap#0; !Get privilege
  *move.l 0,sp; *move.l 4,-(sp)
  *rts
%finish

event_event = 0
*sub.l #2048,sp
obeyfile(defowner."startup".defext)
%cycle
  obey(0,0)
%repeat

%endofprogram