!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