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)

>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