         Source file: SKIMPD.IMP              Compiled on 25-OCT-1979 at 09:40:47

               Computer Science IMP77 Compiler.  Version 6.01

         1  %externalintegerarrayspec a(1:500)
         2  %externalbyteintegerarrayspec named(1:1024)
         3  %externalintegerarrayspec namedlink(0:255)
         4  %externalintegerarrayspec taglink(0:255)
         5  %externalintegerarrayspec tag(1:512)
         6  %externalintegerarrayspec link(1:512)
         7  %externalintegerarrayspec nextrad(0:15)
         8  %externalstring(4)%arrayspec display(0:15)
         9  %externalintegerspec tagasl,level,tagsopt,nextcad,namedp
        10  !-----------------------------------------------------------------------
        11  %externalroutinespec expr(%integer exprp)
        12  !-----------------------------------------------------------------------
        13  %ownintegerarray worklist(0:15)=0(16)
        14  %ownintegerarray namelist(0:15)=0(16)
        15  %ownintegerarray branchlist(0:15)=0(16)
        16  %ownintegerarray startlist(0:15)=0(16)
        17  %ownintegerarray cot(0:127)
        18  %owninteger cotp,faults,params
        19  !-----------------------------------------------------------------------
        20  %externalstring(255)%fn strint(%integer n,p)
        21  %string(255) r
        22  %string(1) s
        23    %if n<0 %then s="-" %and n=-n %else s=""
        24    r=""
        25    r=tostring(n-n//10*10+'0').r %and n=n//10 %until n=0
        26    r=s.r
        27    %while length(r)<p %then r=" ".r
        28    %result=r
        29  %end
        30  !-----------------------------------------------------------------------
        31  %externalstring(8)%fn strhex(%integer n)
        32  %conststring(1)%array h(0:15)="0","1","2","3","4","5","6","7","8",
        33+   "9","A","B","C","D","E","F"
        34  %integer i
        35  %string(8) sh
        36    sh=""
        37    %for i=1,1,8 %cycle
        38      sh=h(n&16_F).sh
        39      n=n>>4
        40    %repeat
        41    %result=sh
        42  %end
        43  !-----------------------------------------------------------------------
        44  %externalroutine fault(%string(63) mess)
        45    print string("*  ".mess."
        46+ 
        47+ ")
        48    faults=faults+1
        49  %end
        50  !-----------------------------------------------------------------------
        51  %externalroutine dump(%string(7) opn,reg,base,%integer disp)
        52    print string(strint(nextcad,5)."$          ". %c
        53+     opn.",".reg.",".base.",".strint(disp,1)."
        54+ ")
        55    nextcad=nextcad+1 %unless opn="FILL"
        56  %end
        57  !-----------------------------------------------------------------------
        58  %externalstring(255)%fn name(%integer ident)
        59    %unless 0<=ident<=255 %and namedlink(ident)#0 %then %result=""
        60    %result=string(addr(named(namedlink(ident))))
        61  %end
        62  !-----------------------------------------------------------------------
        63  %externalintegerfn newtag
        64  %integer i
        65    %if tagasl=0 %then fault("TAG SPACE FULL") %and %stop
        66    i=tagasl
        67    tagasl=link(tagasl)
        68  %result=i
        69  %end
        70  !-----------------------------------------------------------------------
        71  %externalintegerfn returntag(%integer tagi)
        72  %integer l
        73    l=link(tagi)
        74    link(tagi)=tagasl
        75    tagasl=tagi
        76    %result=l
        77  %end
        78  !-----------------------------------------------------------------------
        79  %externalintegerfn getwork
        80  %integername cell
        81    cell==worklist(level)
        82    %while cell#0 %cycle
        83      %if tag(cell)<0 %then tag(cell)=-tag(cell) %and %result=tag(cell)
        84      cell==link(cell)
        85    %repeat
        86    cell=newtag
        87    tag(cell)=nextrad(level)
        88    nextrad(level)=nextrad(level)+1
        89    link(cell)=0
        90    %result=tag(cell)
        91  %end
        92  !-----------------------------------------------------------------------
        93  %externalroutine returnwork(%integer work)
        94  %integer cell
        95    cell=worklist(level)
        96    %while cell#0 %cycle
        97      %if tag(cell)=work %then tag(cell)=-work %and %return
        98      cell=link(cell)
        99    %repeat
       100  %end
       101  !-----------------------------------------------------------------------
       102  %externalroutine clearwork
       103  %integer cell
       104    cell=worklist(level)
       105    %while cell#0 %then cell=returntag(cell)
       106    worklist(level)=0
       107  %end
       108  !-----------------------------------------------------------------------
       109  %externalintegerfn getcoti(%integer const)
       110  %integer coti
       111    %if cotp>0 %then %start
       112      %for coti=0,1,cotp-1 %cycle
       113        %if cot(coti)=const %then %result=coti
       114      %repeat
       115    %finish
       116    %if cotp=128 %then fault("CONSTANT TABLE FULL") %and %stop
       117    cot(cotp)=const
       118    cotp=cotp+1
       119    %result=cotp-1
       120  %end
       121  !-----------------------------------------------------------------------
       122  %externalroutine pushtag(%integer ident,form,type,dim,level,rad)
       123  %integer tagi
       124    %if taglink(ident)#0 %and tag(taglink(ident))>>16&16_F=level %then %c
       125+     fault("NAME ".name(ident)." DECLARED TWICE")
       126    tagi=newtag
       127    tag(tagi)=form<<28!type<<24!dim<<20!level<<16!rad
       128    link(tagi)=taglink(ident)
       129    taglink(ident)=tagi
       130    tagi=newtag
       131    tag(tagi)=ident
       132    link(tagi)=namelist(level)
       133    namelist(level)=tagi
       134  %end
       135  !-----------------------------------------------------------------------
       136  %externalroutine poptags
       137  %integer cell,ident,nametag,params
       138  %string(63) s
       139    %if tagsopt=1 %then newline
       140    cell=namelist(level)
       141    %while cell#0 %cycle
       142      ident=tag(cell)
       143      cell=returntag(cell)
       144      nametag=tag(taglink(ident))
       145      taglink(ident)=returntag(taglink(ident))
       146      %if tagsopt=1 %then %start
       147        s=name(ident)
       148        print string(strint(ident,3)."   ".s)
       149        spaces(10-length(s))
       150        print string(strhex(nametag))
       151      %finish
       152      %if nametag>>28=4 %then %start    ;! procedure type
       153        params=nametag>>20&16_F
       154        %while params#0 %cycle
       155          %if tagsopt=1 %then print string("   ". %c
       156+           strhex(tag(taglink(ident))))
       157          taglink(ident)=returntag(taglink(ident)) 
       158          params=params-1    ;! pop up parameter tags
       159        %repeat
       160      %finish
       161      %if tagsopt=1 %then newline
       162      %if taglink(ident)=0 %then namedp=namedlink(ident) %c
       163+       %and namedlink(ident)=0    ;! backtrack name dictionary
       164    %repeat
       165    %if tagsopt=1 %then newline
       166    namelist(level)=0
       167  %end
       168  !-----------------------------------------------------------------------
       169  %externalintegerfn getlabel(%integer constp)
       170  %integer label
       171    label=a(constp+1)
       172    %if label>9999 %then fault("LABEL ".strint(label,1)." TOO LARGE") %c
       173+     %and %result=-1 %else %result=label
       174  %end
       175  !-----------------------------------------------------------------------
       176  %externalroutine filllabel(%integer label)
       177  %integer cell
       178    %return %if label<0    ;! for conditional statements
       179    cell=branchlist(level)
       180    %while cell#0 %cycle
       181      %if tag(cell)>>16=label %then %start
       182        %if tag(cell)&16_8000=0 %then fault("DUPLICATE LABEL ". %c
       183+         strint(label,1)) %else %start
       184          dump("FILL",strint(label,1),strint(tag(cell)&16_7FFF,1),nextcad)
       185          tag(cell)=label<<16!nextcad
       186        %finish
       187        %return
       188      %finish
       189      cell=link(cell)
       190    %repeat
       191    cell=newtag
       192    link(cell)=branchlist(level)
       193    branchlist(level)=cell
       194    tag(cell)=label<<16!nextcad
       195  %end
       196  !-----------------------------------------------------------------------
       197  %externalintegerfn fillbranch(%integer label)
       198  %integer cell,cad
       199    %result=0 %if label<0
       200    cell=branchlist(level)
       201    %while cell#0 %cycle
       202      %if tag(cell)>>16=label %then %start
       203        cad=tag(cell)&16_7FFF
       204        %if tag(cell)&16_8000#0 %then tag(cell)=label<<16!16_8000!nextcad
       205        %result=cad
       206      %finish
       207      cell=link(cell)
       208    %repeat
       209    cell=newtag
       210    link(cell)=branchlist(level)
       211    branchlist(level)=cell
       212    tag(cell)=label<<16!16_8000!nextcad
       213    %result=0
       214  %end
       215  !-----------------------------------------------------------------------
       216  %externalroutine poplabels
       217  %integer cell
       218    cell=branchlist(level)
       219    %while cell#0 %cycle
       220      %if tag(cell)&16_8000#0 %then fault("LABEL ".strint(tag(cell)>>16,%c
       221+       1)." NOT SET (BRANCH LIST ".strint(tag(cell)&16_7FFF,1).")")
       222      cell=returntag(cell)
       223    %repeat
       224    branchlist(level)=0
       225  %end
       226  !-----------------------------------------------------------------------
       227  %externalintegerfn nextplabel
       228  %owninteger plabel=9999
       229    plabel=plabel+1
       230    %result=plabel
       231  %end
       232  !-----------------------------------------------------------------------
       233  %externalroutine pushstart(%integer flag,plab)
       234  %integer cell
       235    cell=newtag
       236    tag(cell)=flag<<16!plab&16_FFFF    ;! plab may be -1
       237    link(cell)=startlist(level)
       238    startlist(level)=cell
       239  %end
       240  !-----------------------------------------------------------------------
       241  %externalroutine popstart(%integername flag,plab)
       242  %integer cell
       243    cell=startlist(level)
       244    %if cell=0 %then %start
       245      fault("SPURIOUS %FINISH")
       246      flag=0
       247      plab=0
       248    %finish %else %start
       249      flag=tag(cell)>>16
       250      plab=tag(cell)&16_FFFF
       251      %if plab=16_FFFF %then plab=-1
       252      startlist(level)=returntag(cell)
       253    %finish
       254  %end
       255  !-----------------------------------------------------------------------
       256  %externalroutine clearstart
       257  %integer cell
       258    cell=startlist(level)
       259    %while cell#0 %then fault("%FINISH MISSING") %and cell=returntag(cell)
       260    startlist(level)=0
       261  %end
       262  !-----------------------------------------------------------------------
       263  %externalintegerfn enter
       264  %string(4) base
       265  %integer cad
       266    %if level=1 %then %start
       267      %if nextcad#0 %then fault("%BEGIN NOT FIRST STATEMENT")
       268      dump("LDA","COT","",0)    ;! cot base address to be filled
       269      dump("LDA","DR1","",0)    ;! stack base address to be filled
       270      base="DR1"
       271    %finish %else %start
       272      dump("STR",display(level),"STP",0)
       273      dump("LDA",display(level),"STP",0)
       274      dump("STR","WK","STP",1)
       275      base="STP"
       276    %finish
       277    cad=nextcad
       278    dump("LDA","STP",base,0)    ;! static allocation to be filled
       279    nextrad(level)=2
       280    %result=cad
       281  %end
       282  !-----------------------------------------------------------------------
       283  %externalroutine dumpreturn
       284    dump("LDA","STP",display(level),0)
       285    dump("LOAD",display(level),"STP",0)
       286    dump("LOAD","WK","STP",1)
       287    dump("B","","WK",0)
       288  %end
       289  !-----------------------------------------------------------------------
       290  %externalroutine array(%integer arrayp)
       291  %integer namep,actualp,exprp,exprsp,ident,nametag
       292    namep=a(arrayp+1)
       293    actualp=a(arrayp+2)
       294    ident=a(namep+1)
       295    %if a(actualp)=1 %then %start
       296      exprp=a(actualp+1)
       297      exprsp=a(actualp+2)
       298      expr(exprp)
       299      nametag=tag(taglink(ident))
       300      dump("ADD","ACC",display(nametag>>16&16_F),nametag&16_FFFF)
       301      %if a(exprsp)=1 %then fault("ARRAY ".name(ident)." HAS EXTRA INDEX")
       302    %finish %else fault("ARRAY ".name(ident)." HAS NO INDEX")
       303  %end
       304  !-----------------------------------------------------------------------
       305  %externalroutine proc(%integer procp)
       306  %string(4) opn,base
       307  %integer namep,ident,nametag,ptagl,l,actualp,exprp,unaryp,operandp, %c
       308+   npars,ptag,pnamep,pident,pnametag,pactualp,disp,exprrestp,exprsp, %c
       309+   oldparams
       310    %if params>2 %then dump("LDA","STP","STP",params)
       311    oldparams=params
       312    params=2
       313    namep=a(procp+1)
       314    actualp=a(procp+2)
       315    ident=a(namep+1)
       316    l=taglink(ident)
       317    nametag=tag(l)
       318    ptagl=link(l)
       319    npars=nametag>>20&16_F
       320    %if npars=0 %then %start
       321      %if a(actualp)=1 %then fault(name(ident)." HAS PARAMETERS") %c
       322+       %and %return
       323    %finish %else %start
       324      %if a(actualp)=2 %then fault(name(ident)." MISSING PARAMETERS") %c
       325+       %and %return
       326      exprp=a(actualp+1)
       327      exprsp=a(actualp+2)
       328      %cycle    ;! for each parameter
       329        ptag=tag(ptagl)
       330        %if ptag>>28=0 %then expr(exprp) %else %start
       331          unaryp=a(exprp+1)
       332          operandp=a(exprp+2)
       333          exprrestp=a(exprp+3)
       334          %unless a(unaryp)=4 %and a(operandp)=1 %and a(exprrestp)=2 %c
       335+           %then fault("NOT A %NAME PARAMETER") %else %start
       336            pnamep=a(operandp+1)
       337            pactualp=a(operandp+2)
       338            pident=a(pnamep+1)
       339            %if taglink(pident)=0 %then fault(name(pident). %c
       340+             " NOT DECLARED") %else %start
       341              pnametag=tag(taglink(pident))
       342              %if pnametag>>28=4 %then fault(name(pident). %c
       343+               " NOT A %NAME") %else %start
       344                base=display(pnametag>>16&16_F)
       345                disp=pnametag&16_FFFF
       346                %if ptag>>28=1 %then %start    ;! %name
       347                  %if pnametag>>28>=2 %then array(operandp) %else %start
       348                    %if pnametag>>28=1 %then opn="LOAD" %else opn="LDA"
       349                    dump(opn,"ACC",base,disp)
       350                    %if a(pactualp)=1 %then fault(name(pident). %c
       351+                     " DECLARED AS SCALAR")
       352                  %finish
       353                %finish %else %start
       354                  dump("LOAD","ACC",base,disp)    ;! %array
       355                  %if a(pactualp)=1 %then fault("%ARRAYNAME ". %c
       356+                    name(pident)." HAS INDEX")
       357                %finish
       358              %finish
       359            %finish
       360          %finish
       361        %finish
       362        dump("STR","ACC","STP",params)
       363        params=params+1
       364        npars=npars-1
       365        %if npars=0 %then %start
       366          %if a(exprsp)=1 %then fault(name(ident)." HAS EXTRA PARAMETERS")
       367          %exit
       368        %finish
       369        ptagl=link(ptagl)
       370        %if a(exprsp)=2 %then fault(name(ident). %c
       371+         " IS MISSING PARAMETERS") %and %exit
       372        exprp=a(exprsp+1)
       373        exprsp=a(exprsp+2)
       374      %repeat
       375    %finish
       376    ! external i/o routines at level 0
       377    %if nametag>>16&16_F=0 %then base="EXT" %else base=""
       378    dump("BAL","WK",base,nametag&16_FFFF)
       379    params=oldparams
       380    %if params>2 %then dump("SUB","STP","COT",getcoti(params))
       381  %end
       382  !-----------------------------------------------------------------------
       383  %externalroutine endofprog
       384  %integer i
       385    dump("FILL","COT","0",nextcad)
       386    i=0
       387    %while i<cotp %cycle
       388      dump("CONST","","",cot(i))
       389      i=i+1
       390    %repeat
       391    dump("FILL","STACK","1",nextcad)
       392    print string("
       393+      $".strint(faults,4)." FAULTS IN PROGRAM
       394+ ")
       395    %stop
       396  %end
       397  %endoffile
      Code 10012 bytes  Glap 1832 bytes  Diags 2391 bytes   Total size 14235 bytes
         345 statements compiled

