         Source file: SKIMPB.IMP              Compiled on 25-OCT-1979 at 09:39:49

               Computer Science IMP77 Compiler.  Version 6.01

         1  %externalintegerarrayspec a(1:500)
         2  %externalintegerarrayspec taglink(0:255)
         3  %externalintegerarrayspec tag(1:512)
         4  %externalintegerarrayspec link(1:512)
         5  !-----------------------------------------------------------------------
         6  %externalroutinespec expr(%integer exprp)
         7  %externalintegerfnspec cond(%integer condp,tlabel,flabel)
         8  %externalstring(255)%fnspec strint(%integer n,p)
         9  %externalintegerfnspec getwork
        10  %externalroutinespec returnwork(%integer work)
        11  %externalroutinespec clearwork
        12  %externalintegerfnspec newtag
        13  %externalroutinespec pushtag(%integer ident,form,type,dim,level,rad)
        14  %externalroutinespec poptags
        15  %externalintegerfnspec getlabel(%integer constp)
        16  %externalroutinespec filllabel(%integer label)
        17  %externalintegerfnspec fillbranch(%integer label)
        18  %externalroutinespec poplabels
        19  %externalintegerfnspec nextplabel
        20  %externalroutinespec dump(%string(7) opn,reg,base,%integer disp)
        21  %externalroutinespec fault(%string(63) mess)
        22  %externalstring(255)%fnspec name(%integer ident)
        23  %externalroutinespec pushstart(%integer flag,plab)
        24  %externalroutinespec popstart(%integername flag,plab)
        25  %externalroutinespec clearstart
        26  %externalintegerfnspec enter
        27  %externalroutinespec dump return
        28  %externalroutinespec proc(%integer procp)
        29  %externalroutinespec array(%integer arrayp)
        30  %externalroutinespec endofprog
        31  !-----------------------------------------------------------------------
        32  %externalintegerarray nextrad(0:15)
        33  %externalstring(4)%array display(0:15)="DR0","DR1","DR2","DR3","DR4",
        34+  "DR5","DR6","DR7","DR8","DR9","DR10","DR11","DR12","DR13","DR14","DR15"
        35  %externalinteger level,nextcad
        36  !-----------------------------------------------------------------------
        37  %ownintegerarray proctype(0:15)
        38  %ownintegerarray staticalloc(0:15)
        39  %ownintegerarray skipproc(0:15)
        40  !-----------------------------------------------------------------------
        41  %externalroutine statement(%integer statementp)
        42  %routinespec instr(%integer instrp)
        43  %switch sttype(1:8)
        44  %integer condp,instrp,elsep,constp,arrayp,namep,namesp,expr1p,expr2p, %c
        45+   instr2p,tlabel,flabel,label,fplabel,tplabel,work1,work2,flag,plabel,%c
        46+   procp,formalp,formp,params,procid,ident,form,paramt,paraml,dim
        47    ->sttype(a(statementp))
        48  !-----------------------------------------------------------------------
        49  sttype(1):! <instr>
        50    instr(a(statementp+1))
        51    %return
        52  !-----------------------------------------------------------------------
        53  sttype(2):! "IF"<cond>"THEN"<instr><else>
        54    condp=a(statementp+1)
        55    instrp=a(statementp+2)
        56    elsep=a(statementp+3)
        57    %if a(instrp)=2 %then %start    ;! branch
        58      constp=a(instrp+1)
        59      tlabel=getlabel(constp)
        60      %if a(elsep)=2 %then filllabel(cond(condp,tlabel,-1)) %else %start
        61        instrp=a(elsep+1)
        62        %if a(instrp)=2 %then %start    ;! branch
        63          constp=a(instrp+1)
        64          flabel=getlabel(constp)
        65          filllabel(cond(condp,tlabel,flabel))
        66          dump("B","","",fillbranch(flabel))
        67        %finish %else %start
        68          filllabel(cond(condp,tlabel,-1))
        69          %if a(instrp)=3 %then pushstart(1,-1) %else instr(instrp)
        70        %finish
        71      %finish
        72    %finish %else %start
        73      %if a(elsep)=2 %then %start
        74        fplabel=cond(condp,-1,-1)
        75        %if a(instrp)=3 %then pushstart(0,fplabel) %else %c
        76+         instr(instrp) %and filllabel(fplabel)
        77      %finish %else %start
        78        instr2p=a(elsep+1)
        79        %if a(instr2p)=2 %then %start    ;! branch
        80          constp=a(instr2p+1)
        81          fplabel=cond(condp,-1,getlabel(constp))    ;! result always -1
        82          instr(instrp)
        83        %finish %else %start
        84          fplabel=cond(condp,-1,-1)
        85          instr(instrp)
        86          tplabel=nextplabel
        87          dump("B","","",fillbranch(tplabel))
        88          filllabel(fplabel)
        89          %if a(instr2p)=3 %then pushstart(1,tplabel) %else %c
        90+           instr(instr2p) %and filllabel(tplabel)
        91        %finish
        92      %finish
        93    %finish
        94    %return
        95  !-----------------------------------------------------------------------
        96  sttype(3):! <const>':'<statement>
        97    constp=a(statementp+1)
        98    statementp=a(statementp+2)
        99    label=getlabel(constp)
       100    filllabel(label)
       101    statement(statementp)
       102    %return
       103  !-----------------------------------------------------------------------
       104  sttype(4):! "FINISH"<else>
       105    elsep=a(statementp+1)
       106    popstart(flag,plabel)
       107    %if flag=0 %then %start    ;! first %start/%finish
       108      %if a(elsep)=1 %then %start
       109        instrp=a(elsep+1)
       110        tplabel=nextplabel
       111        dump("B","","",fillbranch(tplabel))
       112        filllabel(plabel)
       113        %if a(instrp)=3 %then pushstart(1,tplabel) %else %c
       114+         instr(instrp) %and filllabel(tplabel)
       115      %finish %else filllabel(plabel)
       116    %finish %else %start    ;! second %start/%finish
       117      %if a(elsep)=1 %then fault("SPURIOUS %ELSE") %else filllabel(plabel)
       118    %finish
       119    %return
       120  !-----------------------------------------------------------------------
       121  sttype(5):! "INTEGER"<array>
       122    arrayp=a(statementp+1)
       123    namep=a(arrayp+1)
       124    namesp=a(arrayp+2)
       125    %if a(arrayp)=1 %then %start    ;! array declaration
       126      expr1p=a(arrayp+3)
       127      expr2p=a(arrayp+4)
       128      expr(expr1p)
       129      work1=getwork
       130      dump("STR","ACC",display(level),work1)
       131      expr(expr2p)
       132      dump("LDA","ACC","ACC",1)
       133      work2=getwork
       134      dump("STR","ACC",display(level),work2)
       135      %cycle
       136        pushtag(a(namep+1),2,1,1,level,nextrad(level))
       137        dump("SUB","STP",display(level),work1)
       138        dump("STR","STP",display(level),nextrad(level))
       139        dump("ADD","STP",display(level),work2)
       140        nextrad(level)=nextrad(level)+1
       141        %if a(namesp)=2 %then %exit
       142        namep=a(namesp+1)
       143        namesp=a(namesp+2)
       144      %repeat
       145      returnwork(work1)
       146      returnwork(work2)
       147    %finish %else %start
       148      %cycle
       149        pushtag(a(namep+1),0,1,0,level,nextrad(level))
       150        nextrad(level)=nextrad(level)+1
       151        %if a(namesp)=2 %then %exit
       152        namep=a(namesp+1)
       153        namesp=a(namesp+2)
       154      %repeat
       155    %finish
       156    %return
       157  !-----------------------------------------------------------------------
       158  sttype(6):! <proc><name><formal>
       159    %if level=0 %then fault("PROCEDURE BEFORE %BEGIN")
       160    %if level=15 %then fault("PROCEDURE NESTING TOO DEEP")
       161    procp=a(statementp+1)
       162    namep=a(statementp+2)
       163    formalp=a(statementp+3)
       164    procid=a(namep+1)
       165    skipproc(level)=nextcad
       166    dump("B","","",0)    ;! branch round procedure
       167    pushtag(procid,4,a(procp)-1,0,level,nextcad)
       168    level=level+1
       169    proctype(level)=a(procp)
       170    staticalloc(level)=enter
       171    nextrad(level)=2
       172    %if a(formalp)=2 %then %return    ;! no parameters
       173    params=0
       174    paraml=taglink(procid)
       175    %until a(formalp)=2 %cycle
       176      formp=a(formalp+1)
       177      namep=a(formalp+2)
       178      namesp=a(formalp+3)
       179      formalp=a(formalp+4)
       180      %if a(formp)=1 %then form=3 %and dim=1 %else %start
       181        %if a(formp)=2 %then form=1 %else form=0
       182        dim=0
       183      %finish
       184      %cycle
       185        ident=a(namep+1)
       186        ! declare parameters as locals
       187        pushtag(ident,form,1,dim,level,nextrad(level))
       188        nextrad(level)=nextrad(level)+1
       189        ! append parameter tag cells to procedure tag cell
       190        paramt=newtag
       191        tag(paramt)=tag(taglink(ident))
       192        link(paramt)=link(paraml)
       193        link(paraml)=paramt
       194        paraml=paramt
       195        params=params+1
       196        %if params>15 %then fault(name(procid). %c
       197+         " HAS TOO MANY PARAMETERS") %and %stop
       198        %if a(namesp)=2 %then %exit
       199        namep=a(namesp+1)
       200        namesp=a(namesp+2)
       201      %repeat
       202    %repeat
       203    ! insert number of parameters into tag cell
       204    tag(taglink(procid))=tag(taglink(procid))!params<<20
       205    %return
       206  !-----------------------------------------------------------------------
       207  sttype(7):! "END"<ofprog>
       208    dump("FILL","ALLOC",strint(staticalloc(level),1),nextrad(level))
       209    poptags
       210    poplabels
       211    clearstart
       212    clearwork
       213    %if proctype(level)=1 %then dump return %else dump("STOP","","",0)
       214    level=level-1
       215    %if a(a(statementp+1))=2 %then %start    ;! %end
       216      %if level<=0 %then fault("SPURIOUS %END") %and endofprog
       217      dump("FILL","SKIP",strint(skipproc(level),1),nextcad)
       218    %finish %else %start    ;! %endofprogram
       219      %if level#0 %then fault("TOO FEW %ENDS")
       220      endofprog
       221    %finish
       222    %return
       223  !-----------------------------------------------------------------------
       224  sttype(8):! "BEGIN"
       225    %if level#0 %then fault("SPURIOUS %BEGIN") %else %start
       226      level=1
       227      proctype(1)=0
       228      staticalloc(1)=enter
       229    %finish
       230    %return
       231  !-----------------------------------------------------------------------
       232  %routine instr(%integer instrp)
       233  %switch instype(1:6)
       234  %string(4) base
       235  %integer namep,assignp,constp,ident,actualp,exprp,nametag,disp,work
       236    ->instype(a(instrp))
       237  !-----------------------------------------------------------------------
       238  instype(1):! <name><actual><assign>
       239    namep=a(instrp+1)
       240    actualp=a(instrp+2)
       241    assignp=a(instrp+3)
       242    ident=a(namep+1)
       243    %if taglink(ident)=0 %then fault(name(ident)." NOT DECLARED") %c
       244+     %and %return
       245    nametag=tag(taglink(ident))
       246    %if a(assignp)=1 %then %start
       247      %if nametag>>28=4 %then fault(name(ident)." NOT A DESTINATION") %c
       248+       %and %return
       249      exprp=a(assignp+1)
       250      %if nametag>>28>=2 %then %start    ;! array variable
       251        expr(exprp)
       252        work=getwork
       253        dump("STR","ACC",display(level),work)
       254        array(instrp)
       255        dump("LOAD","WK",display(level),work)
       256        dump("STR","WK","ACC",0)
       257        returnwork(work)
       258      %finish %else %start
       259        expr(exprp)
       260        base=display(nametag>>16&16_F)
       261        disp=nametag&16_FFFF
       262        %if nametag>>28=1 %then %start    ;! %name variable
       263          dump("LOAD","WK",base,disp)
       264          dump("STR","ACC","WK",0)
       265        %finish %else dump("STR","ACC",base,disp)
       266        %if a(actualp)=1 %then fault(name(ident)." DECLARED AS SCALAR")
       267      %finish
       268    %finish %else %start
       269      %if nametag>>28=4 %and nametag>>24&16_F=0 %then proc(instrp) %c
       270+       %else fault(name(ident)." NOT A ROUTINE NAME")
       271    %finish
       272    %return
       273  !-----------------------------------------------------------------------
       274  instype(2):! '->'<const>
       275    constp=a(instrp+1)
       276    label=getlabel(constp)
       277    dump("B","","",fillbranch(label))
       278    %return
       279  !-----------------------------------------------------------------------
       280  instype(3):! "START"
       281    fault("ILLEGAL %START")
       282    %return
       283  !-----------------------------------------------------------------------
       284  instype(4):! "RETURN"
       285    %if proctype(level)#1 %then fault("%RETURN OUT OF CONTEXT")
       286    dumpreturn
       287    %return
       288  !-----------------------------------------------------------------------
       289  instype(5):! "RESULT"'='<expr>
       290    %if proctype(level)#2 %then fault("%RESULT OUT OF CONTEXT")
       291    expr(a(instrp+1))
       292    dumpreturn
       293    %return
       294  !-----------------------------------------------------------------------
       295  instype(6):! "STOP"
       296    dump("STOP","","",0)
       297  %end
       298  %end
       299  %endoffile
      Code 7292 bytes  Glap 1256 bytes  Diags 1276 bytes   Total size 9824 bytes
         253 statements compiled

