!Graham Toal - latest development version of SKIMPB 12/02/80 16.25

const integer true = 0, false = 1

external integer fn spec find(integer flag, integer name ty, la)
external integer array spec a(1 : 500)

external integer array spec taglink(0 : 255)

external integer array spec tag(1 : 512)

external integer array spec link(1 : 512)

!-----------------------------------------------------------------------
external routine spec expr(integer exprp)
external integer fn spec cond(integer condp, tlabel, flabel)
external string (7) fn spec s(integer n)
external string (255) fn spec strint(integer n, p)
external integer fn spec getwork
external routine spec returnwork(integer work)
external routine spec clearwork
external integer fn spec newtag
external routine spec pushtag(integer ident, form, type, dim, level, rad)
external routine spec poptags
external integer fn spec getlabel(integer constp)
external routine spec filllabel(integer label)
external integer fn spec fillbranch(integer label)
external routine spec poplabels
external integer fn spec nextplabel
external routine spec dump(string (7) lab, op, reg, addr)
external routine spec fault(string (63) mess)
external string (255) fn spec name(integer ident)
external routine spec pushstart(integer flag, plab)
external routine spec popstart(integer name flag, plab)
external routine spec findcontinue(integer name type, flag)
external routine spec findexit(integer name type, flag)
external routine spec popcycle(integer name type, lab)
external routine spec clearstart
external integer fn spec enter
external routine spec dumpreturn
external routine spec proc(integer procp)
external routine spec array(integer arrayp)
external routine spec endofprog
!-----------------------------------------------------------------------
external integer array nextrad(0 : 15)

external string (5) array display(0 : 15) = "Bug", "-2,X", "-4,X", c
  "-6,X", "-8,X", "-10,X", "-12,X", "-14,X", "-16,X", "-18,X", "-20,X", c
  "-22,X", "-24,X", "-26,X", "-28,X", "-30,X"

external integer level, nextcad = 1, pstr = 0
!-----------------------------------------------------------------------
own integer array proctype(0 : 15)

own integer array staticalloc(0 : 15)

own string (3) array regs(1 : 2) = "A", "A,B"

external integer array rt(0 : 15)

external integer array parms(0 : 15)

external integer spec traceopt, checkopt
external integer aopt = 0
!-----------------------------------------------------------------------
external routine statement(integer statementp)
   own integer access = 1
   routine spec doloop(integer loopsp)
   routine spec instr(integer instrp)
   string (4) base, b1, b2
   switch sttype(1:13)
   integer condp, instrp, elsep, constp, arrayp, namep, namesp, expr1p, c
     expr2p, instr2p, tlabel, flabel, label, fplabel, tplabel, work1, work2, c
     flag, plabel, procp, formalp, formp, params, procid, ident, form, paramt, c
     paraml, dim, basep, type, cyclab, cntlab, extlab
   -> sttype(a(statementp))
   !-----------------------------------------------------------------------
sttype(1): 
   ! <instr><CYCLAUSE>
   if access = 0 then fault("ACCESS?") and access = 1
   dump("", "SWI", "3", "") if traceopt = 1
   unless a(a(a(statementp + 2) + 1)) = 2 then doloop(a(statementp + 2))
   instr(a(statementp + 1))
   if a(a(a(statementp + 2) + 1)) = 2 then return
   if access = 0 then fault("DUBIOUS STATEMENT") and access = 1
   condp = a(a(a(statementp + 2) + 1) + 1)
   a(1) = 1
   a(2) = 3
   if a(a(statementp + 2)) <= 2 then a(3) = 2 else a(3) = 1
   statementp = 1
   -> untilst
   !-----------------------------------------------------------------------
sttype(2): 
   ! "IF"<cond>"THEN"<instr><else>
   condp = a(statementp + 1)
   instrp = a(statementp + 2)
   elsep = a(statementp + 3)
   if access = 0 then fault("ACCESS?") and access = 1
   dump("", "SWI", "3", "") if traceopt = 1
   if 7 <= a(instrp) <= 8 or a(instrp) = 2 then start
      ! branch
      if a(instrp) = 7 then findcontinue(type, tlabel) c
      else if a(instrp) = 8 then findexit(type, tlabel) else start
         constp = a(instrp + 1)
         tlabel = getlabel(constp)
      finish
      if a(elsep) = 2 then filllabel(cond(condp, tlabel, -1)) else start
         instrp = a(elsep + 1)
         if 7 <= a(instrp) <= 8 or a(instrp) = 2 then start
            ! branch
            if a(instrp) = 7 then findcontinue(type, flabel) c
            else if a(instrp) = 8 then findexit(type, flabel) else start
               constp = a(instrp + 1)
               flabel = getlabel(constp)
            finish
            access = 0
            filllabel(cond(condp, tlabel, flabel))
            dump("", "LBRA", "", "L" . s(flabel))
            return
         finish else start
            filllabel(cond(condp, tlabel, -1))
            if a(instrp) = 3 then pushstart(1, -1) else instr(instrp)
         finish
      finish
   finish else start
      if a(elsep) = 2 then start
         fplabel = cond(condp, -1, -1)
         if a(instrp) = 3 then pushstart(0, fplabel) else instr(instrp) and filllabel(fplabel)
      finish else start
         instr2p = a(elsep + 1)
         if 7 <= a(instr2p) <= 8 or a(instr2p) = 2 then start
            ! branch
            if a(instr2p) = 7 then findcontinue(type, flabel) c
            else if a(instr2p) = 8 then findexit(type, flabel) else start
               constp = a(instr2p + 1)
               flabel = getlabel(constp)
            finish
            fplabel = cond(condp, -1, flabel)
            ! result always -1
            instr(instrp)
         finish else start
            fplabel = cond(condp, -1, -1)
            instr(instrp)
            tplabel = nextplabel
            dump("", "LBRA", "", "L" . s(tplabel))
            filllabel(fplabel)
            if a(instr2p) = 3 then pushstart(1, tplabel) c
            else instr(instr2p) and filllabel(tplabel)
         finish
      finish
   finish
   access = 1
   return
   !-----------------------------------------------------------------------
sttype(3): 
   ! <const>':'<statement>
   access = 1
   constp = a(statementp + 1)
   statementp = a(statementp + 2)
   label = getlabel(constp)
   filllabel(label)
   statement(statementp)
   return
   !-----------------------------------------------------------------------
sttype(4): 
   ! "FINISH"<else>
   access = 1
   elsep = a(statementp + 1)
   popstart(flag, plabel)
   if flag = 0 then start
      ! first %start/%finish
      if a(elsep) = 1 then start
         instrp = a(elsep + 1)
         tplabel = nextplabel
         dump("", "LBRA", "", "L" . s(tplabel))
         filllabel(plabel)
         if a(instrp) = 3 then pushstart(1, tplabel) c
         else instr(instrp) and filllabel(tplabel)
      finish else filllabel(plabel)
   finish else start
      ! second %start/%finish
      if a(elsep) = 1 then fault("SPURIOUS %ELSE") else filllabel(plabel)
   finish
   return
   !-----------------------------------------------------------------------
sttype(5): 
   ! "INTEGER"<array>
   arrayp = a(statementp + 1)
   namep = a(arrayp + 1)
   namesp = a(arrayp + 2)
   if a(arrayp) = 1 then start
      ! array declaration
      dump("", "SWI", "3", "") if traceopt = 1
      if access = 0 then fault("ACCESS?") and access = 1
      if find(2, cyclab, type) = true then fault("ORDER?")
      if level = 1 then base = ",X" else base = ",Y"
      cycle 
         expr1p = a(arrayp + 3)
         expr2p = a(arrayp + 4)
         expr(expr1p)
         dump("", "SEX", "", "")
         dump("", "PSH", "U", "A,B")
         work1 = getwork
         !***dump("STR","ACC",display(level),work1)
         expr(expr2p)
         dump("", "SEX", "", "")
         dump("", "ADD", "D", "#1")
         dump("", "PSH", "U", "A,B")
         dump("", "TFR", "", "S,D")
         !***dump("LDA","ACC","ACC",1)
         work2 = getwork
         !***dump("STR","ACC",display(level),work2)
         cycle 
            staticalloc(level) = staticalloc(level) + 2
            nextrad(level) = nextrad(level) + 2
            pushtag(a(namep + 1), 2, 1, 2, level, nextrad(level))
            dump("", "SUB", "D", "0,U")
            dump("", "ST", "D", "-" . s(nextrad(level)) . base)
            dump("", "ADD", "D", "2,U")
            !        DUMP("","SUB","D","#1")
            !***dump("SUB","STP",display(level),work1)
            !***dump("STR","STP",display(level),nextrad(level))
            !***dump("ADD","STP",display(level),work2)
            if a(namesp) = 2 then exit
            namep = a(namesp + 1)
            namesp = a(namesp + 2)
         repeat
         dump("", "TFR", "", "D,S")
         dump("", "LEA", "U", "4,U")
         returnwork(work1)
         returnwork(work2)
         if a(a(arrayp + 5)) = 1 then start
            arrayp = a(arrayp + 5)
            namep = a(arrayp + 1)
            namesp = a(arrayp + 2)
            continue
         finish else return
      repeat
   finish else start
      cycle 
         staticalloc(level) = staticalloc(level) + 1
         nextrad(level) = nextrad(level) + 1
         pushtag(a(namep + 1), 0, 1, 1, level, nextrad(level))
         if a(namesp) = 2 then exit
         namep = a(namesp + 1)
         namesp = a(namesp + 2)
      repeat
   finish
   return
   !-----------------------------------------------------------------------
sttype(6): 
   ! <proc><name><formal>
   if level = 0 then fault("PROCEDURE BEFORE %BEGIN")
   if level = 15 then fault("PROCEDURE NESTING TOO DEEP")
   access = 1
   procp = a(statementp + 1)
   namep = a(statementp + 2)
   formalp = a(statementp + 3)
   procid = a(namep + 1)
   !  skipproc(level)=nextcad
   pushtag(procid, 4, a(procp) - 1, 0, level, nextcad)
   level = level + 1
   rt(level) = tag(taglink(procid)) & 16_FFFF
   dump("", "LBRA", "", "S" . s(rt(level)))
   dump("E" . s(rt(level)), "EQU", "", "*")
   proctype(level) = a(procp)
   staticalloc(level) = enter
   !  nextrad(level)=2
   parms(level) = 0
   if a(formalp) = 2 then -> retn
   ! no parameters
   params = 0
   paraml = taglink(procid)
   cycle 
      formp = a(formalp + 1)
      namep = a(formalp + 2)
      namesp = a(formalp + 3)
      formalp = a(formalp + 4)
      if a(formp) = 1 then form = 3 and dim = 2 else start
         if a(formp) = 2 then form = 1 and dim = 2 c
         else form = 0 and dim = 1
      finish
      cycle 
         ident = a(namep + 1)
         ! declare parameters as locals
         nextrad(level) = nextrad(level) + dim
         staticalloc(level) = staticalloc(level) + dim
         pushtag(ident, form, 1, dim, level, nextrad(level))
         !      DUMP("","PUL","U",REGS(DIM))
         !      DUMP("","PSH","S",REGS(DIM))
         ! append parameter tag cells to procedure tag cell
         paramt = newtag
         tag(paramt) = tag(taglink(ident))
         link(paramt) = link(paraml)
         link(paraml) = paramt
         paraml = paramt
         parms(level) = parms(level) + dim
         params = params + 1
         if params > 15 then fault(name(procid) . " HAS TOO MANY PARAMETERS") and stop
         if a(namesp) = 2 then exit
         namep = a(namesp + 1)
         namesp = a(namesp + 2)
      repeat
   repeat until a(formalp) = 2
   ! insert number of parameters into tag cell
   tag(taglink(procid)) = tag(taglink(procid)) ! params << 20
retn: 
   dump("", "LEA", "S", "-A" . s(rt(level)) . ",S")
   return
   !-----------------------------------------------------------------------
sttype(7): 
   ! "END"<ofprog>
   if level > 1 start
      !     DUMP("P".S(RT(LEVEL)),"EQU","",S(PARMS(LEVEL)))
      if proctype(level) # 1 and checkopt = 1 then dump("", "SWI", "", "")
      !  %RESULT NOT ENCOUNTERED
      !     DUMP("R".S(RT(LEVEL)),"EQU","","*")
   finish
   poptags
   poplabels
   clearstart
   clearwork
   dump("A" . s(rt(level)), "EQU", "", s(staticalloc(level)))
   if proctype(level) >= 1 and access = 1 then dumpreturn
   access = 1
   level = level - 1
   if a(a(statementp + 1)) = 2 then start
      ! %end
      if level <= 0 then fault("SPURIOUS %END") and endofprog
      dump("S" . s(rt(level + 1)), "EQU", "", "*")
   finish else start
      ! %endofprogram
      if level # 0 then fault("TOO FEW %ENDS")
      endofprog
   finish
   return
   !-----------------------------------------------------------------------
sttype(8): 
   ! "BEGIN"
   if level # 0 then fault("SPURIOUS %BEGIN") else start
      rt(1) = 0
      level = 1
      proctype(1) = 0
      staticalloc(1) = enter
      nextrad(1) = staticalloc(1)
   finish
   return
sttype(9): 
   ! <LOOPS>%CYCLE
   if access = 0 then fault("WARNING - ACCESS???") and access = 1
   dump("", "SWI", "3", "") if traceopt = 1
   doloop(a(statementp + 1))
   return
sttype(10): 
   ! %REPEAT<UNTIL>
   condp = a(a(statementp + 1) + 1)
   dump("", "SWI", "3", "") if traceopt = 1
untilst: 
   access = 1
   popcycle(type, cyclab)
   cntlab = cyclab + 1
   extlab = cntlab + 1
   if a(a(statementp + 1)) # 2 then start
      dump("L" . s(cntlab), "EQU", "", "*")
      tplabel = cond(condp, -1, cyclab)
      if type = 2 then dump("L" . s(extlab), "LEA", "U", "4,U") c
      else dump("L" . s(extlab), "EQU", "", "*")
   finish else start
      dump("L" . s(cntlab), "LBRA", "", "L" . s(cyclab))
      if type = 2 then dump("L" . s(extlab), "LEA", "U", "4,U") c
      else dump("L" . s(extlab), "EQU", "", "*")
   finish
   return
sttype(13): 
   ! "PRINTTEXT" <STRING>
   pstr = 1
   fault("ACCESS?") and access = 1 if access = 0
   dump("", "SWI", "3", "") if traceopt = 1
   dump("", "LBSR", "", "PSTR")
   printstring("          FCB       ")
   work1 = 4
   cycle 
      work2 = a(work1)
      if work2 # 16_80 then write(work2, 0) else printstring("$80") and exit
      printsymbol(',')
      work1 = work1 + 1
   repeat
   newline
   return
sttype(11): 
   ! "CONSTANT" <NAME) '=' <VALUE>
   dump(name(a(a(statementp + 1) + 1)), "EQU", "", s(a(a(statementp + 2) + 1)))
   return
sttype(12): 
   ! "LABEL" <NAME>
   dump(name(a(a(statementp + 1) + 1)), "EQU", "", "*")
   return
   !-----------------------------------------------------------------------
   routine instr(integer instrp)
      switch instype(1:14)
      string (4) base
      integer namep, assignp, constp, ident, actualp, exprp, nametag, c
        disp, work, rinstrp, type, lab
      -> instype(a(instrp))
      !-----------------------------------------------------------------------
instype(1): 
      ! <name><actual><assign>
      namep = a(instrp + 1)
      actualp = a(instrp + 2)
      assignp = a(instrp + 3)
      rinstrp = a(instrp + 4)
      ident = a(namep + 1)
      !?  %if taglink(ident)=0 %then fault(name(ident)." NOT DECLARED") !?    %and %return
      if taglink(ident) = 0 start
         if a(assignp) # 1 then dump("", "FDB", "", name(ident)) c
         else expr(a(assignp + 1)) and dump("", "ST", "B", name(ident))
      finish else start
         nametag = tag(taglink(ident))
         ! %ROUTINE GET NAME ADDRESS ????
         if a(assignp) = 1 then start
            if nametag >> 28 = 4 then fault(name(ident) . " NOT A DESTINATION") and return
            exprp = a(assignp + 1)
            if nametag >> 28 >= 2 then start
               ! array variable
               expr(exprp)
               work = getwork
               dump("", "PSH", "U", "B")
               array(instrp)
               dump("", "PUL", "U", "B")
               dump("", "ST", "B", "[0,X]")
               returnwork(work)
            finish else start
               expr(exprp)
               basep = nametag >> 16 & 16_F
               disp = nametag & 16_FFFF
               base = display(basep)
               base = ",Y" if basep = level
               base = ",X" if basep = 1
               if basep = level or basep = 1 start
                  if nametag >> 28 = 1 then b1 = "[" and b2 = "]" else b1 = "" and b2 = ""
                  dump("", "ST", "B", b1 . "-" . s(disp) . base . b2)
               finish else start
                  dump("", "PSH", "U", "A,B")
                  dump("", "LD", "D", base)
                  dump("", "SUB", "D", "#" . s(disp))
                  dump("", "ST", "D", "0,X")
                  if nametag >> 28 = 1 then start
                     dump("", "LD", "D", "[0,X]")
                     dump("", "ST", "D", "0,X")
                  finish
                  dump("", "PUL", "U", "A,B")
                  dump("", "ST", "B", "[0,X]")
               finish
               if a(actualp) = 1 then fault(name(ident) . " DECLARED AS SCALAR")
            finish
            ! %END OF ROUTINE GET NAME ADDRESS???
         finish else start
            if nametag >> 28 = 4 and nametag >> 24 & 16_F = 0 c
            then proc(instrp) else fault(name(ident) . " NOT A ROUTINE NAME")
         finish
      finish
      if a(rinstrp) = 1 then instrp = a(rinstrp + 1) and -> instype(a(instrp))
      return
      !-----------------------------------------------------------------------
instype(2): 
      ! '->'<const>
      access = 0
      constp = a(instrp + 1)
      label = getlabel(constp)
      dump("", "LBRA", "", "L" . s(label))
      return
      !-----------------------------------------------------------------------
instype(3): 
      ! "START"
      fault("ILLEGAL %START")
      return
      !-----------------------------------------------------------------------
instype(4): 
      ! "RETURN"
      if proctype(level) # 1 then fault("%RETURN OUT OF CONTEXT")
      access = 0
      dumpreturn
      !  DUMP("","LBRA","","R".S(RT(LEVEL)))
      return
      !-----------------------------------------------------------------------
instype(5): 
      ! "RESULT"'='<expr>
      if proctype(level) # 2 then fault("%RESULT OUT OF CONTEXT")
      access = 0
      expr(a(instrp + 1))
      dumpreturn
      !  DUMP("","LBRA","","R".S(RT(LEVEL)))
      return
      !-----------------------------------------------------------------------
instype(6): 
      ! "STOP"
      access = 0
      dump("", "SWI", "2", "")
      !  CALL MONITOR AND HALT?
      return
instype(7): 
      access = 0
      findcontinue(type, lab)
      dump("", "LBRA", "", "L" . s(lab))
      return
instype(8): 
      access = 0
      findexit(type, lab)
      dump("", "LBRA", "", "L" . s(lab))
      return
instype(9): 
      !    <OPCODE> # <CONST>
      dump("", name(a(a(instrp + 1) + 1)), "", "#" . s(a(a(instrp + 2) + 1)))
      return
instype(10): 
      !    <OPCODE>   <CONST>
      dump("", name(a(a(instrp + 1) + 1)), "", s(a(a(instrp + 2) + 1)))
      return
instype(11): 
      !    <OPCODE> # <NAME>
      namep = a(instrp + 2)
      ident = a(namep + 1)
      dump("", name(a(a(instrp + 1) + 1)), "", "#" . name(ident))
      return
instype(12): 
      !    <OPCODE>   <NAME>
      namep = a(instrp + 2)
      ident = a(namep + 1)
      nametag = tag(taglink(ident)) if taglink(ident) # 0
      if taglink(ident) = 0 or nametag >> 28 = 4 start
         dump("", name(a(a(instrp + 1) + 1)), "", name(ident))
      finish else start
         basep = nametag >> 16 & 15
         disp = nametag & 16_FFFF
         base = display(basep)
         base = ",Y" if basep = level
         base = ",X" if basep = 1
         b1 = ""
         b2 = ""
         b1 = "[" and b2 = "]" if nametag >> 28 = 1
         dump("", name(a(a(instrp + 1) + 1)), "", b1 . "-" . s(disp) . base . b2)
      finish
      return
instype(13): 
      !     <OPCODE>   <STRING>
      begin
         string (255) addr
         integer i, sym
         addr = ""
         i = 10
         cycle 
            sym = a(i)
            i = i + 1
            exit if sym = 128
            addr = addr . tostring(sym)
         repeat
         dump("", name(a(a(instrp + 1) + 1)), "", addr)
      end
      return
instype(14): 
      !    <OPCODE>
      dump("", name(a(a(instrp + 1) + 1)), "", "")
      return
   end
   routine doloop(integer loopsp)
      integer type, cyclab, cntlab, extlab, namep, actualp, forp, c
        initp, incrp, finalp, tplabel, condp, whilep, disp, nametag
      string (7) base, reg
      switch cycle(1:3)
      if a(loopsp) = 1 then type = 2 else type = 3
      cyclab = nextplabel
      cntlab = nextplabel
      extlab = nextplabel
      pushstart(type, cyclab)
      -> cycle(a(loopsp))
cycle(1): 
      !FOR
      forp = a(loopsp + 1)
      namep = a(forp + 1)
      actualp = a(forp + 2)
      initp = a(forp + 3)
      incrp = a(forp + 4)
      finalp = a(forp + 5)
      ident = a(namep + 1)
      reg = "D"
      !?      %if taglink(ident)=0 %then fault(name(ident)." NOT DECLARED") %andreturn
      if taglink(ident) = 0 then start
         dump("", "LD", "D", "#" . name(ident))
      finish else start
         nametag = tag(taglink(ident))
         if nametag >> 28 = 4 then start
            fault("NOT A DESTINATION")
            return
         finish
         if nametag >> 28 = 2 start
            aopt = 1
            array(forp)
         finish else start
            basep = nametag >> 16 & 16_F
            base = display(basep)
            disp = nametag & 16_FFFF
            base = "Y" if basep = level
            base = "X" if basep = 1
            if nametag >> 28 = 1 then start
               if 1 < basep < level then start
                  dump("", "LD", "D", base)
                  dump("", "SUB", "D", "#" . s(disp))
                  dump("", "ST", "D", "0,X")
                  dump("", "LD", "D", "[0,X]")
               finish else start
                  dump("", "LD", "D", "-" . s(disp) . "," . base)
               finish
            finish else start
               if 1 < basep < level then start
                  dump("", "LD", "D", base)
                  dump("", "SUB", "D", "#" . 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", "D", "#" . s(disp))
                  finish
               finish
               if a(actualp) = 1 then fault(name(ident) . " DECLARED AS SCALAR")
            finish
         finish
      finish
      dump("", "PSH", "U", reg)
      expr(finalp)
      dump("", "PSH", "U", "B")
      expr(incrp)
      dump("", "PSH", "U", "B")
      expr(initp)
      dump("", "SUB", "B", ",U")
      dump("", "ST", "B", "[2,U]")
      dump("L" . s(cyclab), "EQU", "", "*")
      dump("", "LD", "B", "[2,U]")
      dump("", "CMP", "B", "1,U")
      dump("", "LBEQ", "", "L" . s(extlab))
      dump("", "ADD", "B", ",U")
      dump("", "ST", "B", "[2,U]")
      return
      cycle(*):

      dump("L" . s(cyclab), "EQU", "", "*")
      return if a(loopsp) # 2
      whilep = a(loopsp + 1)
      condp = a(whilep + 1)
      tplabel = cond(condp, -1, extlab)
   end
end
end of file