!Graham Toal - latest development version of SKIMPE 23/01/80 18.58
%external %integer %array %spec a(1 : 500)

%external %integer %array %spec taglink(0 : 255)

%external %integer %array %spec tag(1 : 512)

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

%external %integer %spec level, condflag, expropt
!-----------------------------------------------------------------------
%external %string (7) %fn %spec s(%integer i)
%external %string (255) %fn %spec strint(%integer n, p)
%external %string (8) %fn %spec strhex(%integer n)
%external %routine %spec fault(%string (63) s)
%external %string (255) %fn %spec name(%integer ident)
%external %routine %spec dump(%string (7) lab, op, reg, addr)
%external %integer %fn %spec getwork
%external %routine %spec returnwork(%integer work)
%external %routine %spec proc(%integer ap)
%external %routine %spec array(%integer ap)
%external %integer %fn %spec getcoti(%integer const)
!-----------------------------------------------------------------------
%const %integer proceedure = -1, arrayelement = -2, scalar = -3, unary = 11, %c
  complex = -2, terminal = 0, true = 1, load = 0, exp = 6, sub = 10, %c
  mult = 8, div = 7, shr = 2, shl = 1, cmp = 13
!------------------------------------------------------------------------
%external %integer %fn intstr(%string (6) val)
   %integer i, total
   total = 0
   %for i = 1, 1, length(val) %cycle
      total = total * 10 + charno(val, i) - '0'
   %repeat
   %result = total
%end
%external %routine expr(%integer exprp)
   %integer %fn %spec totree(%integer exprp)
   %routine %spec evaluate(%integer exprp)
   %routine %spec opn(%integer op, ptr)
   %integer %array tree(1 : 64)
   %integer treep, treenode, treenode1, treenode2, testp, expr1p, expr2p, compp, i, j, l
   %const %integer %array reversecomp(1 : 6) = 1, 2, 5, 6, 3, 4

   treep = 1
   %if condflag = 0 %then treenode = totree(exprp) %else %start
      condflag = 0
      testp = exprp
      ! for <test>=<expr><comp><expr>
      expr1p = a(testp + 1)
      compp = a(testp + 2)
      expr2p = a(testp + 3)
      treenode1 = totree(expr1p)
      treenode2 = totree(expr2p)
      tree(treep) = 13
      ! CMP
      %if tree(treenode1) = -4 %then %start
         a(compp) = reversecomp(a(compp))
         tree(treep + 1) = treenode2
         tree(treep + 2) = treenode1
      %finish %else %start
         tree(treep + 1) = treenode1
         tree(treep + 2) = treenode2
      %finish
      treenode = treep
   %finish
   %if expropt = 1 %then %start
      newline
      %if 0 < tree(treenode) <= 10 %then l = treenode + 2 %else l = treenode + 1
      j = 0
      %for i = 1, 1, l %cycle
         write(tree(i), 4)
         j = j + 5
         %if i = treenode %then printstring("*") %and j = j + 1
         %if tree(i) = -3 %then i = i + 1 %and printstring("  " . strhex(tree(i))) %and j = j + 10
         %if j > 70 %then newline %and j = 0
      %repeat
      newlines(2)
   %finish
   evaluate(treenode)
   %return
   !-----------------------------------------------------------------------
   %integer %fn totree(%integer exprp)
      ! create tree form of expression
      %routine %spec pseval(%integer type, datum)
      %integer %array os(1 : 4), ps(1 : 5)
      ! operator & pseudo-evaluation stacks
      %integer osp, psp, unaryp, operandp, exprrestp, opp, namep, actualp, ident, nametag
      %const %integer %array prec(1 : 12) = 3, 3, 2, 1, 1, 3, 2, 2, 1, 1, 1, 4

      ! <<,>>,&,!!,!,**,/,*,+,-,-(unary),\
      %integer %fn constop(%integer op, val1)
         %switch exec(1:10)
         %integer res
         -> exec(op)
exec(1): 
         ! <<
         res = tree(val1 + 1) << tree(val1 + 3)
         -> cont
exec(2): 
         ! >>
         res = tree(val1 + 1) >> tree(val1 + 3)
         -> cont
exec(3): 
         ! &
         res = tree(val1 + 1) & tree(val1 + 3)
         -> cont
exec(4): 
         ! !!
         res = tree(val1 + 1) !! tree(val1 + 3)
         -> cont
exec(5): 
         ! !
         res = tree(val1 + 1) ! tree(val1 + 3)
         -> cont
exec(6): 
         ! **
         res = tree(val1 + 1) \\ tree(val1 + 3)
         -> cont
exec(7): 
         ! /
         %if tree(val1 + 3) = 0 %then fault("DIVISION BY ZERO") %and res = 0 %and -> cont
         res = tree(val1 + 1) // tree(val1 + 3)
         -> cont
exec(8): 
         ! *
         res = tree(val1 + 1) * tree(val1 + 3)
         -> cont
exec(9): 
         ! +
         res = tree(val1 + 1) + tree(val1 + 3)
         -> cont
exec(10): 
         ! -
         res = tree(val1 + 1) - tree(val1 + 3)
cont: 
         %result = res
      %end
      unaryp = a(exprp + 1)
      operandp = a(exprp + 2)
      exprrestp = a(exprp + 3)
      %if a(unaryp) <= 2 %then os(1) = a(unaryp) + 10 %and osp = 1 %else osp = 0
      psp = 0
      %cycle 
         ! for each operand
         %if a(operandp) = 1 %then %start
            ! <name><actual>
            namep = a(operandp + 1)
            actualp = a(operandp + 2)
            ident = a(namep + 1)
            %if taglink(ident) = 0 %then %start
               !?        fault(name(ident)." NOT DECLARED")
               pseval(-3, -ident)
               ! pseval dummy tag
            %finish %else %start
               nametag = tag(taglink(ident))
               %if nametag >> 28 <= 1 %then %start
                  ! scalar variable
                  %if a(actualp) = 1 %then %start
                     fault("SCALAR " . name(ident) . " HAS PARAMETER")
                     pseval(-3, 0)
                  %finish %else pseval(-3, nametag)
               %finish %else %start
                  %if nametag >> 28 <= 3 %then pseval(-2, operandp) %else %start
                     %if nametag >> 24 & 16_F = 0 %then %start
                        fault("ROUTINE NAME " . name(ident) . " IN EXPRESSION")
                        pseval(-3, 0)
                     %finish %else pseval(-1, operandp)
                  %finish
               %finish
            %finish
         %finish %else %start
            %if a(operandp) = 2 %then pseval(-4, a(a(operandp + 1) + 1)) %c
            %else psp = psp + 1 %and ps(psp) = totree(a(operandp + 1))
         %finish
         %if a(exprrestp) = 2 %then %exit
         ! no more operands
         opp = a(exprrestp + 1)
         operandp = a(exprrestp + 2)
         exprrestp = a(exprrestp + 3)
         pseval(os(osp), 0) %and osp = osp - 1 %while osp > 0 %and prec(a(opp)) <= prec(os(osp))
         ! unstack while prec(new op)<=
         osp = osp + 1
         ! stack new operator
         os(osp) = a(opp)
      %repeat
      pseval(os(osp), 0) %and osp = osp - 1 %while osp > 0
      ! unstack rest
      %result = ps(1)
      !-----------------------------------------------------------------------
      %routine pseval(%integer type, datum)
         %routine %spec store(%integer t)
         %integer nodep, temp
         nodep = treep
         store(type)
         %if type > 0 %then %start
            ! operator
            %if type > 10 %then %start
               store(ps(psp))
            %finish %else %start
               %if tree(ps(psp - 1)) = -4 %and tree(ps(psp)) = -4 %c
                 %and ps(psp - 1) = treep - 5 %and ps(psp) = treep - 3 %start
                  temp = constop(type, treep - 5)
                  %if temp >= 0 %then %start
                     treep = ps(psp - 1) + 2
                     tree(ps(psp - 1) + 1) = temp
                     psp = psp - 1
                     ps(psp) = treep - 2
                     %return
                  %finish %else -> over
               %finish %else %start
over: 
                  store(ps(psp - 1))
                  store(ps(psp))
                  psp = psp - 1
               %finish
            %finish
         %finish %else store(datum) %and psp = psp + 1
         ps(psp) = nodep
         !-----------------------------------------------------------------------
         %routine store(%integer t)
            %if treep > 64 %then fault("EXPRESSION TOO LONG") %and %stop
            tree(treep) = t
            treep = treep + 1
         %end
      %end
   %end
   !-----------------------------------------------------------------------
   %const %string (3) %array strop(0 : 13) = "LD", "SHL", "SHR", "AND", "EOR", %c
     "OR", "EXP", "DIV", "MUL", "ADD", "SUB", "NEG", "COM", "CMP"

   %const %integer %array args(0 : 13) = 1, 0, 0, 1, 1, 1, 0, 0, -1, 1, 1, 1, 1, 1

   %const %integer %array commut(0 : 13) = 0, 0, 0, 1, 1, 1, 0, 0, 1, 1, 0, 0, 0, 1

   %routine doop(%integer op, %string (10) val)
      %string (6) const
      %integer value
      %switch clever(0:13)
      ! B op VAL
      %if args(op) # 1 %start
         %if val -> ("#") . const %then %start
            value = intstr(const)
            -> clever(op)
clever(mult): 
            %if value = 2 %or value = 4 %then %start
               dump("", "ASL", "B", "") %and value = value >> 1 %while value # 1
            %finish
            %return %if value = 1
            -> eval
clever(div): 
            %if value = 2 %or value = 4 %then %start
               dump("", "ASR", "B", "") %and value = value >> 1 %while value # 1
            %finish
            %return %if value = 1
            -> eval
clever(exp): 
            %if value = 2 %then %start
               dump("", "TFR", "", "B,A")
               dump("", "MUL", "", "")
               %return
            %finish %else -> eval
clever(shl): 
            %if 1 <= value <= 2 %then %start
               dump("", "LSL", "B", "") %and value = value - 1 %until value = 0
            %finish
            %return %unless 3 <= value <= 7
            -> eval
clever(shr): 
            %if 1 <= value <= 2 %then %start
               dump("", "LSR", "B", "") %and value = value - 1 %until value = 0
            %finish
            %return %unless 3 <= value <= 7
            -> eval
            clever(*):

eval: 
         %finish
         dump("", "LD", "A", val)
         %if args(op) < 0 %start
            dump("", "MUL", "", "")
         %finish %else %start
            dump("", "LBSR", "", strop(op))
         %finish
      %finish %else %start
         dump("", strop(op), "B", val)
      %finish
   %end
   %routine opn(%integer op, nodep)
      %integer type, basep, varp, disp
      %string (4) base
      type = tree(nodep)
      %if type > scalar %then fault("*BUG")
      varp = tree(nodep + 1)
      %if varp < 0 %then %start
         doop(op, name(-varp))
      %finish %else %start
         %if type = scalar %start
            basep = varp >> 16 & 16_F
            base = display(basep)
            base = ",Y" %if basep = level
            base = ",X" %if basep = 1
            disp = varp & 16_FFFF
            %if varp >> 28 = 1 %start
               %if basep = level # 1 %start
                  doop(op, "[" . "-" . s(disp) . base . "]")
               %finish %else %if basep # level # 1 %start
                  dump("", "PSH", "U", "A,B")
                  dump("", "LD", "D", base)
                  dump("", "ADD", "D", "#" . s(disp))
                  dump("", "ST", "D", "0,X")
                  dump("", "PUL", "U", "A,B")
                  doop(op, "[0,X]")
               %finish
               %return
            %finish
            %if basep = level %or basep = 1 %start
               doop(op, "-" . s(disp) . base)
            %finish %else %start
               dump("", "PSH", "U", "A,B")
               dump("", "LD", "D", base)
               dump("", "ADD", "D", "#" . s(disp))
               dump("", "ST", "D", "0,X")
               dump("", "PUL", "U", "A,B")
               doop(op, "[0,X]")
            %finish
         %finish %else %start
            doop(op, "#" . s(varp))
         %finish
      %finish
   %end
   %routine regop(%integer op, %string (7) r1, r2)
      ! R1 op R2
      %if args(op) # 1 %start
         %if args(op) < 0 %start
            dump("", "MUL", "", "")
         %finish %else %start
            dump("", "LBSR", "", strop(op))
         %finish
      %finish %else %start
         dump("", strop(op), r1, r2)
      %finish
   %end
   %routine loadb(%integer nodep)
      %integer type, datum
      type = tree(nodep)
      datum = tree(nodep + 1)
      %if type = proceedure %start
         proc(datum)
         %return
      %finish
      %if type = arrayelement %start
         array(datum)
         dump("", "LD", "B", "[0,X]")
         %return
      %finish
      opn(load, nodep)
   %end
   %routine evaluate(%integer nodep)
      %integer op, opd1p, opd2p
      %if tree(nodep) <= terminal %start
         loadb(nodep)
         %return
      %finish
      op = tree(nodep)
      opd1p = tree(nodep + 1)
      %if cmp > op >= unary %start
         !
         ! TEST FOR CONST NODE HERE
         !
         evaluate(opd1p)
         dump("", strop(op), "B", "")
         %return
      %finish
      opd2p = tree(nodep + 2)
      !
      ! TEST FOR BOTH NODES CONST HERE
      !
      %if tree(opd1p) >= complex %start
         %if tree(opd2p) >= complex %start
            evaluate(opd2p)
            dump("", "PSH", "U", "B")
            evaluate(opd1p)
            doop(op, ",U+")
         %finish %else %start
            evaluate(opd1p)
            opn(op, opd2p)
         %finish
      %finish %else %start
         %if tree(opd2p) >= complex %start
            evaluate(opd2p)
            %if commut(op) = true %start
               opn(op, opd1p)
               %return
            %finish
            %if args(op) <= 0 %start
               dump("", "TFR", "", "B,A")
               opn(load, opd1p)
               regop(op, "B", "A")
            %finish %else %start
               dump("", "PSH", "U", "B")
               opn(load, opd1p)
               doop(op, ",U+")
            %finish
         %finish %else %start
            opn(load, opd1p)
            opn(op, opd2p)
         %finish
      %finish
   %end
%end
%end %of %file