Source file: SKIMPE.IMP              Compiled on 25-OCT-1979 at 09:41:31

               Computer Science IMP77 Compiler.  Version 6.01

         1  %externalintegerarrayspec a(1:500)
         2  %externalintegerarrayspec taglink(0:255)
         3  %externalintegerarrayspec tag(1:512)
         4  %externalstring(4)%arrayspec display(0:15)
         5  %externalintegerspec level,condflag,expropt
         6  !-----------------------------------------------------------------------
         7  %externalstring(255)%fnspec strint(%integer n,p)
         8  %externalstring(8)%fnspec strhex(%integer n)
         9  %externalroutinespec fault(%string(63) s)
        10  %externalstring(255)%fnspec name(%integer ident)
        11  %externalroutinespec dump(%string(7) opn,reg,base,%integer disp)
        12  %externalintegerfnspec getwork
        13  %externalroutinespec returnwork(%integer work)
        14  %externalroutinespec proc(%integer ap)
        15  %externalroutinespec array(%integer ap)
        16  %externalintegerfnspec getcoti(%integer const)
        17  !-----------------------------------------------------------------------
        18  %externalroutine expr(%integer exprp)
        19  %integerfnspec totree(%integer exprp)
        20  %routinespec evaluate(%integer nodep)
        21  %integerarray tree(1:64)
        22  %integer treep,treenode,treenode1,treenode2,testp,expr1p,expr2p,compp,%c
        23+   i,j,l
        24  %constintegerarray reversecomp(1:6)=1,2,5,6,3,4
        25    treep=1
        26    %if condflag=0 %then treenode=totree(exprp) %else %start
        27      condflag=0
        28      testp=exprp    ;! for <test>=<expr><comp><expr>
        29      expr1p=a(testp+1)
        30      compp=a(testp+2)
        31      expr2p=a(testp+3)
        32      treenode1=totree(expr1p)
        33      treenode2=totree(expr2p)
        34      %if tree(treenode1)=-4 %and tree(treenode1+1)=0 %then %start
        35        a(compp)=reversecomp(a(compp))
        36        treenode=treenode2
        37      %finish %else %start
        38        %if tree(treenode2)=-4 %and tree(treenode2+1)=0 %then %c
        39+         treenode=treenode1 %else %start
        40          tree(treep)=10    ;! -
        41          tree(treep+1)=treenode1
        42          tree(treep+2)=treenode2
        43          treenode=treep
        44        %finish
        45      %finish
        46    %finish
        47    %if expropt=1 %then %start
        48      newline
        49      %if 0<tree(treenode)<=10 %then l=treenode+2 %else l=treenode+1
        50      j=0
        51      %for i=1,1,l %cycle
        52        write(tree(i),4)
        53        j=j+5
        54        %if i=treenode %then print string("*")
        55        %if tree(i)=-3 %then i=i+1 %and print string("  ". %c
        56+         strhex(tree(i))) %and j=j+10
        57        %if j>70 %then newline %and j=0
        58      %repeat
        59      newlines(2)
        60    %finish
        61    evaluate(treenode)
        62    %return
        63  !-----------------------------------------------------------------------
        64  %integerfn totree(%integer exprp)
        65  ! create tree form of expression
        66  %routinespec pseval(%integer type,datum)
        67  %integerarray os(1:4),ps(1:5)    ;! operator & pseudo-evaluation stacks
        68  %integer osp,psp,unaryp,operandp,exprrestp,opp,namep,actualp, %c
        69+   ident,nametag
        70  %constintegerarray prec(1:12)=3,3,2,1,1,3,2,2,1,1,1,4
        71  ! <<,>>,&,!!,!,**,/,*,+,-,-(unary),\
        72    unaryp=a(exprp+1)
        73    operandp=a(exprp+2)
        74    exprrestp=a(exprp+3)
        75    %if a(unaryp)<=2 %then os(1)=a(unaryp)+10 %and osp=1 %else osp=0
        76    psp=0
        77    %cycle    ;! for each operand
        78      %if a(operandp)=1 %then %start    ;! <name><actual>
        79        namep=a(operandp+1)
        80        actualp=a(operandp+2)
        81        ident=a(namep+1)
        82        %if taglink(ident)=0 %then %start
        83          fault(name(ident)." NOT DECLARED")
        84          pseval(-3,0)    ;! pseval dummy tag
        85        %finish %else %start
        86          nametag=tag(taglink(ident))
        87          %if nametag>>28<=1 %then %start    ;! scalar variable
        88            %if a(actualp)=1 %then %start
        89              fault("SCALAR ".name(ident)." HAS PARAMETER")
        90              pseval(-3,0)
        91            %finish %else pseval(-3,nametag)
        92          %finish %else %start
        93            %if nametag>>28<=3 %then pseval(-2,operandp) %else %start
        94              %if nametag>>24&16_F=0 %then %start
        95                fault("ROUTINE NAME ".name(ident)." IN EXPRESSION")
        96                pseval(-3,0)
        97              %finish %else pseval(-1,operandp)
        98            %finish
        99          %finish
       100        %finish
       101      %finish %else %start
       102        %if a(operandp)=2 %then pseval(-4,a(a(operandp+1)+1)) %else %c
       103+         psp=psp+1 %and ps(psp)=totree(a(operandp+1))
       104      %finish
       105      %if a(exprrestp)=2 %then %exit    ;! no more operands
       106      opp=a(exprrestp+1)
       107      operandp=a(exprrestp+2)
       108      exprrestp=a(exprrestp+3)
       109      %while osp>0 %and prec(a(opp))<=prec(os(osp)) %then %c
       110+       pseval(os(osp),0) %and osp=osp-1   ;! unstack while prec(new op)<=
       111      osp=osp+1    ;! stack new operator
       112      os(osp)=a(opp)
       113    %repeat
       114    %while osp>0 %then pseval(os(osp),0) %and osp=osp-1    ;! unstack rest
       115    %result=ps(1)
       116  !-----------------------------------------------------------------------
       117  %routine pseval(%integer type,datum)
       118  %routinespec store(%integer t)
       119  %integer nodep
       120    nodep=treep
       121    store(type)
       122    %if type>0 %then %start    ;! operator
       123      %if type>10 %then store(ps(psp)) %else store(ps(psp-1)) %and %c
       124+       store(ps(psp)) %and psp=psp-1
       125    %finish %else store(datum) %and psp=psp+1
       126    ps(psp)=nodep
       127  !-----------------------------------------------------------------------
       128  %routine store(%integer t)
       129    %if treep>64 %then fault("EXPRESSION TOO LONG") %and %stop
       130    tree(treep)=t
       131    treep=treep+1
       132  %end
       133  %end
       134  %end
       135  !-----------------------------------------------------------------------
       136  %routine evaluate(%integer nodep)
       137  ! dump code to evaluate expression
       138  %routinespec opn(%integer op,p)
       139  %conststring(4)%array strop(0:12)="LOAD","SHL","SHR","AND","XOR","OR",
       140+   "EXP","DIV","MLT","ADD","SUB","NEG","NOT"
       141  %constintegerarray commut(1:10)=0,0,1,1,1,0,0,1,1,0
       142  %integer op,opd1p,opd2p,work
       143    %if tree(nodep)<0 %then opn(0,nodep) %and %return    ;! operand
       144    op=tree(nodep)
       145    opd1p=tree(nodep+1)
       146    %if op>10 %then %start    ;! unary operator
       147      %if tree(opd1p)>=-2 %then evaluate(opd1p) %else opn(0,opd1p)
       148      dump(strop(op),"ACC","",0)
       149      %return
       150    %finish
       151    opd2p=tree(nodep+2)
       152    %if tree(opd1p)>=-2 %then %start      ;! operand1 a node
       153      %if tree(opd2p)>=-2 %then %start    ;! operand2 a node
       154        evaluate(opd2p)
       155        work=getwork
       156        dump("STR","ACC",display(level),work)
       157        evaluate(opd1p)
       158        dump(strop(op),"ACC",display(level),work)
       159        returnwork(work)
       160      %finish %else %start
       161        evaluate(opd1p)
       162        opn(op,opd2p)
       163      %finish
       164    %finish %else %start
       165      %if tree(opd2p)>=-2 %then %start
       166        evaluate(opd2p)
       167        %if commut(op)#0 %then opn(op,opd1p) %and %return
       168        work=getwork
       169        dump("STR","ACC",display(level),work)
       170        opn(0,opd1p)
       171        dump(strop(op),"ACC",display(level),work)
       172        returnwork(work)
       173      %finish %else %start
       174        opn(0,opd1p)
       175        opn(op,opd2p)
       176      %finish
       177    %finish
       178    %return
       179  !-----------------------------------------------------------------------
       180  %routine opn(%integer op,p)
       181  ! dump object code for simple operation
       182  %string(7) base
       183  %integer type,datum,disp
       184    type=tree(p)
       185    datum=tree(p+1)
       186    %if type=-1 %then proc(datum) %else %start    ;! procedure
       187      %if type=-2 %then %start                    ;! array
       188        array(datum)
       189        dump("LOAD","ACC","ACC",0)
       190      %finish %else %start
       191        %if type=-3 %then %start                  ;! scalar
       192          base=display(datum>>16&16_F)
       193          disp=datum&16_FFFF
       194          %if datum>>28=1 %then %start            ;! %name type
       195            dump("LOAD","WK",base,disp)
       196            dump(strop(op),"ACC","WK",0)
       197          %finish %else dump(strop(op),"ACC",base,disp)
       198        %finish %else %start    ;! constant
       199          %if op>0 %or datum>16_FFFF %then dump(strop(op),"ACC", %c
       200+           "COT",getcoti(datum)) %else dump("LDA","ACC","",datum)
       201        %finish
       202      %finish
       203    %finish
       204  %end
       205  %end
       206  %end
       207  %endoffile
      ?STRINT unused
      Code 5164 bytes  Glap 680 bytes  Diags 1023 bytes   Total size 6867 bytes
         187 statements compiled