%begin; ! Bridging (old-system) -> (new-system) command interpreter

%ownstring(63)title="CLI version 02/04/85"

%recordformat dictf(%integer beg,pos,lim,alt)
%recordformat eventfm(%integer event,(%integer sub %or %integer subevent),
%integer extra,pc,%string(255) message,%integerarray r(0:15))

@16_1000 %shortinteger linenum
@16_1100 %routine etherwrite(%integer port,%bytename buf,%integer length)
@16_1104 %integerfn etherread(%integer port,%bytename buf,%integer max)
@16_1108 %integerfn fcomm(%integer cn,%string(255)s)
@16_117c %integerfn defname(%string(255)s,%record(dictf)%name d,%integer size)
@16_1180 %integerfn refname(%string(255)s,%record(dictf)%name d)
@16_1184 %routine transname(%integer tag,%string(255)%name s)
@16_1188 %routine define event handler
@16_1190 %routine phex2(%integer x)
@16_1194 %routine phex4(%integer x)
@16_1198 %routine phex(%integer x)
@16_3400 %record(eventfm)event
@16_35c4 %shortinteger userno
@16_3652 %shortinteger terminalmode
@16_372c %byteinteger cylock
@16_372d %byteinteger fsport
@16_3f98 %integer mainprogram,mexglob
@16_3fac %integer cliparamad
@16_3fb0 %record(dictf)comdict,fildict,extdict,sysdict
@16_3ff0 %integer freebot,freetop,membot,memtop

%constinteger esc=27
%owninteger trouble,tmode,bottom

%predicate starts(%string(*)%name s,%integer c)
  %falseif length(s)=0
  %falseunless charno(s,1)=c
  %true
%end

%string(255)%fn substring(%string(255) s, %integer from,to)
%string(255) t
  t = ""
  from = 1 %if from<=0
  to = length(s) %if to>length(s)
  %while from <= to %cycle
    t = t.tostring(charno(s,from));  from = from+1
  %repeat
  %result = t
%end

%predicate started(%string(*)%name s,%integer c)
  %falseunless starts(s,c)
  s = substring(s,2,length(s))
  %true
%end

%routine truncate(%string(*)%name s,%integer c)
  %while started(s,c) %cycle
  %repeat
%end

%predicate resolves(%string(*)%name var,fore,
                    %string(255)match,%string(*)%name aft)
%integer i

  %integerfn INDEX(%string(*)%name var,match)
  !Return index position of first occurrence of match within string
  %integer i=0,j,l
    l=length(match)
    %cycle
      %result = 0 %if i > length(var)-l
      i = i+1
      j = 0
      %cycle
        %result = i %if j = l
        j = j+1
      %repeat %until charno(var,i+j-1) # charno(match,j)
    %repeat
  %end

  %routine do aft
    aft = substring(var,i+length(match),length(var)) %if addr(aft) # 0
  %end

  i = index(var,match)
  %false %if i = 0
  %if addr(fore) # 0 %start
    %if addr(fore) # addr(var) %start
      fore = substring(var,1,i-1)
      do aft
    %finish %else %start
      do aft
      length(var) = i-1
    %finish
  %finish %else do aft
  %true
%end

!Aux (%signal does not work)
%routine signal(%integer e,s,i,%string(255)m)
  event_message = m
  event_extra = i
  e = e&15+(s&255)<<4
  *move.l e,d0
  *jsr 16_1114
%end

%routine standardise(%string(*)%name s)
%bytename k
%integer i
  %for i = 1,1,length(s) %cycle
    k == charno(s,i)
    k = k&95 %if 'A'<=k&95<='Z'
  %repeat
%end

%routine lock
  cylock = cylock+1
%end

%routine unlock
  %returnif cylock=0
  cylock = cylock-1
  cylock = 0 %and %signal 0,1 %if cylock=128
%end

{%endoflist

%control 16_8000

%routine diagnose; !Print event message, line number, etc
!%switch main(0:15)
%integer e,s,x,i
%shortintegername ac,ir,sr

! %routine escapes(%string(255)s)
! %integer i
!   %for i = 1,1,length(s) %cycle
!     printsymbol(esc); printsymbol(charno(s,i))
!   %repeat
! %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

  e = event_event&15
  s = event_subevent
  x = event_extra
  %returnif e=0 %and s=0;                !normal %stop
  selectinput(0); resetinput; closeinput
  %returnif e=0 %and s=1;                !^Y
  newline
!  escapes("G3xlXkjb");                   !Reset V200
  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="); phex4(ac)
!    printstring(", Addr="); phex(x)
!    printstring(", IR="); phex4(ir)
!    printstring(", SR="); phex4(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
!  %if s=9 %start
!    %if x=16_11bc %start
!      printstring("Attempt to load FE00 externals")
!    %else
!      printstring("Attempt to call FE00 extracode at ")
!      phex4(x)
!    %finish
!    newline; ->norest
!  %finish
!  ->unknown
!main(1):
!  %if s=4 %start
!    printstring("Division by zero"); ->rest
!  %finish
!  %if s=1 %start
!    printstring("Integer ")
!  %elseif s=2
!    printstring("Real ")
!  %elseif s=3
!    printstring("String ")
!  %finish
!  printstring("Overflow")
!  ->rest
!main(2):
!  %if s=1 %start
!    printstring("Not enough store")
!  %elseif s=2
!    printstring("Output exceeded")
!  %elseif s=3
!    printstring("Time limit exceeded")
!  %finishelse -> unknown
!  ->rest
!main(3):
!  %if s=1 %start
!    printstring("Transmission error")
!  %elseif s=2
!    printstring("Timeout")
!  %elseif s=3
!    printstring("Open failure")
!  %elseif s=4
!    printstring("I/O error")
!  %finishelse ->unknown
!  ->rest
!main(4):
!  printstring("Non-numeric character "); symbol(x)
!  printstring(" in data"); ->norest
!main(5):
!  printstring("Invalid ")
!  %if s=1 %start
!    printstring("%for loop arguments")
!  %elseif s=2
!    printstring("exponent")
!  %elseif s=3
!    printstring("array bounds")
!  %elseif s=4
!    printstring("SUBSTRING arguments")
!  %elseif s=5
!    printstring("type")
!  %else
!    printstring(" arguments")
!  %finish
!  ->rest
!main(6):
!  %if s=1 %start
!    printstring("Value")
!  %elseif s=2
!    printstring("Array index")
!  %elseif s=3
!    printstring("Switch index")
!  %elseif s=4
!    printstring("Event number")
!  %elseif s=5
!    printstring("CHARNO index")
!  %elseif s=6
!    printstring("TOSTRING parameter")
!  %elseif s=7
!    printstring("Stream number")
!  %finish
!  write(x,1); printstring(" out of range"); ->norest
!main(7):
!  printstring("String resolution fails"); ->rest
!main(8):
!  printstring("Unassigned variable"); ->rest
!main(9):
!  printstring("End of file reached"); ->rest
!main(10):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

%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

{%list

%control 16_8000

%integerfn allocate(%integer amount)
  amount = (amount+3)>>2<<2
  %result = 0 %if bottom+amount+1000>freetop
  bottom = bottom+amount
  %result = bottom-amount
%end

%routine loadfile(%string(255)n,%integername s,l)
%string(255)z
%integer x,y,dict
%integer pos=1,blocks,pad

  %integerfn hex
  %integer n=0,k
    %cycle
      %result = n %if pos>=length(z); pos = pos+1
      k = charno(z,pos-1)-'0'
      %result = n %if k<0
      n = n<<4+k
    %repeat
  %end
  
  standardise(n)
  dict = refname(n,fildict)
  %if dict>0 %start                        {If entry exists
    x = integer(dict); y = integer(dict+4)
    %if x<y %start                         {if file remembered
      s = x; l = y-x; %return
    %finish
  %finish
  s = 0; l = 0
  z = "Z".tostring('0'+userno).n.tostring(nl)  {Read file into store
  lock
    etherwrite(fsport,charno(z,1),length(z))
    length(z) = etherread(fsport,charno(z,1),255)
  unlock
  %if charno(z,1)='-' %start
    x = charno(z,2)-'0'; y =length(z)
    y = y-1 %if charno(z,y)=nl {and it ought to be}
    n = "Load ".n
    n = n." fails:"
    z = substring(z,3,y)
    z = n.z
    signal(3,3,x,z)
  %finish
  blocks = hex; pad = hex
  x = blocks<<9-pad
  y = allocate(x)
  %if y<=0 %start
    y = bottom
    lock
      %cycle
        x = etherread(fsport,byteinteger(y),512)
      %repeatuntil x#512
    unlock
    signal(2,1,l,"No space for ".n)
  %finish
  s = y; l = x
  lock
    %cycle
      x = etherread(fsport,byteinteger(y),512)
      y = y+x
    %repeatuntil x#512
  unlock
  %if dict>0 %start
    %if integer(dict)=integer(dict+4)=-1 %start {marked for remembering
      integer(dict) = s; integer(dict+4) = s+l
      freebot = bottom
    %finish
  %finish
%end

%routine define symbol(%string(255)symbol,value)
%integer stag,vtag
  standardise(symbol)
  stag = defname(symbol,comdict,8)
  %if stag=0 %start
    printstring("*Command dict full"); newline; %return
  %finish
  vtag = defname(value,fildict,8)
  %if vtag=0 %start
    printstring("*File dict full"); newline; %return
  %finish
  %if stag<0 %start
    stag = stag<<1>>1
!   printstring(symbol.": ".value." replaces ")
!   transname(integer(stag),symbol); printstring(symbol); newline
  %finish
  integer(stag) = vtag<<1>>1
%end

%control 16_8000

%routine run program(%string(255)file,parm)
%recordformat mex header f(%short magic,flags,export,import,
   %integer code,%short reset,main,%integer own,stack,spare1,spare2)
%record(mexheaderf)%name h
%bytename first,second
%integer start,limit

  %routine run(%integer xpc,xd6)
  %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
        selectinput(0); resetinput; closeinput
      %finish
      close all ins; diagnose; %return
    %finish
    tmode = terminalmode
    *move.l a6,env
    linenum = 0
    *move.l xpc,a0
    *move.l xd6,d6
    *jsr (a0)
    %stop
  %end

  cliparamad = addr(parm)
  bottom = freebot
  loadfile(file,start,limit); limit = limit+start
  first == byteinteger(start)
  second == byteinteger(start+1)
  %unless first=16_fe %start
    printstring("File ".file." starts with ")
    phex2(first); printstring(" instead of FE")
    newline; %return
  %finish
  %while started(parm,' ') %cycle; %repeat
  parm = tostring(255) %if parm=""
  prompt(":"); selectinput(0); selectoutput(0)
  mainprogram = 0
  %if 1<=second<=3 %start; !Mex format
    mainprogram = start
    loadfile("fmac:mexrun.mob",start,limit); limit = limit+start
    parm = "" %if parm = tostring(255)
    h == record(start)
    start = start+32+h_export
    %if h_import!h_own#0 %c
    %or shortinteger(start+h_reset<<1)#16_4e75 %start
      printstring("File fmac:mexrun.mob is not as expected"); newline; %return
    %finish
    run(start+h_main<<1,(bottom+3+256)&\3)
  %else
    printstring("Warning: ".file." starts with FE"); phex2(second); newline
    run(limit-4,(bottom+3+256)&\3)
  %finish
%end

%control 16_8000

%routinespec obeystream(%string(255)parms)

%routine obeyfile(%string(255)verb,parms)
  %onevent 3,4,9 %start
    printstring(event_message); newline
    %return
  %finish
  openinput(1,verb) {Test whether file accessible}
  selectinput(0); closeinput
  openinput(0,verb)
  selectinput(1); closeinput
  selectinput(0)
  obeystream(parms)
%end

%predicate verify
%string(255)x
%integer tag
  tag = refname("VERIFY",comdict)
  %falseif tag<=0
  tag = integer(tag)
  transname(tag,x)
  tag = length(x)
  %falseif tag=0
  tag = charno(x,tag)&1
  %falseif tag=0
  %true
%end

%routine obeyline(%string(255)line)
@0%string(1)null
%string(255)verb,param,spare
%integer tag,pos,sym,lives=9
%constintegerarray bit(0:3) = 0,
{ ?>=<;:9876543210/.-,+*)('&%$#"!
2_01010111111111110100111111111100,
2_11111111111111111111111111111111,
2_01111111111111111111111111111111
    
  %onevent 2,3,4,9 %start
    printstring(event_message); newline
    %return
  %finish

!First parse the line, split it up into verb and parameters.
!Then perform verb translation.

  truncate(line,' '); truncate(line,'{'); truncate(line,' ')
  %if started(line,'@') %start
    truncate(line,' ')
    line = "@".line
  %finish
  %cycle
    verb = ""
    pos = 1
    %cycle
      %exitif pos>length(line); sym = charno(line,pos)
      %exitif bit(sym>>5&3)&1<<(sym&31)=0
      verb = verb.tostring(sym); pos = pos+1
    %repeat
    %returnif verb=""
!!  sym = '=' %and pos = pos+1 %if sym='_'  {suppress symbol translation}
    %if charno(verb,length(verb))='_' %start
      sym = '='; length(verb) = length(verb)-1
    %finish
    param = substring(line,pos,length(line))
    %exitif sym='='
    standardise(verb)
    tag = refname(verb,comdict)
    %exitif tag<=0
    tag = integer(tag)
    transname(tag,verb)
    line = verb.param
    lives = lives-1
    %if lives=0 %start
      printstring("Symbol translation looping: ".line); newline
      verb = ""; %return
    %finish
  %repeat

  %if verify %start
    printstring(verb)
    printstring(param)
    newline
  %finish

!Now decide whether the command is a symbol definition or
!a request to run a program or a request to obey another file.

  %if length(param)>1 %and charno(param,1)='=' %start
    definesymbol(verb,substring(param,2,length(param)))
  %elseif starts(verb,'@')
    verb = substring(verb,2,length(verb))
    verb = verb.".COM" %unless resolves(verb,null,".",null)
    obeyfile(verb,param)
  %else
    verb = verb.".MOB" %unless resolves(verb,null,".",null)
    runprogram(verb,param)
  %finish
%end

%routine obeystream(%string(255)parms)
%string(63)%array parameter(1:8)
%string(255)parm,rest,line
%integer i

  %integerfn nsym
  %integer k
    k = nextsymbol&127
    k = nl %if k<' '
    %result = k
  %end

  %integerfn rsym
  %integer k,x
    x = nsym
    readsymbol(k); %result = x %unless k=esc
    readsymbol(k); %result = x %unless k='?'
    readsymbol(k); %result = x
  %end

  %predicate fits(%integer n)
    %trueif length(line)+n<=255
    %false
  %end

  %routine read line
  %string(63)p
  %integer k,kk,i
    selectinput(0)
    prompt("} ")
    %cycle
      %cycle
        line = ""
        %cycle
          k = rsym; %exitif k=nl
          %if k='%' %and '1'<=nsym<='8' %start
            k = rsym; p = parameter(k-'0')
            %if fits(length(p)) %start
              line = line.p
            %else
              line = line."%" %if fits(1)
              line = line.tostring(k) %if fits(1)
            %finish
          %elseif k='-' %and nsym=nl
            k=rsym
          %else
            line = line.tostring(k) %if fits(1)
          %finish
        %repeat
        %exitunless started(line,'!')
        %continueunless starts(line,'!')
        kk = 0
        %for i = 2,1,length(line) %cycle
          k = charno(line,i); kk = k %unless k=' '
          printsymbol(k)
        %repeat
        newline %unless kk=':'
      %repeat
    %repeatuntil line#""
  %end

  %onevent 0,9 %start
    resetinput; closeinput
    %return
  %finish
  parms = parm." ".rest %while resolves(parms,parm,"  ",rest)
  parms = rest %while resolves(parms,parm," ",rest) %and parm=""
  parms = parm.",".rest %while resolves(parms,parm," ",rest)
  parms = parm.",".rest %while resolves(parms,parm,"/",rest)
  parms = parms.","
  %for i = 1,1,8 %cycle
    parm = "" %unless resolves(parms,parm,",",parms)
    parameter(i) = parm
  %repeat
  %cycle
    readline
    obeyline(line)
  %repeat
%end

!%routine load imp runtime support
!%integer d
!  d = defname("I:LIB.MOB",fildict,8)
!  integer(d) = -1; integer(d+4) = -1
!  obeyline("i:lib")
!  obeyline("fmac:floating")
!%end

{%endoflist
%control 16_8000
%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
%integer retad,entry,eventbeg,eventend,temp,olda6
%integername a4,a5,a6,fp,sp

  %predicate ok(%integer lo,hi); ! False unless accessible
    %falseunless lo<=hi %and lo&1=0
    %trueif membot<=lo %and hi<memtop
    %trueif 0<=lo %and hi<16_4000
    %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.

  bit=1<<event_event
  a4 == event_r(12); a5 == event_r(13); a6 == event_r(14); sp == event_r(15)
  %cycle
    %cycle
      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)
      %result=1 %if frame=0
      retad = integer(fp+4)
      olda6 = a6
      %result=2 %unless ok(retad-6,retad-1)
      %if shortinteger(retad-4)=bsr %start
        entry = shortinteger(retad-2)+retad-2
      %elseif shortinteger(retad-4)=jsrel
        entry = shortinteger(retad-2)+retad-2
      %elseif shortinteger(retad-4)=jsrabsshort
        entry = shortinteger(retad-2)
      %elseif shortinteger(retad-4)=jsra6
        %result=3 %unless ok(fp+8,fp+11)
        a6 = integer(fp+8)
        temp = a6+shortinteger(retad-2)
        %result=4 %unless ok(temp,temp+11)
        %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
        entry = integer(retad-4)
      %finishelseresult=7
      %cycle
        %result=8 %unless ok(entry-4,entry+3)
        temp = shortinteger(entry)
        %if temp=bra %start
          entry = shortinteger(entry+2)+entry+2
        %elseif temp=jmpabslong
          entry = integer(entry+2)
        %finishelseexit;                       ! Not stepping stone ->
      %repeat
      %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
    %result=10 %unless ok(eventbeg-4,eventbeg-1)
    %result=11 %unless shortinteger(eventbeg-4)=bra
    eventend = shortinteger(eventbeg-2)+eventbeg-2
    %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

{%list

mexglob = 0
cylock = 0

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
  selectinput(0); resetinput; closeinput
  selectoutput(0); diagnose
  *sub.l #2048,sp
  %cycle
    obeyfile(":t","")
  %repeat
%finish
event_event = 0
*sub.l #2048,sp

printstring(title); newline
bottom = freebot
!load imp runtime support
obeyfile("fmac:astartup.com","")
%cycle
  obeyfile(":t","")
%repeat

%endofprogram
