!Graham Toal - new development version of SKIMPD 13/02/80 13.27

const string (1) snl = "
"

const integer true = 0, false = 1

external integer array spec a(1 : 500)

external byte integer array spec named(1 : 1024)

external integer array spec namedlink(0 : 255)

external integer array spec taglink(0 : 255)

external integer array spec tag(1 : 512)

external integer array spec link(1 : 512)

external integer array spec nextrad(0 : 15)

external integer array spec rt(0 : 15)

external integer array spec parms(0 : 15)

external string (5) array spec display(0 : 15)

external integer faults = 0
external integer spec tagasl, level, tagsopt, nextcad, namedp, c
 traceopt, aopt, pstr
!-----------------------------------------------------------------------
external integer fn spec intstr(string (6) val)
external routine spec expr(integer exprp)
routine spec popitem(integer name f, l)
! Local
external integer fn spec outstream
!-----------------------------------------------------------------------
own integer array used(0 : 15) = 0(*)

own integer array worklist(0 : 15) = 0(16)

own integer array namelist(0 : 15) = 0(16)

own integer array branchlist(0 : 15) = 0(16)

own integer array startlist(0 : 15) = 0(16)

own integer array cot(0 : 127)

own integer cotp, params
!-----------------------------------------------------------------------
external string (255) fn strint(integer n, p)
   string (255) r
   string (1) s
   if n < 0 then s = "-" and n = -n else s = ""
   r = ""
   r = tostring(n - n // 10 * 10 + '0') . r and n = n // 10 until n = 0
   r = s . r
   r = " " . r while length(r) < p
   result = r
end
!-----------------------------------------------------------------------
external string (7) fn s(integer i)
   result = strint(i, 0)
end
!-----------------------------------------------------------------------
external string (8) fn strhex(integer n)
   const string (1) array h(0 : 15) = c
"0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F"

   integer i
   string (8) sh
   sh = ""
   for i = 1, 1, 8 cycle
      sh = h(n & 16_F) . sh
      n = n >> 4
   repeat
   result = sh
end
!-----------------------------------------------------------------------
external routine fault(string (63) mess)
   integer st
   printstring("?  " . mess . "

")
   st = outstream
   selectoutput(0)
   printstring("*" . mess . snl)
   selectoutput(st)
   faults = faults + 1
end
!-----------------------------------------------------------------------
external routine dump(string (7) lab, op, reg, addr)
   own string (7) label = ""
   routine spec codeout(string (7) l, o, r, a)
   if label # "" start
      if lab = "" then lab = label else start
         codeout(label, "EQU", "", "*")
         label = ""
      finish
   finish
   if (op = "ADD" or op = "SUB" or op = "EOR" or op = "OR") and addr = "#0" then return
   if (op = "AND" or op = "LD") and reg # "D" and addr = "#0" then op = "CLR" and addr = ""
   if op = "ADD" and addr = "#1" and reg # "D" then start
      op = "INC"
      addr = ""
   finish
   if op = "SUB" and addr = "#1" and reg # "D" then start
      op = "DEC"
      addr = ""
   finish
   if op = "CMP" and addr = "#0" and reg # "D" then op = "TST" and addr = ""
   if op = "EQU" and addr = "*" then label = lab c
   else label = "" and codeout(lab, op, reg, addr)

   routine codeout(string (7) lab, op, reg, addr)
      string (6) nums
      integer i
      routine dump2(string (7) lab, op, reg, addr)
         own string (7) lastop = "silly"
         own integer inhibit = 0
         if reg = "B" and op = "LD" and addr -> ("#") . nums c
           and (not nums -> ("-") . nums) and intstr(nums) > 255 then reg = "D"
         if lab # "" then start
            if op = "EQU" and addr = "*" then inhibit = 0
            if op # "EQU" then inhibit = 0
         finish
         if inhibit = 0 or op = "EQU" then start
            lastop = op
            return if op = "TST" and reg = "B" and lab = ""
            !   ****FRIG****
            if op = "CMP" and addr = "#1" then addr = "" and op = "DEC"
            printstring(lab)
            spaces(10 - length(lab))
            op = op . reg
            printstring(op)
            spaces(10 - length(op))
            printstring(addr)
            newline
            nextcad = nextcad + 1
         finish
         if op = "LBRA" or op = "SWI2" or (op = "SWI" and reg = "2") c
           then inhibit = 1
         return unless op = "LBSR"
         if addr = "SHL" then used(12) = 1
         if addr = "SHR" then used(13) = 1
         if addr = "EXP" then used(14) = 1
         if addr = "DIV" then used(15) = 1
      end
      own string (7) array l(1 : 2) = ""(2)

      own string (7) array o(1 : 2) = ""(2)

      own string (7) array r(1 : 2) = ""(2)

      own string (7) array a(1 : 2) = ""(2)

      own integer buffptr = 0
      switch load(0:2)
      switch store(0:2)
      routine flushbuffer
         integer i
         for i = 1, 1, buffptr cycle
            dump2(l(i), o(i), r(i), a(i))
         repeat
         buffptr = 0
      end
      routine checklabel(integer buff)
         if buff = 3 then start
            if lab # "" then dump2(lab, "EQU", "", "*")
            return
         finish
         if l(buff) # "" then dump2(l(buff), "EQU", "", "*")
      end
      routine savethisinstr
         buffptr = buffptr + 1
         if buffptr > 2 then start
            printstring("*?????Buffer full..." . snl)
            flushbuffer
         finish
         l(buffptr) = lab
         o(buffptr) = op
         r(buffptr) = reg
         a(buffptr) = addr
      end
      if op = "SEX" and buffptr # 0 and o(buffptr) = "LD" c
      and a(buffptr) -> ("#") . nums and (not nums -> ("-") . nums) c
      and intstr(nums) > 255 then return
      if reg # "B" then start
         flushbuffer
         dump2(lab, op, reg, addr)
         return
      finish
      if op = "LD" then start
         -> load(buffptr)
load(0): 
         savethisinstr
         return
load(1): 
         if o(1) = "LD" then checklabel(1) and buffptr = 0 else start
            if o(1) = "ST" and a(1) = addr then start
               if lab # "" then start
                  flushbuffer
                  savethisinstr
                  return
               finish else return
            finish
         finish
         savethisinstr
         return
load(2): 
         dump2(l(1), o(1), r(1), a(1))
         l(1) = l(2)
         r(1) = r(2)
         o(1) = o(2)
         a(1) = a(2)
         buffptr = 1
         printstring("?***** Unexpected third el = load" . snl)
         -> load(1)
      finish
      if op = "ST" then start
         -> store(buffptr)
store(0): 
         savethisinstr
         return
store(1): 
         if o(1) = "LD" or o(1) = "ST" then start
            if a(1) = addr then start
               if lab # "" then start
                  flushbuffer
                  savethisinstr
                  return
               finish else return
            finish else start
               flushbuffer
               savethisinstr
               return
            finish
         finish
         if o(1) = "CLR" then start
            checklabel(1)
            buffptr = 0
            dump2(lab, "CLR", "", addr)
            return
         finish
         flushbuffer
         savethisinstr
         return
store(2): 
         if o(1) = "LD" and a(1) = addr and (o(2) = "INC" or o(2) = "DEC" c
           or o(2) = "NEG" or o(2) = "COM") then start
            checklabel(2)
            checklabel(3)
            dump2(l(1), o(2), "", addr)
            buffptr = 0
            return
         finish
         dump2(l(1), o(1), r(1), a(1))
         l(1) = l(2)
         o(1) = o(2)
         r(1) = r(2)
         a(1) = a(2)
         buffptr = 1
         -> store(1)
      finish
      if op = "TST" then start
         if buffptr # 0 then start
            if o(buffptr) = "LD" then start
               dump2(l(buffptr), op, "", a(buffptr))
               checklabel(3)
               buffptr = buffptr - 1
               return
            finish
         finish
         flushbuffer
         dump2(lab, op, reg, addr)
         return
      finish
      if op = "INC" or op = "DEC" or op = "CLR" or op = "NEG" c
        or op = "COM" then start
         if buffptr = 2 then start
            dump2(l(1), o(1), r(1), a(1))
            l(1) = l(2)
            o(1) = o(2)
            r(1) = r(2)
            a(1) = a(2)
            l(2) = lab
            o(2) = op
            r(2) = reg
            a(2) = addr
            buffptr = 2
            return
         finish
         savethisinstr
         return
      finish
      flushbuffer
      dump2(lab, op, reg, addr)
   end
end
!-----------------------------------------------------------------------
external string (255) fn name(integer ident)
   unless 0 <= ident <= 255 and namedlink(ident) # 0 then result = ""
   result = string(addr(named(namedlink(ident))))
end
!-----------------------------------------------------------------------
external integer fn newtag
   integer i
   if tagasl = 0 then fault("TAG SPACE FULL") and stop
   i = tagasl
   tagasl = link(tagasl)
   result = i
end
!-----------------------------------------------------------------------
external integer fn returntag(integer tagi)
   integer l
   l = link(tagi)
   link(tagi) = tagasl
   tagasl = tagi
   result = l
end
!-----------------------------------------------------------------------
external integer fn getwork
   !%integername cell
   !  cell==worklist(level)
   !  %while cell#0 %cycle
   !    %if tag(cell)<0 %then tag(cell)=-tag(cell) %and %result=tag(cell)
   !    cell==link(cell)
   !  %repeat
   !  cell=newtag
   !  tag(cell)=nextrad(level)
   !  nextrad(level)=nextrad(level)+1
   !  link(cell)=0
   !  %result=tag(cell)
   result = 0
end
!-----------------------------------------------------------------------
external routine returnwork(integer work)
   !%integer cell
   !  cell=worklist(level)
   !  %while cell#0 %cycle
   !    %if tag(cell)=work %then tag(cell)=-work %and %return
   !    cell=link(cell)
   !  %repeat
end
!-----------------------------------------------------------------------
external routine clearwork
   integer cell
   cell = worklist(level)
   cell = returntag(cell) while cell # 0
   worklist(level) = 0
end
!-----------------------------------------------------------------------
external integer fn getcoti(integer const)
   integer coti
   if cotp > 0 then start
      for coti = 0, 1, cotp - 1 cycle
         if cot(coti) = const then result = coti
      repeat
   finish
   if cotp = 128 then fault("CONSTANT TABLE FULL") and stop
   cot(cotp) = const
   cotp = cotp + 1
   result = cotp - 1
end
!-----------------------------------------------------------------------
external routine pushtag(integer ident, form, type, dim, level, rad)
   integer tagi
   if taglink(ident) # 0 and tag(taglink(ident)) >> 16 & 16_F = level c
   then fault("NAME " . name(ident) . " DECLARED TWICE")
   tagi = newtag
   tag(tagi) = form << 28 ! type << 24 ! dim << 20 ! level << 16 ! rad
   link(tagi) = taglink(ident)
   taglink(ident) = tagi
   tagi = newtag
   tag(tagi) = ident
   link(tagi) = namelist(level)
   namelist(level) = tagi
end
!-----------------------------------------------------------------------
external routine poptags
   integer cell, ident, nametag, params
   string (63) s
   if tagsopt = 1 then newline
   cell = namelist(level)
   while cell # 0 cycle
      ident = tag(cell)
      cell = returntag(cell)
      nametag = tag(taglink(ident))
      taglink(ident) = returntag(taglink(ident))
      if tagsopt = 1 then start
         s = name(ident)
         printstring(strint(ident, 3) . "   " . s)
         spaces(10 - length(s))
         printstring(strhex(nametag))
      finish
      if nametag >> 28 = 4 then start
         ! procedure type
         params = nametag >> 20 & 16_F
         while params # 0 cycle
            if tagsopt = 1 then printstring("
                    " . strhex(tag(taglink(ident))))
            taglink(ident) = returntag(taglink(ident))
            params = params - 1
            ! pop up parameter tags
         repeat
      finish
      if tagsopt = 1 then newline
      if taglink(ident) = 0 then namedp = namedlink(ident) and namedlink(ident) = 0
      ! backtrack name dictionary
   repeat
   if tagsopt = 1 then newline
   namelist(level) = 0
end
!-----------------------------------------------------------------------
external integer fn getlabel(integer constp)
   integer label
   label = a(constp + 1)
   if label > 9999 then fault("LABEL " . strint(label, 1) . " TOO LARGE") c
     and result = -1 else result = label
end
!-----------------------------------------------------------------------
external routine filllabel(integer label)
   !%integer cell
   return if label < 0
   ! for conditional statements
   !  cell=branchlist(level)
   !  %while cell#0 %cycle
   !    %if tag(cell)>>16=label %then %start
   !      %if tag(cell)&16_8000=0 %then fault("DUPLICATE LABEL ". !        strint(label,1)) %else %start
   dump("L" . s(label), "EQU", "", "*")
   !        tag(cell)=label<<16!nextcad
   !      %finish
   !      %return
   !    %finish
   !    cell=link(cell)
   !  %repeat
   !  cell=newtag
   !  link(cell)=branchlist(level)
   !  branchlist(level)=cell
   !  tag(cell)=label<<16!nextcad
end
!-----------------------------------------------------------------------
external integer fn fillbranch(integer label)
   integer cell, cad
   result = 0 if label < 0
   cell = branchlist(level)
   while cell # 0 cycle
      if tag(cell) >> 16 = label then start
         cad = tag(cell) & 16_7FFF
         if tag(cell) & 16_8000 # 0 then tag(cell) = label << 16 ! 16_8000 ! nextcad
         result = cad
      finish
      cell = link(cell)
   repeat
   cell = newtag
   link(cell) = branchlist(level)
   branchlist(level) = cell
   tag(cell) = label << 16 ! 16_8000 ! nextcad
   result = 0
end
!-----------------------------------------------------------------------
external routine poplabels
   integer cell
   cell = branchlist(level)
   while cell # 0 cycle
      if tag(cell) & 16_8000 # 0 then fault("LABEL " . strint(tag(cell) >> 16, 1) . c
        " NOT SET (BRANCH LIST " . strint(tag(cell) & 16_7FFF, 1) . ")")
      cell = returntag(cell)
   repeat
   branchlist(level) = 0
end
!-----------------------------------------------------------------------
external integer fn nextplabel
   own integer plabel = 9999
   plabel = plabel + 1
   result = plabel
end
!-----------------------------------------------------------------------
external routine pushstart(integer flag, plab)
   integer cell
   cell = newtag
   tag(cell) = flag << 16 ! plab & 16_FFFF
   ! plab may be -1
   link(cell) = startlist(level)
   startlist(level) = cell
end
external integer fn find(integer type, integer name t, lab)
   integer cell
   cell = startlist(level)
   while cell # 0 cycle
      t = tag(cell) >> 16
      if t & 2 = type then start
         lab = tag(cell) & 16_FFFF
         result = true
      finish
      cell = link(cell)
   repeat
   t = 0
   lab = 0
   result = false
end
external routine findcontinue(integer name type, lab)
   if find(2, type, lab) = true then lab = lab + 1 c
   else type = 0 and lab = 0 and fault("%CYCLE MISSING")
end
external routine findexit(integer name type, lab)
   if find(2, type, lab) = true then lab = lab + 2 c
   else type = 0 and lab = 0 and fault("%CYCLE MISSING")
end
integer fn findcycle
   integer t, l
   if find(2, t, l) = true then result = true
   result = false
end
integer fn findstart
   integer t, l
   if find(0, t, l) = true then result = true
   result = false
end
external routine popcycle(integer name type, lab)
   popitem(type, lab)
   if type & 2 = 0 then start
      if findcycle = true then start
         fault("%FINISH MISSING {Or spurious %REPEAT??}")
      finish else start
         fault("SPURIOUS %REPEAT")
         pushstart(type, lab) if lab # 0
      finish
      lab = 0
      type = 3
   finish
end
external routine popstart(integer name type, lab)
   popitem(type, lab)
   if type & 2 = 2 or lab = 0 then start
      if findstart = true then start
         fault("%REPEAT MISSING {Or spurious %FINISH??}")
      finish else start
         fault("SPURIOUS %FINISH")
         pushstart(type, lab) if lab # 0
      finish
      lab = 0
      type = 0
   finish
end
!-----------------------------------------------------------------------
routine popitem(integer name flag, plab)
   integer cell
   cell = startlist(level)
   if cell = 0 then start
      flag = 0
      plab = 0
   finish else start
      flag = tag(cell) >> 16
      plab = tag(cell) & 16_FFFF
      if plab = 16_FFFF then plab = -1
      startlist(level) = returntag(cell)
   finish
end
!-----------------------------------------------------------------------
external routine clearstart
   integer cell
   const string (7) array what(0 : 1) = "%FINISH", "%REPEAT"

   cell = startlist(level)
   while cell # 0 cycle
      fault(what(tag(cell) >> 17) . " MISSING")
      cell = returntag(cell)
   repeat
   startlist(level) = 0
end
!-----------------------------------------------------------------------
external integer fn enter
   own string (4) array regs(1 : 2) = "A", "A,B"

   string (4) base
   integer alloc, dim
   if level = 1 then start
      if nextcad # 1 then fault("%BEGIN NOT FIRST STATEMENT")
      dump("", "ORG", "", "$F800")
      dump("START", "EQU", "", "*")
      dump("", "SWI", "3", "") if traceopt = 1
      dump("", "LD", "U", "#STACK")
      dump("", "LEA", "X", "-USTK,U")
      base = ",X"
      alloc = 34
      ! Already set up by calling program
      ! Rest for I/O buffers and perm locations.
   finish else start
      ! STORE STP (=Y) IF NECCESARY
      if level > 2 start
         dump("", "ST", "Y", display(level - 1))
      finish
      dump("", "PSH", "S", "Y")
      dump("", "TFR", "", "S,Y")
      alloc = 0
      base = ",Y"
   finish
   !  cad=nextcad
   if level # 1 then start
      ! REMOVED TO 'SKIMPB'
   finish else start
      dump("", "LEA", "S", "-A" . s(rt(level)) . ",X")
   finish
   nextrad(level) = alloc
   result = alloc
end
!-----------------------------------------------------------------------
external routine dumpreturn
   dump("", "TFR", "", "Y,S")
   dump("", "PUL", "S", "Y,PC")
end
!-----------------------------------------------------------------------
external routine array(integer arrayp)
   integer namep, actualp, exprp, exprsp, ident, nametag, basep, disp
   string (4) base
   namep = a(arrayp + 1)
   actualp = a(arrayp + 2)
   ident = a(namep + 1)
   if a(actualp) = 1 then start
      dump("  ", "CLR", "A", "")
      dump("", "ANDCC", "", "0")
      exprp = a(actualp + 1)
      exprsp = a(actualp + 2)
      expr(exprp)
      nametag = tag(taglink(ident))
      basep = nametag >> 16 & 16_F
      base = display(basep)
      base = ",Y" if basep = level
      base = ",X" if basep = 1
      disp = nametag & 16_FFFF
      dump("", "BCC", "", "*+3")
      dump("", "INC", "A", "")
      if basep = 1 or basep = level start
         dump("", "ADD", "D", "-" . s(disp) . base)
      finish else start
         dump("", "PSH", "U", "A,B")
         dump("", "LD", "D", display(basep))
         dump("", "SUB", "D", "#" . s(disp))
         dump("", "ST", "D", "0,X")
         dump("", "LD", "D", "[0,X]")
         dump("", "ADD", "D", ",U++")
      finish
      dump("", "ST", "D", "0,X") if aopt = 0
      aopt = 0
      !    dump("ADD","ACC",display(nametag>>16&16_f),nametag&16_ffff)
      if a(exprsp) = 1 then fault("ARRAY " . name(ident) . " HAS EXTRA INDEX")
   finish else fault("ARRAY " . name(ident) . " HAS NO INDEX")
end
!-----------------------------------------------------------------------
external routine proc(integer procp)
   string (4) opn, base, reg
   integer namep, ident, nametag, ptagl, l, actualp, exprp, unaryp, operandp, c
     npars, ptag, pnamep, pident, pnametag, pactualp, disp, exprrestp, exprsp, c
     oldparams, basep, size
   !  %if params>2 %then dump("LDA","STP","STP",params)
   !***! hack !***!
   if params >= 2 then dump("", "LEA", "S", "-" . s(params + 1) . ",S")
   !***! hack !***!
   oldparams = params
   params = 4
   namep = a(procp + 1)
   actualp = a(procp + 2)
   ident = a(namep + 1)
   l = taglink(ident)
   nametag = tag(l)
   ptagl = link(l)
   npars = nametag >> 20 & 16_F
   if npars = 0 then start
      if a(actualp) = 1 then fault(name(ident) . " HAS PARAMETERS") and return
   finish else start
      if a(actualp) = 2 then fault(name(ident) . " MISSING PARAMETERS") and return
      exprp = a(actualp + 1)
      exprsp = a(actualp + 2)
      cycle 
         ! for each parameter
         ptag = tag(ptagl)
         if ptag >> 28 = 0 then expr(exprp) and reg = "B" else start
            reg = "D"
            unaryp = a(exprp + 1)
            operandp = a(exprp + 2)
            exprrestp = a(exprp + 3)
            unless a(unaryp) = 4 and a(operandp) = 1 and a(exprrestp) = 2 c
         then fault("NOT A %NAME PARAMETER") else start
               pnamep = a(operandp + 1)
               pactualp = a(operandp + 2)
               pident = a(pnamep + 1)
               !?          %if taglink(pident)=0 %then fault(name(pident). !?            " NOT DECLARED") %else %start
               if taglink(pident) = 0 then start
                  dump("", "LD", "B", name(pident))
               finish else start
                  pnametag = tag(taglink(pident))
                  if pnametag >> 28 = 4 then fault(name(pident) . " NOT A %NAME") else start
                     basep = pnametag >> 16 & 16_F
                     base = display(basep)
                     disp = pnametag & 16_FFFF
                     base = "Y" if basep = level
                     base = "X" if basep = 1
                     if ptag >> 28 = 1 then start
                        ! %name
                        if pnametag >> 28 >= 2 then aopt = 1 and array(operandp) else start
                           if pnametag >> 28 = 1 then start
                              if 1 < basep < level start
                                 dump("", "LD", reg, base)
                                 dump("", "SUB", reg, "#" . s(disp))
                                 dump("", "ST", reg, "0,X")
                                 dump("", "LD", reg, "[0,X]")
                              finish else start
                                 dump("", "LD", reg, "-" . s(disp) . "," . base)
                              finish
                           finish else start
                              if 1 < basep < level start
                                 dump("", "LD", reg, base)
                                 dump("", "SUB", reg, "#" . s(disp))
                              finish else start
                                 if basep = 1 = level then start
                                    dump("", "LEA", "Y", "-" . s(disp) . ",X")
                                    reg = "Y"
                                 finish else start
                                    dump("", "TFR", "", base . ",D")
                                    dump("", "SUB", reg, "#" . s(disp))
                                 finish
                                 ! GET ADDRESS OF A %NAME INTO B
                              finish
                           finish
                           !   CHECK FOR SILLY BASE REGISTER
                           !                  dump(opn,"ACC",base,disp)
                           if a(pactualp) = 1 then fault(name(pident) . " DECLARED AS SCALAR")
                        finish
                     finish else start
                        !                dump("LOAD","ACC",base,disp)    ;! %array
                        if base = "Y" or base = "X" start
                           dump("", "LD", reg, "-" . s(disp) . "," . base)
                        finish else start
                           dump("", "LD", reg, base)
                           dump("", "SUB", reg, "#" . s(disp))
                           dump("", "ST", reg, "0,X")
                           dump("", "LD", reg, "[0,X]")
                        finish
                        !   CHECK SILLY BASE REGISTER
                        if a(pactualp) = 1 then fault("%ARRAYNAME " . name(pident) . " HAS INDEX")
                     finish
                  finish
               finish
            finish
         finish
         !      dump("STR","ACC","STP",params)
         if reg = "D" or reg = "Y" then size = 2 else size = 1
         params = params + size
         dump("", "ST", reg, "-" . s(params) . ",S")
         npars = npars - 1
         if npars = 0 then start
            if a(exprsp) = 1 then fault(name(ident) . " HAS EXTRA PARAMETERS")
            exit
         finish
         ptagl = link(ptagl)
         if a(exprsp) = 2 then fault(name(ident) . " IS MISSING PARAMETERS") and exit
         exprp = a(exprsp + 1)
         exprsp = a(exprsp + 2)
      repeat
   finish
   ! external i/o routines at level 0
   if nametag >> 16 & 16_F = 0 then base = "EXT" else base = "E"
   if nametag >> 16 & 16_F = 0 then start
      used(nametag & 16_F) = 1
   finish
   dump("", "LBSR", "", base . s(nametag & 16_FFFF))
   params = oldparams
   !                      EH??????
   !***! frig !***!
   if params >= 2 then dump("", "LEA", "S", s(params + 1) . ",S")
   !  %if params>2 %then dump("SUB","STP","COT",getcoti(params))
end
!-----------------------------------------------------------------------
external routine endofprog
   integer i
   dump("", "SWI", "2", "")
   dump("STACK", "EQU", "", "$0800-1")
   dump("USTK", "EQU", "", "$20")
   !  DUMP("EXT1","EQU","","") %IF USED(1)=1
   !  DUMP("EXT2","EQU","","") %IF USED(2)=1
   !  DUMP("EXT3","EQU","","") %IF USED(3)=1
   !  DUMP("EXT4","EQU","","") %IF USED(4)=1
   !  DUMP("EXT5","EQU","","") %IF USED(5)=1
   !  DUMP("EXT6","EQU","","") %IF USED(6)=1
   !  DUMP("EXT7","EQU","","") %IF USED(7)=1
   !  DUMP("EXT8","EQU","","") %IF USED(8)=1
   !  DUMP("EXT9","EQU","","") %IF USED(9)=1
   !  DUMP("EXT10","EQU","","") %IF USED(10)=1
   !! READSYMBOL POSING AS READ
   !  DUMP("EXT11","EQU","","") %AND USED(15)=1 %IF USED(11)=1
   if used(12) = 1 then start
      dump("DOSHL", "LSL", "B", "")
      dump("", "SUB", "A", "#1")
      dump("SHL", "CMP", "A", "#0")
      dump("", "BGT", "", "DOSHL")
      dump("", "RTS", "", "")
   finish
   if used(13) = 1 then start
      dump("DOSHR", "LSR", "B", "")
      dump("", "SUB", "A", "#1")
      dump("SHR", "CMP", "A", "#0")
      dump("", "BGT", "", "DOSHR")
      dump("", "RTS", "", "")
   finish
   if used(14) = 1 then start
      dump("EXP", "PSH", "S", "B")
      dump("EXP2", "CMP", "A", "#1")
      dump("", "BGT", "", "DOEXP")
      dump("", "LEA", "S", "1,S")
      dump("", "RTS", "", "")
      dump("DOEXP", "PSH", "U", "A")
      dump("", "LDA", "", "0,S")
      dump("", "MUL", "", "")
      dump("", "PUL", "U", "A")
      dump("", "SUB", "A", "#1")
      dump("", "BRA", "", "EXP2")
   finish
   if used(15) = 1 then start
      ! 'B'//'A'
      dump("DIV", "EQU", "", "*")
      dump("", "CLR", "", "-1,S")
      dump("", "CLR", "", "-2,S")
      dump("", "INC", "", "-2,S")
      dump("", "TST", "B", "")
      dump("", "BGE", "", "TRYA")
      dump("", "NEG", "B", "")
      dump("", "CLR", "", "-2,S")
      dump("TRYA", "TST", "A", "")
      dump("", "BGE", "", "OK")
      dump("", "NEG", "A", "")
      dump("", "TST", "", "-2,S")
      dump("", "BNE", "", "OK")
      dump("", "INC", "", "-2,S")
      dump("OK", "TST", "B", "")
      dump("", "BLT", "", "DONE")
      dump("", "INC", "", "-1,S")
      dump("", "PSH", "U", "A")
      dump("", "SUB", "B", ",U+")
      dump("", "BRA", "", "OK")
      dump("DONE", "DEC", "", "-1,S")
      dump("", "TST", "", "-2,S")
      dump("", "BNE", "", "RET")
      dump("", "NEG", "", "-1,S")
      dump("RET", "LD", "B", "-1,S")
      dump("", "RTS", "", "")
   finish else dump("DIV", "EQU", "", "0")
   !  newline
   if pstr # 0 then start
      dump("OUTCH", "LD", "A", "ACIAS")
      dump("", "AND", "A", "#2")
      dump("", "BEQ", "", "OUTCH")
      dump("", "ST", "B", "ACIAD")
      dump("WAITX", "LD", "B", "#$FF")
      dump("", "DEC", "B", "")
      dump("", "BNE", "", "WAITX")
      dump("PSTR", "LD", "B", "[0,S]")
      dump("", "INC", "", "1,S")
      dump("", "BNE", "", "NOCAR")
      dump("", "INC", "", "0,S")
      dump("NOCAR", "CMP", "B", "#$80")
      dump("", "BNE", "", "OUTCH")
      dump("", "RTS", "", "")
   finish
   if faults > 0 start
      begin
         integer st
         st = outstream
         selectoutput(0)
         printstring("Program contains " . s(faults) . " fault")
         printsymbol('s') if faults > 1
         newline
         selectoutput(st)
      end
   finish
   newline
   if faults > 0 then printstring("?" . strint(faults, 4)) else printstring("*NO")
   printstring(" FAULT")
   printsymbol('S') if faults # 1
   printstring(" IN THIS PROGRAM
")
   signal event 13
   ! Not again!!!
end
end of file